Once again syncing after too long an absence
Charles Bailey [Mon, 8 Jan 2001 08:53:52 +0000 (08:53 +0000)]
p4raw-id: //depot/vmsperl@8367

546 files changed:
AUTHORS
Changes5.6
Configure
EXTERN.h
INSTALL
INTERN.h
MAINTAIN [deleted file]
MANIFEST
Makefile.SH
Porting/Contract
Porting/Glossary
Porting/config.sh
Porting/config_H
Porting/genlog
Porting/pumpkin.pod
Porting/repository.pod [new file with mode: 0644]
README
README.aix
README.amiga
README.cygwin
README.dos
README.epoc
README.hpux
README.mpeix
README.os2
README.os390
README.solaris [new file with mode: 0644]
README.vos
README.win32
av.c
av.h
bytecode.pl
config_h.SH
configure.com
cop.h
cv.h
cygwin/cygwin.c
deb.c
djgpp/config.over
djgpp/djgpp.c
doio.c
doop.c
dump.c
emacs/cperl-mode.el
emacs/ptags
embed.h
embed.pl
embedvar.h
epoc/config.sh
epoc/epoc.c
epoc/epocish.c
ext/B/B.pm
ext/B/B.xs
ext/B/B/C.pm
ext/B/B/Deparse.pm
ext/B/B/Lint.pm
ext/B/B/Terse.pm
ext/ByteLoader/ByteLoader.xs
ext/ByteLoader/byterun.c
ext/DB_File/Changes
ext/DB_File/DB_File.pm
ext/DB_File/DB_File.xs
ext/DB_File/dbinfo
ext/DB_File/typemap
ext/DB_File/version.c
ext/Devel/DProf/DProf.xs
ext/Devel/Peek/Peek.xs
ext/DynaLoader/DynaLoader_pm.PL
ext/DynaLoader/dl_aix.xs
ext/Encode/Encode.pm
ext/Encode/Encode.xs
ext/Encode/Encode/EncodeFormat.pod [new file with mode: 0644]
ext/Encode/Encode/ascii.enc
ext/Encode/Encode/cp1006.enc [new file with mode: 0644]
ext/Encode/Encode/cp1047.enc [new file with mode: 0644]
ext/Encode/Encode/cp37.enc [new file with mode: 0644]
ext/Encode/Encode/cp424.enc [new file with mode: 0644]
ext/Encode/Encode/cp856.enc [new file with mode: 0644]
ext/Encode/Encode/gsm0338.enc [new file with mode: 0644]
ext/Encode/Encode/iso8859-10.enc [new file with mode: 0644]
ext/Encode/Encode/iso8859-13.enc [new file with mode: 0644]
ext/Encode/Encode/iso8859-14.enc [new file with mode: 0644]
ext/Encode/Encode/iso8859-15.enc [new file with mode: 0644]
ext/Encode/Encode/iso8859-16.enc [new file with mode: 0644]
ext/Encode/Encode/posix-bc.enc [new file with mode: 0644]
ext/Encode/Makefile.PL
ext/Encode/compile [new file with mode: 0755]
ext/Encode/encengine.c [new file with mode: 0644]
ext/Encode/encode.h [new file with mode: 0644]
ext/Errno/Errno_pm.PL
ext/Fcntl/Fcntl.pm
ext/Fcntl/Fcntl.xs
ext/Filter/Util/Call/Call.pm [new file with mode: 0644]
ext/Filter/Util/Call/Call.xs [new file with mode: 0644]
ext/Filter/Util/Call/Makefile.PL [new file with mode: 0644]
ext/GDBM_File/GDBM_File.pm
ext/GDBM_File/GDBM_File.xs
ext/GDBM_File/typemap
ext/IO/IO.xs
ext/IO/lib/IO/Handle.pm
ext/IO/lib/IO/Seekable.pm
ext/IO/lib/IO/Select.pm
ext/IPC/SysV/SysV.xs
ext/NDBM_File/NDBM_File.pm
ext/NDBM_File/NDBM_File.xs
ext/NDBM_File/typemap
ext/ODBM_File/ODBM_File.pm
ext/ODBM_File/ODBM_File.xs
ext/ODBM_File/typemap
ext/Opcode/Opcode.pm
ext/Opcode/Opcode.xs
ext/POSIX/Makefile.PL
ext/POSIX/POSIX.pm
ext/POSIX/POSIX.pod
ext/POSIX/POSIX.xs
ext/POSIX/hints/svr4.pl [new file with mode: 0644]
ext/POSIX/typemap
ext/SDBM_File/Makefile.PL
ext/SDBM_File/SDBM_File.pm
ext/SDBM_File/sdbm/sdbm.c
ext/SDBM_File/typemap
ext/Storable/ChangeLog
ext/Storable/Makefile.PL
ext/Storable/Storable.pm
ext/Storable/Storable.xs
ext/Sys/Syslog/Syslog.pm
ext/Thread/Thread.pm
ext/Thread/Thread.xs
ext/re/Makefile.PL
ext/re/hints/aix.pl [new file with mode: 0644]
ext/re/re.xs
fakesdio.h [new file with mode: 0644]
fix_pl [deleted file]
form.h
global.sym
gv.c
gv.h
handy.h
hints/aix.sh
hints/cygwin.sh
hints/dec_osf.sh
hints/dos_djgpp.sh
hints/freebsd.sh
hints/hpux.sh
hints/linux.sh
hints/machten.sh
hints/nonstopux.sh
hints/openbsd.sh
hints/solaris_2.sh
hints/svr4.sh
hints/uts.sh
hints/uwin.sh
hints/vmesa.sh
hv.c
hv.h
installhtml
installman
installperl
intrpvar.h
iperlsys.h
lib/AnyDBM_File.pm
lib/CGI.pm
lib/CGI/Apache.pm
lib/CGI/Switch.pm
lib/CPAN.pm
lib/CPAN/FirstTime.pm
lib/Carp.pm
lib/Carp/Heavy.pm
lib/Class/Struct.pm
lib/Cwd.pm
lib/DirHandle.pm
lib/Dumpvalue.pm
lib/English.pm
lib/Env.pm
lib/Exporter.pm
lib/Exporter/Heavy.pm
lib/ExtUtils/Install.pm
lib/ExtUtils/Liblist.pm
lib/ExtUtils/MANIFEST.SKIP [new file with mode: 0644]
lib/ExtUtils/MM_Cygwin.pm
lib/ExtUtils/MM_OS2.pm
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/MM_VMS.pm
lib/ExtUtils/MM_Win32.pm
lib/ExtUtils/MakeMaker.pm
lib/ExtUtils/Manifest.pm
lib/ExtUtils/Mksymlists.pm
lib/ExtUtils/typemap
lib/ExtUtils/xsubpp
lib/File/Basename.pm
lib/File/CheckTree.pm
lib/File/DosGlob.pm
lib/File/Find.pm
lib/File/Path.pm
lib/File/Spec.pm
lib/File/Spec/Epoc.pm [new file with mode: 0644]
lib/File/Spec/Functions.pm
lib/File/Spec/Unix.pm
lib/File/Temp.pm
lib/File/stat.pm
lib/FileCache.pm
lib/Filter/Simple.pm [new file with mode: 0644]
lib/Getopt/Long.pm
lib/I18N/Collate.pm
lib/Math/Complex.pm
lib/Net/Ping.pm
lib/Net/hostent.pm
lib/Net/netent.pm
lib/Net/protoent.pm
lib/Net/servent.pm
lib/Pod/Checker.pm
lib/Pod/Functions.pm
lib/Pod/Html.pm
lib/Pod/Man.pm
lib/Pod/Select.pm
lib/Pod/Text.pm
lib/Pod/Text/Color.pm
lib/Pod/Text/Overstrike.pm [new file with mode: 0644]
lib/Pod/Text/Termcap.pm
lib/Search/Dict.pm
lib/SelectSaver.pm
lib/Term/Cap.pm
lib/Term/Complete.pm
lib/Term/ReadLine.pm
lib/Test.pm
lib/Test/Harness.pm
lib/Text/Abbrev.pm
lib/Text/ParseWords.pm
lib/Tie/Array.pm
lib/Tie/Hash.pm
lib/Tie/RefHash.pm
lib/Tie/Scalar.pm
lib/Tie/SubstrHash.pm
lib/Time/Local.pm
lib/Time/tm.pm
lib/UNIVERSAL.pm
lib/User/grent.pm
lib/User/pwent.pm
lib/Win32.pod
lib/bytes.pm
lib/charnames.pm
lib/constant.pm
lib/diagnostics.pm
lib/filetest.pm
lib/ftp.pl
lib/integer.pm
lib/less.pm
lib/lib_pm.PL
lib/locale.pm
lib/open.pm
lib/overload.pm
lib/perl5db.pl
lib/perlio.pm [new file with mode: 0644]
lib/strict.pm
lib/subs.pm
lib/unicode/Is/Alnum.pl
lib/unicode/Is/Alpha.pl
lib/unicode/Is/Blank.pl [new file with mode: 0644]
lib/unicode/Is/DCmedial.pl [new file with mode: 0644]
lib/unicode/Is/Graph.pl
lib/unicode/Is/Print.pl
lib/unicode/Is/Punct.pl
lib/unicode/Is/Space.pl
lib/unicode/Is/SpacePerl.pl [new file with mode: 0644]
lib/unicode/Is/Word.pl
lib/unicode/distinct.pm [new file with mode: 0644]
lib/unicode/mktables.PL
lib/unicode/syllables.txt
lib/utf8.pm
lib/vars.pm
lib/warnings.pm
lib/warnings/register.pm
makedef.pl
malloc.c
mg.c
mg.h
minimod.pl
nostdio.h
objXSUB.h
op.c
op.h
opcode.pl
opnames.h
os2/OS2/ExtAttr/Makefile.PL
os2/OS2/PrfDB/Makefile.PL
os2/OS2/Process/Makefile.PL
os2/OS2/REXX/DLL/Makefile.PL
os2/OS2/REXX/Makefile.PL
os2/OS2/REXX/REXX.xs
os2/os2.c
os2/os2ish.h
patchlevel.h
perl.c
perl.h
perlapi.c
perlapi.h
perlio.c
perlio.h
perliol.h [new file with mode: 0644]
perlsdio.h
perlsfio.h
perly.c
perly.y
pod/Makefile.SH
pod/buildtoc.PL
pod/perl.pod
pod/perl5004delta.pod
pod/perl5005delta.pod
pod/perl56delta.pod
pod/perlapi.pod
pod/perldebguts.pod
pod/perldebtut.pod
pod/perldebug.pod
pod/perldiag.pod
pod/perlebcdic.pod
pod/perlembed.pod
pod/perlfaq.pod
pod/perlfaq1.pod
pod/perlfaq2.pod
pod/perlfaq3.pod
pod/perlfaq4.pod
pod/perlfaq5.pod
pod/perlfaq6.pod
pod/perlfaq7.pod
pod/perlfaq8.pod
pod/perlfaq9.pod
pod/perlfilter.pod
pod/perlfunc.pod
pod/perlguts.pod
pod/perlhack.pod
pod/perlhist.pod
pod/perlintern.pod
pod/perlipc.pod
pod/perllexwarn.pod
pod/perllocale.pod
pod/perlmodlib.PL
pod/perlmodlib.pod
pod/perlnumber.pod
pod/perlop.pod
pod/perlopentut.pod
pod/perlpod.pod
pod/perlport.pod
pod/perlre.pod
pod/perlreftut.pod
pod/perlrequick.pod
pod/perlretut.pod
pod/perlrun.pod
pod/perlsec.pod
pod/perlsub.pod
pod/perltie.pod
pod/perltoc.pod
pod/perltodo.pod
pod/perltoot.pod
pod/perltootc.pod
pod/perlunicode.pod
pod/perlvar.pod
pod/perlxs.pod
pod/perlxstut.pod
pod/pod2man.PL
pod/pod2text.PL
pp.c
pp.h
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regcomp.c
regcomp.h
regcomp.sym
regexec.c
regexp.h
regnodes.h
run.c
scope.c
scope.h
sv.c
sv.h
t/README
t/TEST
t/UTEST
t/base/commonsense.t [new file with mode: 0644]
t/base/term.t
t/comp/proto.t
t/comp/redef.t
t/comp/require.t
t/io/dup.t
t/io/fs.t
t/io/open.t
t/io/pipe.t
t/io/tell.t
t/io/utf8.t [new file with mode: 0755]
t/lib/attrs.t
t/lib/b.t
t/lib/bigfltpm.t
t/lib/cgi-function.t
t/lib/cgi-html.t
t/lib/class-struct.t [new file with mode: 0644]
t/lib/db-btree.t
t/lib/db-hash.t
t/lib/db-recno.t
t/lib/dprof.t
t/lib/dprof/V.pm
t/lib/encode.t
t/lib/filter-util.pl [new file with mode: 0644]
t/lib/filter-util.t [new file with mode: 0644]
t/lib/ftmp-mktemp.t
t/lib/ftmp-posix.t
t/lib/ftmp-tempfile.t
t/lib/gdbm.t
t/lib/io_sock.t
t/lib/io_tell.t
t/lib/io_udp.t
t/lib/io_xs.t
t/lib/ndbm.t
t/lib/net-hostent.t [new file with mode: 0644]
t/lib/odbm.t
t/lib/peek.t
t/lib/sdbm.t
t/lib/st-lock.t
t/lib/st-recurse.t
t/lib/syslfs.t
t/lib/syslog.t
t/lib/thr5005.t
t/lib/tie-refhash.t [new file with mode: 0644]
t/lib/tie-splice.t [new file with mode: 0644]
t/lib/tie-substrhash.t [new file with mode: 0644]
t/op/64bitint.t
t/op/array.t
t/op/assignwarn.t
t/op/attrs.t
t/op/bop.t
t/op/chop.t
t/op/cmp.t
t/op/concat.t [new file with mode: 0644]
t/op/each.t
t/op/fork.t
t/op/goto_xs.t
t/op/join.t
t/op/length.t [new file with mode: 0644]
t/op/lfs.t
t/op/local.t
t/op/method.t
t/op/misc.t
t/op/numconvert.t
t/op/ord.t
t/op/pat.t
t/op/pos.t
t/op/re_tests
t/op/ref.t
t/op/regexp.t
t/op/regmesg.t
t/op/reverse.t [new file with mode: 0644]
t/op/sort.t
t/op/split.t
t/op/sprintf.t
t/op/taint.t
t/op/tie.t
t/op/utf8decode.t [new file with mode: 0644]
t/op/ver.t
t/op/write.t
t/pragma/constant.t
t/pragma/locale.t
t/pragma/overload.t
t/pragma/sub_lval.t
t/pragma/utf8.t
t/pragma/warn/pp_hot
t/pragma/warn/pp_sys
t/pragma/warn/utf8
t/pragma/warnings.t
taint.c
thrdvar.h
toke.c
uconfig.h
uconfig.sh
universal.c
unixish.h
utf8.c
utf8.h
util.c
util.h
utils/h2xs.PL
utils/perlbug.PL
utils/perlcc.PL
utils/perldoc.PL
vmesa/vmesa.c
vms/descrip_mms.template
vms/ext/DCLsym/Makefile.PL
vms/ext/Stdio/Makefile.PL
vms/ext/Stdio/Stdio.pm
vms/ext/Stdio/Stdio.xs
vms/gen_shrfls.pl
vms/genconfig.pl
vms/perlvms.pod
vms/perly_c.vms
vms/test.com
vms/vms.c
vms/vmsish.h
vms/vmspipe.com
vos/Changes
vos/build.cm
vos/compile_perl.cm
vos/config.alpha.def [copied from vos/config.def with 94% similarity]
vos/config.alpha.h [moved from vos/config.h with 96% similarity]
vos/config.ga.def [moved from vos/config.def with 88% similarity]
vos/config.ga.h [moved from vos/config_h.SH_orig with 83% similarity, mode: 0644]
vos/config.pl
vos/configure_perl.cm [new file with mode: 0644]
vos/install_perl.cm [new file with mode: 0644]
vos/perl.bind
vos/vosish.h
warnings.pl
win32/Makefile
win32/bin/mdelete.bat [new file with mode: 0644]
win32/bin/search.pl
win32/config.bc
win32/config.gc
win32/config.vc
win32/config_H.bc
win32/config_H.gc
win32/config_H.vc
win32/config_h.PL
win32/distclean.bat [new file with mode: 0755]
win32/include/sys/socket.h
win32/makefile.mk
win32/perlhost.h
win32/perllib.c
win32/vdir.h
win32/win32.c
win32/win32.h
win32/win32iop.h
win32/win32sck.c
win32/win32thread.h
x2p/EXTERN.h
x2p/INTERN.h
x2p/a2p.c
x2p/a2p.h
x2p/a2p.y
x2p/find2perl.PL
x2p/hash.c
x2p/hash.h
x2p/proto.h
x2p/str.c
x2p/str.h
x2p/util.c
x2p/util.h
x2p/walk.c

diff --git a/AUTHORS b/AUTHORS
index b3d240c..e3bc2af 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
-# Two sections: the real one and the virtual one.
-# The real section has three \t+ fields: alias, name, email.
-# The sections are separated by one or more empty lines.
-# The virtual section (each record two \t+ separated fields) builds
-# meta-aliases based on the real section.
-
-alan.burlison  Alan Burlison           Alan.Burlison@UK.Sun.com
-allen          Norton T. Allen         allen@huarp.harvard.edu
-bradapp                Brad Appleton           bradapp@enteract.com
-cbail          Charles Bailey          bailey@newman.upenn.edu
-dgris          Daniel Grisinger        dgris@dimensional.com
-dmulholl       Daniel Yacob            dmulholl@cs.indiana.edu
-dogcow         Tom Spindler            dogcow@merit.edu
-domo           Dominic Dunlop          domo@computer.org
-doug           Doug MacEachern         dougm@covalent.net
-doughera       Andy Dougherty          doughera@lafcol.lafayette.edu
-efifer         Eric Fifer              EFifer@sanwaint.com
-francois       Francois Desarmenien    desar@club-internet.fr
-gbarr          Graham Barr             gbarr@ti.com
-gerben         Gerben Wierda           Gerben_Wierda@RnA.nl
-gerti          Gerd Knops              gerti@BITart.com
-gibreel                Stephen Zander          gibreel@pobox.com
-gnat           Nathan Torkington       gnat@frii.com
-gsar           Gurusamy Sarathy        gsar@activestate.com
-hansmu         Hans Mulder             hansmu@xs4all.nl
-hops           Mike Hopkirk            hops@sco.com
-hugo           Hugo van der Sanden     hv@crypt.demon.co.uk
-ilya           Ilya Zakharevich        ilya@math.ohio-state.edu
-jbuehler       Joe Buehler             jbuehler@hekimian.com
-jfs            John Stoffel            jfs@fluent.com
-jhi            Jarkko Hietaniemi       jhi@iki.fi
-jon            Jon Orwant              orwant@oreilly.com
-jvromans       Johan Vromans           jvromans@squirrel.nl
-k              Andreas König           a.koenig@mind.de
-kjahds         Kenneth Albanowski      kjahds@kjahds.com
-krishna                Krishna Sethuraman      krishna@sgi.com
-kstar          Kurt D. Starsinic       kstar@chapin.edu
-lane           Charles Lane            lane@DUPHY4.Physics.Drexel.Edu
-lstein         Lincoln D. Stein        lstein@genome.wi.mit.edu
-lutherh                Luther Huffman          lutherh@stratcom.com
-lutz           Mark P. Lutz            mark.p.lutz@boeing.com
-lwall          Larry Wall              larry@wall.org
-makemaker      MakeMaker list          makemaker@franz.ww.tu-berlin.de
-mbiggar                Mark A Biggar           mab@wdl.loral.com
-mbligh         Martin J. Bligh         mbligh@sequent.com
-mikestok       Mike Stok               mike@stok.co.uk
-millert                Todd Miller             millert@openbsd.org
-mkvale         Mark Kvale              kvale@phy.ucsf.edu
-mjd            Mark-Jason Dominus      mjd@plover.com
-mjtg           Mike Guy                mjtg@cam.ac.uk
-laszlo.molnar  Laszlo Molnar           Laszlo.Molnar@eth.ericsson.se
-mpeix          Mark Bixby              markb@cccd.edu
-muir           David Muir Sharnoff     muir@idiom.com
-neale          Neale Ferguson          neale@VMA.TABNSW.COM.AU
-nik            Nick Ing-Simmons        nik@tiuk.ti.com
-okamoto                Jeff Okamoto            okamoto@corp.hp.com
-paul_green     Paul Green              Paul_Green@stratus.com
-pmarquess      Paul Marquess           Paul.Marquess@btinternet.com
-pomeranz       Hal Pomeranz            pomeranz@netcom.com
-pudge          Chris Nandor            pudge@pobox.com
-pueschel       Norbert Pueschel        pueschel@imsdd.meb.uni-bonn.de
-pvhp           Peter Prymmer           pvhp@forte.com
-raphael                Raphael Manfredi        Raphael.Manfredi@pobox.com
-rdieter                Rex Dieter              rdieter@math.unl.edu
-richard                Richard Foley           Richard.Foley@m.dasa.de
-rra            Russ Allbery            rra@stanford.edu
-rsanders       Robert Sanders          Robert.Sanders@linux.org        
-roberto                Ollivier Robert         roberto@keltia.freenix.fr
-roderick       Roderick Schertler      roderick@argon.org
-roehrich       Dean Roehrich           roehrich@cray.com
-tsanders       Tony Sanders            sanders@bsdi.com
-schinder       Paul Schinder           schinder@pobox.com
-scotth         Scott Henry             scotth@sgi.com
-seibert                Greg Seibert            seibert@Lynx.COM
-simon          Simon Cozens            simon@brecon.co.uk
-spider         Spider Boardman         spider@Orb.Nashua.NH.US
-smccam         Stephen McCamant        smccam@uclink4.berkeley.edu
-sthoenna       Yitzchak Scott-Thoennes sthoenna@efn.org
-sugalskd       Dan Sugalski            dan@sidhe.org
-sundstrom      David Sundstrom         sunds@asictest.sc.ti.com
-tchrist                Tom Christiansen        tchrist@perl.com
-thomas.dorner  Dorner Thomas           Thomas.Dorner@start.de
-tjenness       Tim Jenness             t.jenness@jach.hawaii.edu
-timb           Tim Bunce               Tim.Bunce@ig.co.uk
-tom.horsley    Tom Horsley             Tom.Horsley@mail.ccur.com
-tye            Tye McQueen             tye@metronet.com
-wayne.thompson Wayne Thompson          Wayne.Thompson@Ebay.sun.com
-wilfredo       Wilfredo Sánchez        wsanchez@apple.com
-
-PUMPKING       jhi
-aix            jhi
-amiga          pueschel
-beos           dogcow
-bsdos          tsanders
-cfg            jhi
-cgi            lstein
-complex                jhi,raphael
-cpan           k
-cxux           tom.horsley
-cygwin         win32
-dec_osf                jhi,spider
-dgux           roderick
-doc            tchrist
-dos            laszlo.molnar
-dynix/ptx      mbligh
-ebcdic         os390,vmesa,posix-bc
-filespec       kjahds
-freebsd                roberto
-hpux           okamoto,jhi
-irix           scotth,krishna,jfs,kstar
-jpl            gibreel
-lexwarn                pmarquess
-linux          kjahds,kstar
-locale         jhi,domo
-machten                domo
-mm             makemaker
-netbsd         jhi
-next           gerben,hansmu
-openbsd                millert
-os2            ilya
-os390          pvhp
-plan9          lutherl
-posix-bc       thomas.dorner
-powerux                tom.horsley
-qnx            allen
-regex          ilya,jfriedl,hugo,mjd
-sco            francois,hops
-solaris                doughera,alan.burlison
-step           gerti,hansmu,rdieter
-sunos4         doughera
-svr4           tye
-unicos         jhi,lutz
-uwin           jbuehler
-vmesa          neale
-vms            sugalskd,cbail
-vos            paul_green
-warn           pmarquess
-win32          gsar
+# To give due honor to those who have made Perl 5 what is is today,
+# here are easily-from-changelogs-extractable people and their
+# (hopefully) current and preferred email addresses (as of late 2000
+# if known) from the Changes files.  These people have either submitted
+# patches or suggestions, or their bug reports or comments have inspired
+# the appropriate patches.  Corrections, additions, deletions welcome.
+#
+-- 
+Aaron B. Dossett               <aaron@iglou.com>
+Abigail                        <abigail@foad.org>
+Achim Bohnet                   <ach@mpe.mpg.de>
+Adam Krolnik                   <adamk@gypsy.cyrix.com>
+Akim Demaille                  <akim@epita.fr>
+Alan Burlison                  <Alan.Burlison@uk.sun.com>
+Alan Champion                  <achampio@lehman.com>
+Alan Harder                    <Alan.Harder@Ebay.Sun.COM>
+Alan Modra
+Albert Chin-A-Young            <china@thewrittenword.com>
+Albert Dvornik                 <bert@genscan.com>
+Alexander Smishlajev           <als@turnhere.com>
+Allen Smith                    <easmith@beatrice.rutgers.edu>
+Ambrose Kofi Laing
+Andreas Klussmann              <andreas@infosys.heitec.de>
+Andreas König                  <a.koenig@mind.de>
+Andreas Schwab                 <schwab@suse.de>
+Andrew Bettison                <andrewb@zip.com.au>
+Andrew Cohen                   <cohen@andy.bu.edu>
+Andrew M. Langmead             <aml@world.std.com>
+Andrew Pimlott                 <pimlott@abel.math.harvard.edu>
+Andrew Vignaux                 <ajv@nz.sangacorp.com>
+Andrew Wilcox                  <awilcox@maine.com>
+Andy Dougherty                 <doughera@lafayette.edu>
+Anno Siegel                    <anno4000@lublin.zrz.tu-berlin.de>
+Anthony David                  <adavid@netinfo.com.au>
+Anton Berezin                  <tobez@tobez.org>
+Art Green                      <Art_Green@mercmarine.com>
+Artur                          <artur@vogon-solutions.com>
+Barrie Slaymaker               <barries@slaysys.com>
+Barry Friedman
+Ben Tilly                      <ben_tilly@hotmail.com>
+Benjamin Low                   <b.d.low@unsw.edu.au>
+Benjamin Stuhl                 <sho_pi@hotmail.com>
+Benjamin Sugars                <bsugars@canoe.ca>
+Bernard Quatermass             <bernard@quatermass.co.uk>
+Bill Campbell                  <bill@celestial.com>
+Bill Glicker                   <billg@burrelles.com>
+Billy Constantine              <wdconsta@cs.adelaide.edu.au>
+Blair Zajac                    <bzajac@geostaff.com>
+Boyd Gerber                    <gerberb@zenez.com>
+Brad Appleton                  <bradapp@enteract.com>
+Brad Howerter                  <bhower@wgc.woodward.com>
+Brad Hughes                    <brad@tgsmc.com>
+Brad Lanam                     <bll@gentoo.com>
+Brent B. Powers                <powers@ml.com>
+Brian Callaghan                <callagh@itginc.com>
+Brian Clarke                   <clarke@appliedmeta.com>
+Brian Grossman
+Brian Harrison                 <brie@corp.home.net>
+Brian Jepson                   <bjepson@home.com>
+Brian Katzung
+Brian Reichert                 <reichert@internet.com>
+Brian S. Cashman               <bsc@umich.edu>
+Bruce Barnett                  <barnett@grymoire.crd.ge.com>
+Bruce J. Keeler                <bkeelerx@iwa.dp.intel.com>
+Bruce P. Schuck                <bruce@aps.org>
+Bud Huff                       <BAHUFF@us.oracle.com>
+Byron Brummer                  <byron@omix.com>
+Calle Dybedahl                 <calle@lysator.liu.se>
+Carl M. Fongheiser             <cmf@ins.infonet.net>
+Carl Witty                     <cwitty@newtonlabs.com>
+Cary D. Renzema                <caryr@mxim.com>
+Casey R. Tweten                <crt@kiski.net>
+Castor Fu
+Chaim Frenkel                  <chaimf@pobox.com>
+Charles Bailey                 <bailey@newman.upenn.edu>
+Charles F. Randall             <crandall@free.click-n-call.com>
+Charles Lane                   <lane@DUPHY4.Physics.Drexel.Edu>
+Charles Wilson                 <cwilson@ece.gatech.edu>
+Chip Salzenberg                <chip@pobox.com>
+Chris Faylor                   <cgf@bbc.com>
+Chris Nandor                   <pudge@pobox.com>
+Chris Wick                     <cwick@lmc.com>
+Christian Kirsch               <ck@held.mind.de>
+Christopher Chan-Nui           <channui@austin.ibm.com>
+Christopher Davis              <ckd@loiosh.kei.com>
+Chuck D. Phillips              <cdp@hpescdp.fc.hp.com>
+Chuck Phillips                 <cdp@fc.hp.com>
+Chunhui Teng                   <cteng@nortel.ca>
+Clark Cooper                   <coopercc@netheaven.com>
+Clinton Pierce                 <cpierce1@ford.com>
+Colin Kuskie                   <ckuskie@cadence.com>
+Conrad Augustin
+Conrad E. Kimball              <cek@tblv021.ca.boeing.com>
+Craig A. Berry                 <craig.berry@psinetcs.com>
+Craig Milo Rogers              <Rogers@ISI.EDU>
+Dale Amon                      <amon@vnl.com>
+Damian Conway                  <damian@cs.monash.edu.au>
+Damon Atkins                   <Damon.Atkins@nabaus.com.au>
+Dan Boorstein                  <dan_boo@bellsouth.net>
+Dan Carson                     <dbc@tc.fluke.COM>
+Dan Schmidt                    <dfan@harmonixmusic.com>
+Dan Sugalski                   <dan@sidhe.org>
+Daniel Chetlin                 <daniel@chetlin.com>
+Daniel Grisinger               <dgris@dimensional.com>
+Daniel Muiño                   <dmuino@afip.gov.ar>
+Daniel S. Lewart               <lewart@vadds.cvm.uiuc.edu>
+Daniel Yacob                   <dmulholl@cs.indiana.edu>
+Danny R. Faught                <faught@mailhost.rsn.hp.com>
+Danny Sadinoff                 <sadinoff@olf.com>
+Darrell Kindred                <dkindred+@cmu.edu>
+Darrell Schiebel               <drs@nrao.edu>
+Darren/Torin/Who Ever...       <torin@daft.com>
+Dave Bianchi
+Dave Hartnoll                  <Dave_Hartnoll@3b2.com>
+Dave Nelson                    <David.Nelson@bellcow.com>
+Dave Schweisguth               <dcs@neutron.chem.yale.edu>
+David Billinghurst             <David.Billinghurst@riotinto.com.au>
+David Campbell
+David Couture
+David Denholm                  <denholm@conmat.phys.soton.ac.uk>
+David Dyck                     <dcd@tc.fluke.com>
+David F. Haertig               <dfh@dwroll.lucent.com>
+David Filo
+David Glasser                  <me@davidglasser.net>
+David Hammen                   <hammen@gothamcity.jsc.nasa.gov>
+David J. Fiander               <davidf@mks.com>
+David Kerry                    <davidk@tor.securecomputing.com>
+David Muir Sharnoff            <muir@idiom.com>
+David R. Favor                 <dfavor@austin.ibm.com>
+David Sparks                   <daves@ActiveState.com>
+David Starks-Browning          <dstarks@rc.tudelft.nl>
+David Sundstrom                <sunds@asictest.sc.ti.com>
+Davin Milun                    <milun@cs.Buffalo.EDU>
+Dean Roehrich                  <roehrich@cray.com>
+Dennis Marsa                   <dennism@cyrix.com>
+dive                           <dive@ender.com>
+Dominic Dunlop                 <domo@computer.org>
+Dominique Dumont               <Dominique_Dumont@grenoble.hp.com>
+Doug Campbell                  <soup@ampersand.com>
+Doug MacEachern                <dougm@covalent.net>
+Douglas E. Wegscheid           <wegscd@whirlpool.com>
+Douglas Lankshear              <dougl@activestate.com>
+Dov Grobgeld                   <dov@Orbotech.Co.IL>
+Drago Goricanec                <drago@raptor.otsd.ts.fujitsu.co.jp>
+Ed Mooring                     <mooring@Lynx.COM>
+Ed Peschko                     <epeschko@den-mdev1>
+Elaine -HFB- Ashton            <elaine@chaos.wustl.edu>
+Eric Arnold                    <eric.arnold@sun.com>
+Eric Bartley                   <bartley@icd.cc.purdue.edu>
+Eric E. Coe                    <Eric.Coe@oracle.com>
+Eric Fifer                     <egf7@columbia.edu>
+Erich Rickheit
+Eryq                           <eryq@zeegee.com>
+Etienne Grossman               <etienne@isr.isr.ist.utl.pt>
+Eugene Alterman                <Eugene.Alterman@bremer-inc.com>
+Fabien Tassin                  <tassin@eerie.fr>
+Felix Gallo                    <fgallo@etoys.com>
+Florent Guillaume
+Frank Crawford
+Frank Ridderbusch              <Frank.Ridderbusch@pdb.siemens.de>
+Frank Tobin                    <ftobin@uiuc.edu>
+François Désarménien           <desar@club-internet.fr>
+Fréderic Chauveau              <fmc@pasteur.fr>
+G. Del Merritt                 <del@intranetics.com>
+Gabe Schaffer
+Gary Clark                     <GaryC@mail.jeld-wen.com>
+Gary Ng                        <71564.1743@compuserve.com>
+Gerben Wierda                  <G.C.Th.Wierda@AWT.nl>
+Gerd Knops                     <gerti@BITart.com>
+Giles Lean                     <giles@nemeton.com.au>
+Gisle Aas                      <gisle@aas.no>
+Gordon J. Miller               <gjm@cray.com>
+Grace Lee                      <grace@hal.com>
+Graham Barr                    <gbarr@pobox.com>
+Graham TerMarsch               <grahamt@ActiveState.com>
+Greg Bacon                     <gbacon@itsc.uah.edu>
+Greg Chapman                   <glc@well.com>
+Greg Earle
+Greg Kuperberg
+Greg Seibert                   <seibert@Lynx.COM>
+Greg Ward                      <gward@ase.com>
+Gregory Martin Pfeil           <pfeilgm@technomadic.org>
+Guenter Schmidt                <gsc@bruker.de>
+Guido Flohr                    <gufl0000@stud.uni-sb.de>
+Gurusamy Sarathy               <gsar@activestate.com>
+Gustaf Neumann
+Guy Decoux                     <decoux@moulon.inra.fr>
+H.J. Lu                        <hjl@nynexst.com>
+H.Merijn Brand                 <h.m.brand@hccnet.nl>
+Hal Pomeranz                   <pomeranz@netcom.com>
+Hallvard B Furuseth            <h.b.furuseth@usit.uio.no>
+Hannu Napari                   <Hannu.Napari@hut.fi>
+Hans Mulder                    <hansmu@xs4all.nl>
+Hans de Graaff                 <J.J.deGraaff@twi.tudelft.nl>
+Harold O Morris                <hom00@utsglobal.com>
+Harry Edmon                    <harry@atmos.washington.edu>
+Helmut Jarausch                <jarausch@numa1.igpm.rwth-aachen.de>
+Henrik Tougaard                <ht.000@foa.dk>
+Hershel Walters                <walters@smd4d.wes.army.mil>
+Holger Bechtold
+Horst von Brand                <vonbrand@sleipnir.valparaiso.cl>
+Hubert Feyrer                  <hubert.feyrer@informatik.fh-regensburg.de>
+Hugo van der Sanden            <hv@crypt0.demon.co.uk>
+Hunter Kelly                   <retnuh@zule.pixar.com>
+Huw Rogers                     <count0@gremlin.straylight.co.jp>
+Ian Maloney                    <ian.malonet@ubs.com>
+Ian Phillipps                  <ian@dial.pipex.com>
+Ignasi Roca                    <ignasi.roca@fujitsu.siemens.es>
+Ilya Sandler                   <Ilya.Sandler@etak.com>
+Ilya Zakharevich               <ilya@math.ohio-state.edu>
+Inaba Hiroto                   <inaba@st.rim.or.jp>
+Irving Reid                    <irving@tor.securecomputing.com>
+J. David Blackstone            <jdb@dfwnet.sbms.sbc.com>
+J. van Krieken                 <John.van.Krieken@ATComputing.nl>
+JD Laub                        <jdl@access-health.com>
+JT McDuffie                    <jt@kpc.com>
+Jack Shirazi                   <JackS@GemStone.com>
+Jacqui Caren                   <Jacqui.Caren@ig.co.uk>
+Jake Hamby                     <jehamby@lightside.com>
+James FitzGibbon               <james@ican.net>
+Jamshid Afshar
+Jan D.                         <jan.djarv@mbox200.swipnet.se>
+Jan Dubois                     <jand@activestate.com>
+Jan Pazdziora                  <adelton@fi.muni.cz>
+Jan-Erik Karlsson              <trg@privat.utfors.se>
+Jan-Pieter Cornet              <johnpc@xs4all.nl>
+Jared Rhine                    <jared@organic.com>
+Jarkko Hietaniemi              <jhi@iki.fi>
+Jason A. Smith                 <smithj4@rpi.edu>
+Jason Shirk
+Jason Stewart                  <jasons@cs.unm.edu>
+Jason Varsoke                  <jjv@caesun10.msd.ray.com>
+Jay Rogers                     <jay@rgrs.com>
+Jeff Bouis
+Jeff McDougal                  <jmcdo@cris.com>
+Jeff Okamoto                   <okamoto@corp.hp.com>
+Jeff Pinyan                    <jeffp@crusoe.net>
+Jeff Urlwin                    <jurlwin@access.digex.net>
+Jeffrey Friedl                 <jfriedl@yahoo-inc.com>
+Jeffrey S. Haemer              <jsh@woodcock.boulder.qms.com>
+Jens Hamisch                   <jens@Strawberry.COM>
+Jens T. Berger Thielemann      <jensthi@ifi.uio.no>
+Jens Thomsen                   <jens@fiend.cis.com>
+Jens-Uwe Mager                 <jum@helios.de>
+Jeremy D. Zawodny              <jzawodn@wcnet.org>
+Jerome Abela                   <abela@hsc.fr>
+Jim Anderson                   <jander@ml.com>
+Jim Avera                      <avera@hal.com>
+Jim Balter
+Jim Meyering                   <meyering@asic.sc.ti.com>
+Jim Miner                      <jfm@winternet.com>
+Jim Richardson
+Joachim Huober
+Jochen Wiedmann                <joe@ispsoft.de>
+Joe Buehler                    <jbuehler@hekimian.com>
+Joe Smith                      <jsmith@inwap.com>
+Joel Rosi-Schwartz             <j.schwartz@agonet.it>
+Joerg Porath                   <Joerg.Porath@informatik.tu-chemnitz.de>
+Joergen Haegg
+Johan Holtman
+Johan Vromans                  <jvromans@squirrel.nl>
+Johann Klasek                  <jk@auto.tuwien.ac.at>
+John Bley                      <jbb6@acpub.duke.edu>
+John Borwick                   <jhborwic@unity.ncsu.edu>
+John Cerney                    <j-cerney1@ti.com>
+John D Groenveld               <groenvel@cse.psu.edu>
+John Hasstedt                  <John.Hasstedt@sunysb.edu>
+John Hughes                    <john@AtlanTech.COM>
+John L. Allen                  <allen@grumman.com>
+John Macdonald                 <jmm@revenge.elegant.com>
+John Nolan                     <jpnolan@Op.Net>
+John Peacock                   <jpeacock@rowman.com>
+John Pfuntner                  <pfuntner@vnet.ibm.com>
+John Rowe
+John Salinas                   <jsalinas@cray.com>
+John Stoffel                   <jfs@fluent.com>
+John Tobey                     <jtobey@john-edwin-tobey.org>
+Jon Orwant                     <orwant@oreilly.com>
+Jonathan Biggar                <jon@sems.com>
+Jonathan D Johnston            <jdjohnston2@juno.com>
+Jonathan Fine                  <jfine@borders.com>
+Jonathan I. Kamens             <jik@kamens.brookline.ma.us>
+Jonathan Roy                   <roy@idle.com>
+Joseph N. Hall                 <joseph@cscaper.com>
+Joseph S. Myers                <jsm28@hermes.cam.ac.uk>
+Joshua Pritikin                <joshua.pritikin@db.com>
+Juan Gallego                   <Little.Boss@physics.mcgill.ca>
+Julian Yip                     <julian@imoney.com>
+Justin Banks                   <justinb@cray.com>
+Ka-Ping Yee                    <kpyee@aw.sgi.com>
+Karl Glazebrook                <kgb@aaossz.aao.GOV.AU>
+Karl Heuer                     <kwzh@gnu.org>
+Karl Simon Berg                <karl@it.kth.se>
+Karsten Sperling               <spiff@phreax.net>
+Kaveh Ghazi                    <ghazi@caip.rutgers.edu>
+Keith Neufeld                  <neufeld@fast.pvi.org>
+Keith Thompson                 <kst@cts.com>
+Ken Estes                      <estes@ms.com>
+Ken Fox                        <kfox@ford.com>
+Ken MacLeod                    <ken@bitsko.slc.ut.us>
+Ken Shan                       <ken@digitas.harvard.edu>
+Kenneth Albanowski             <kjahds@kjahds.com>
+Kenneth Duda                   <kjd@cisco.com>
+Keong Lim                      <Keong.Lim@sr.com.au>
+Kevin O'Gorman                 <kevin.kosman@nrc.com>
+Kevin White                    <klwhite@magnus.acs.ohio-state.edu>
+Kim Frutiger
+Kragen Sitaker                 <kragen@dnaco.net>
+Krishna Sethuraman             <krishna@sgi.com>
+Kurt D. Starsinic              <kstar@smithrenaud.com>
+Kyriakos Georgiou
+Larry Parmelee                 <parmelee@CS.Cornell.EDU>
+Larry Schuler
+Larry Schwimmer                <rosebud@cyclone.Stanford.EDU>
+Larry W. Virden                <lvirden@cas.org>
+Larry Wall                     <larry@wall.org>
+Lars Hecking                   <lhecking@nmrc.ucc.ie>
+Laszlo Molnar                  <laszlo.molnar@eth.ericsson.se>
+Len Johnson                    <lenjay@ibm.net>
+Les Peters                     <lpeters@aol.net>
+Lincoln D. Stein               <lstein@cshl.org>
+Lionel Cons                    <lionel.cons@cern.ch>
+Luca Fini
+Lupe Christoph                 <lupe@lupe-christoph.de>
+Luther Huffman                 <lutherh@stratcom.com>
+M. J. T. Guy                   <mjtg@cam.ac.uk>
+Major Sébastien                <sebastien.major@crdp.ac-caen.fr>
+Makoto MATSUSHITA              <matusita@ics.es.osaka-u.ac.jp>
+Malcolm Beattie                <mbeattie@sable.ox.ac.uk>
+Marc Lehmann                   <pcg@goof.com>
+Marc Paquette                  <Marc.Paquette@Softimage.COM>
+Marcel Grunauer                <marcel@codewerk.com>
+Mark A Biggar                  <mab@wdl.loral.com>
+Mark Bixby                     <mark@bixby.org>
+Mark Dickinson                 <dickins3@fas.harvard.edu>
+Mark Hanson
+Mark K Trettin                 <mkt@lucent.com>
+Mark Kaehny                    <kaehny@execpc.com>
+Mark Kettenis                  <kettenis@wins.uva.nl>
+Mark Klein                     <mklein@dis.com>
+Mark Knutsen                   <knutsen@pilot.njin.net>
+Mark Kvale                     <kvale@phy.ucsf.edu>
+Mark Leighton Fisher           <fisherm@tce.com>
+Mark Murray                    <mark@grondar.za>
+Mark P. Lutz                   <mark.p.lutz@boeing.com>
+Mark Pease                     <peasem@primenet.com>
+Mark Pizzolato                 <mark@infocomm.com>
+Mark R. Levinson               <mrl@isc.upenn.edu>
+Mark-Jason Dominus             <mjd@plover.com>
+Martijn Koster                 <mak@excitecorp.com>
+Martin J. Bligh                <mbligh@sequent.com>
+Martin Jost                    <Martin.Jost@icn.siemens.de>
+Martin Lichtin                 <lichtin@bivio.com>
+Martin Plechsmid               <plechsmi@karlin.mff.cuni.cz>
+Marty Lucich                   <marty@netcom.com>
+Martyn Pearce                  <martyn@inpharmatica.co.uk>
+Masahiro KAJIURA               <masahiro.kajiura@toshiba.co.jp>
+Mathias Koerber                <mathias@dnssec1.singnet.com.sg>
+Matt Kimball
+Matthew Black                  <black@csulb.edu>
+Matthew Green                  <mrg@splode.eterna.com.au>
+Matthew T Harden               <mthard@mthard1.monsanto.com>
+Matthias Ulrich Neeracher      <neeri@iis.ee.ethz.ch>
+Matthias Urlichs               <smurf@noris.net>
+Maurizio Loreti                <maurizio.loreti@pd.infn.it>
+Michael Cook                   <mcook@cognex.com>
+Michael De La Rue              <mikedlr@tardis.ed.ac.uk>
+Michael Engel                  <engel@nms1.cc.huji.ac.il>
+Michael G Schwern              <schwern@pobox.com>
+Michael H. Moran               <mhm@austin.ibm.com>
+Michael Mahan                  <mahanm@nextwork.rose-hulman.edu>
+Michael Stevens                <mstevens@globnix.org>
+Michele Sardo
+Mik Firestone                  <fireston@lexmark.com>
+Mike Fletcher                  <fletch@phydeaux.org>
+Mike Hopkirk                   <hops@sco.com>
+Mike Rogers
+Mike Stok                      <mike@stok.co.uk>
+Mike W Ellwood                 <mwe@rl.ac.uk>
+Milton Hankins                 <webtools@uewrhp03.msd.ray.com>
+Milton L. Hankins              <mlh@swl.msd.ray.com>
+Molnar Laszlo                  <molnarl@cdata.tvnet.hu>
+Murray Nesbitt                 <mjn@pathcom.com>
+Nathan Kurz                    <nate@valleytel.net>
+Nathan Torkington              <gnat@frii.com>
+Neale Ferguson                 <neale@VMA.TABNSW.COM.AU>
+Neil Bowers                    <neilb@cre.canon.co.uk>
+Nicholas Clark                 <nick@ccl4.org>
+Nick Duffek
+Nick Gianniotis
+Nick Ing-Simmons               <nick@ing-simmons.net>
+Norbert Pueschel               <pueschel@imsdd.meb.uni-bonn.de>
+Norton T. Allen                <allen@huarp.harvard.edu>
+Olaf Flebbe                    <o.flebbe@gmx.de>
+Olaf Titz                      <olaf@bigred.inka.de>
+Ollivier Robert                <roberto@keltia.freenix.fr>
+Owen Taylor                    <owt1@cornell.edu>
+Patrick Hayes                  <Patrick.Hayes.CAP_SESA@renault.fr>
+Patrick O'Brien                <pdo@cs.umd.edu>
+Paul A Sand                    <pas@unh.edu>
+Paul David Fardy               <pdf@morgan.ucs.mun.ca>
+Paul Green                     <Paul_Green@stratus.com>
+Paul Hoffman                   <phoffman@proper.com>
+Paul Holser                    <Paul.Holser.pholser@nortelnetworks.com>
+Paul Johnson                   <pjcj@transeda.com>
+Paul Marquess                  <Paul.Marquess@btinternet.com>
+Paul Moore                     <Paul.Moore@uk.origin-it.com>
+Paul Rogers                    <Paul.Rogers@Central.Sun.COM>
+Paul Saab                      <ps@yahoo-inc.com>
+Paul Schinder                  <schinder@pobox.com>
+Pete Peterson                  <petersonp@genrad.com>
+Peter Chines                   <pchines@nhgri.nih.gov>
+Peter Gordon                   <peter@valor.com>
+Peter Haworth                  <pmh@edison.ioppublishing.com>
+Peter J. Farley III            <pjfarley@banet.net>
+Peter Jaspers-Fayer
+Peter Prymmer                  <pvhp@forte.com>
+Peter Scott                    <Peter@PSDT.com>
+Peter Wolfe                    <wolfe@teloseng.com>
+Peter van Heusden              <pvh@junior.uwc.ac.za>
+Petter Reinholdtsen            <pere@hungry.com>
+Phil Lobbes                    <phil@finchcomputer.com>
+Philip Hazel                   <ph10@cus.cam.ac.uk>
+Philip Newton                  <pne@cpan.org>
+Piers Cawley                   <pdcawley@bofh.org.uk>
+Piotr Klaban                   <makler@oryl.man.torun.pl>
+Prymmer/Kahn                   <pvhp@best.com>
+Quentin Fennessy               <quentin@arrakeen.amd.com>
+Radu Greab                     <radu@netsoft.ro>
+Ralf S. Engelschall            <rse@engelschall.com>
+Randal L. Schwartz             <merlyn@stonehenge.com>
+Randy J. Ray                   <rjray@redhat.com>
+Raphael Manfredi               <Raphael.Manfredi@pobox.com>
+Raymund Will                   <ray@caldera.de>
+Rex Dieter                     <rdieter@math.unl.edu>
+Rich Morin                     <rdm@cfcl.com>
+Rich Salz                      <rsalz@bbn.com>
+Richard A. Wells               <Rwells@uhs.harvard.edu>
+Richard Foley                  <Richard.Foley@m.dasa.de>
+Richard L. England             <richard_england@mentorg.com>
+Richard L. Maus, Jr.           <rmaus@monmouth.com>
+Richard Soderberg              <rs@crystalflame.net>
+Richard Yeh                    <rcyeh@cco.caltech.edu>
+Rick Delaney                   <rick@consumercontact.com>
+Rick Pluta
+Rickard Westman
+Rob Henderson                  <robh@cs.indiana.edu>
+Robert Partington              <rjp@riffraff.plig.net>
+Robert Sanders                 <Robert.Sanders@linux.org>
+Robert Spier                   <rspier@pobox.com>
+Robin Barker                   <rmb1@cise.npl.co.uk>
+Robin Houston                  <robin@nml.guardian.co.uk>
+Rocco Caputo                   <troc@netrus.net>
+Roderick Schertler             <roderick@argon.org>
+Rodger Anderson                <rodger@boi.hp.com>
+Ronald F. Guilmette            <rfg@monkeys.com>
+Ronald J. Kimball              <rjk@linguist.dartmouth.edu>
+Ruben Schattevoy               <schattev@imb-jena.de>
+Rujith S. de Silva             <desilva@netbox.com>
+Russ Allbery                   <rra@stanford.edu>
+Russell Fulton                 <russell@ccu1.auckland.ac.nz>
+Russell Mosemann
+Ryan Herbert                   <rherbert@sycamorehq.com>
+SAKAI Kiyotaka                 <ksakai@netwk.ntt-at.co.jp>
+Samuli Kärkkäinen              <skarkkai@woods.iki.fi>
+Scott Gifford                  <sgifford@tir.com>
+Scott Henry                    <scotth@sgi.com>
+Sean Robinson                  <robinson_s@sc.maricopa.edu>
+Sean Sheedy                    <seans@ncube.com>
+Sebastien Barre                <Sebastien.Barre@utc.fr>
+Shigeya Suzuki                 <shigeya@foretune.co.jp>
+Shimpei Yamashita              <shimpei@socrates.patnet.caltech.edu>
+Shishir Gundavaram             <shishir@ruby.ora.com>
+Simon Cozens                   <simon@cozens.net>
+Simon Leinen
+Simon Parsons                  <S.Parsons@ftel.co.uk>
+Slaven Rezic                   <eserte@cs.tu-berlin.de>
+Spider Boardman                <spider@orb.nashua.nh.us>
+Stephane Payrard               <stef@francenet.fr>
+Stephanie Beals                <bealzy@us.ibm.com>
+Stephen McCamant               <alias@mcs.com>
+Stephen O. Lidie               <lusol@turkey.cc.Lehigh.EDU>
+Stephen P. Potter              <spp@ds.net>
+Stephen Zander                 <gibreel@pobox.com>
+Steve A Fink                   <sfink@cs.berkeley.edu>
+Steve Kelem                    <steve.kelem@xilinx.com>
+Steve McDougall                <swmcd@world.std.com>
+Steve Nielsen                  <spn@enteract.com>
+Steve Pearlmutter
+Steve Vinoski
+Steven Hirsch                  <hirschs@btv.ibm.com>
+Steven Knight                  <knight@theopera.baldmt.citilink.com>
+Steven Morlock                 <newspost@morlock.net>
+Steven N. Hirsch               <hirschs@stargate.btv.ibm.com>
+Steven Parkes                  <parkes@sierravista.com>
+Sven Verdoolaege               <skimo@breughel.ufsia.ac.be>
+SynaptiCAD, Inc.               <sales@syncad.com>
+Taro KAWAGISHI
+Ted Ashton                     <ashted@southern.edu>
+Ted Law                        <tedlaw@cibcwg.com>
+Teun Burgers                   <burgers@ecn.nl>
+Thad Floryan                   <thad@thadlabs.com>
+Thomas Bowditch                <bowditch@inmet.com>
+Thomas Conté                   <tom@fr.uu.net>
+Thomas Dorner                  <Thomas.Dorner@start.de>
+Thomas Kofler
+Thomas König
+Tim Adye                       <T.J.Adye@rl.ac.uk>
+Tim Ayers                      <tayers@bridge.com>
+Tim Bunce                      <Tim.Bunce@ig.co.uk>
+Tim Conrow                     <tim@spindrift.srl.caltech.edu>
+Tim Freeman                    <tfreeman@infoseek.com>
+Tim Jenness                    <t.jenness@jach.hawaii.edu>
+Tim Mooney                     <mooney@dogbert.cc.ndsu.NoDak.edu>
+Tim Witham                     <twitham@pcocd2.intel.com>
+Timur I. Bakeyev               <bsdi@listserv.bat.ru>
+Tkil                           <tkil@reptile.scrye.com>
+Todd C. Miller                 <Todd.Miller@courtesan.com>
+Tom Bates                      <tom_bates@att.net>
+Tom Christiansen               <tchrist@perl.com>
+Tom Horsley                    <Tom.Horsley@mail.ccur.com>
+Tom Hughes                     <tom@compton.nu>
+Tom Phoenix                    <rootbeer@teleport.com>
+Tom Spindler                   <dogcow@isi.net>
+Tony Camas
+Tony Cook                      <tony@develop-help.com>
+Tony Sanders                   <sanders@bsdi.com>
+Tor Lillqvist                  <tml@hemuli.tte.vtt.fi>
+Trevor Blackwell               <tlb@viaweb.com>
+Tuomas J. Lukka                <tjl@lukka.student.harvard.edu>
+Tye McQueen                    <tye@metronet.com>
+Ulrich Kunitz                  <kunitz@mai-koeln.com>
+Ulrich Pfeifer                 <pfeifer@wait.de>
+Vadim Konovalov                <vkonovalov@lucent.com>
+Valeriy E. Ushakov             <uwe@ptc.spbu.ru>
+Vishal Bhatia                  <vishal@deja.com>
+Vlad Harchev                   <hvv@hippo.ru>
+Vladimir Alexiev               <vladimir@cs.ualberta.ca>
+W. Phillip Moore               <wpm@ms.com>
+Warren Hyde                    <whyde@pezz.sps.mot.com>
+Warren Jones                   <wjones@tc.fluke.com>
+Wayne Berke                    <berke@panix.com>
+Wayne Scott                    <wscott@ichips.intel.com>
+Wayne Thompson                 <Wayne.Thompson@Ebay.sun.com>
+Wilfredo Sánchez               <wsanchez@apple.com>
+William J. Middleton           <William.Middleton@oslo.mobil.telenor.no>
+William Mann                   <wmann@avici.com>
+William R Ward                 <hermit@BayView.COM>
+William Setzer                 <William_Setzer@ncsu.edu>
+Winfried König                 <win@in.rhein-main.de>
+Wolfgang Laun                  <Wolfgang.Laun@alcatel.at>
+Yary Hluchan
+Yasushi Nakajima               <sey@jkc.co.jp>
+Yitzchak Scott-Thoennes        <sthoenna@efn.org>
+Yutaka OIWA                    <oiwa@is.s.u-tokyo.ac.jp>
+Yutao Feng
+Zachary Miller                 <zcmiller@simon.er.usgs.gov>
index 3dc17bc..47adbff 100644 (file)
@@ -13319,7 +13319,7 @@ ____________________________________________________________________________
 [  3914] By: jhi                                   on 1999/08/03  21:11:11
         Log: The op/filetest.t failed subtest 7 if testing as root.
              
-             From: =?iso-8859-1?Q?Fran=E7ois=20D=E9sarm=E9nien?= <desar@club-internet.fr>
+             From: François Désarménien <desar@club-internet.fr>
              To: perl5-porters@perl.org
              Subject: [ID 19990727.039] Not OK: perl 5.00558 on i386-sco 3.2v5.0.4
              Date: Tue, 27 Jul 1999 22:54:05 +0200
index 03004be..023df36 100755 (executable)
--- a/Configure
+++ b/Configure
 
 # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
 #
-# Generated on Thu Oct 19 22:28:50 EET DST 2000 [metaconfig 3.0 PL70]
+# Generated on Fri Jan  5 20:11:52 EET 2001 [metaconfig 3.0 PL70]
 # (with additional metaconfig patches by perlbug@perl.org)
 
-cat >/tmp/c1$$ <<EOF
+cat >c1$$ <<EOF
 ARGGGHHHH!!!!!
 
 SCO csh still thinks true is false.  Write to SCO today and tell them that next
@@ -34,18 +34,18 @@ we'd have to do is go in and swap the && and || tokens, wherever they are.)
 
 [End of diatribe. We now return you to your regularly scheduled programming...]
 EOF
-cat >/tmp/c2$$ <<EOF
+cat >c2$$ <<EOF
 
 OOPS!  You naughty creature!  You didn't run Configure with sh!
 I will attempt to remedy the situation by running sh for you...
 EOF
 
-true || cat /tmp/c1$$ /tmp/c2$$
+true || cat c1$$ c2$$
 true || exec sh $0 $argv:q
 
-(exit $?0) || cat /tmp/c2$$
+(exit $?0) || cat c2$$
 (exit $?0) || exec sh $0 $argv:q
-rm -f /tmp/c1$$ /tmp/c2$$
+rm -f c1$$ c2$$
 
 : compute my invocation name
 me=$0
@@ -308,6 +308,7 @@ cppminus=''
 cpprun=''
 cppstdin=''
 crosscompile=''
+d__fwalk=''
 d_access=''
 d_accessx=''
 d_alarm=''
@@ -348,6 +349,7 @@ d_endsent=''
 d_fchmod=''
 d_fchown=''
 d_fcntl=''
+d_fcntl_can_lock=''
 d_fd_macros=''
 d_fd_set=''
 d_fds_bits=''
@@ -361,6 +363,7 @@ d_fs_data_s=''
 d_fseeko=''
 d_fsetpos=''
 d_fstatfs=''
+d_fsync=''
 d_ftello=''
 d_ftime=''
 d_gettimeod=''
@@ -385,6 +388,7 @@ d_getnbyaddr=''
 d_getnbyname=''
 d_getnent=''
 d_getnetprotos=''
+d_getpagsz=''
 d_getpent=''
 d_getpgid=''
 d_getpgrp2=''
@@ -474,6 +478,7 @@ d_rmdir=''
 d_safebcpy=''
 d_safemcpy=''
 d_sanemcmp=''
+d_sbrkproto=''
 d_select=''
 d_sem=''
 d_semctl=''
@@ -536,6 +541,8 @@ d_fstatvfs=''
 d_statvfs=''
 d_stdio_cnt_lval=''
 d_stdio_ptr_lval=''
+d_stdio_ptr_lval_nochange_cnt=''
+d_stdio_ptr_lval_sets_cnt=''
 d_stdiobase=''
 d_stdstdio=''
 stdio_base=''
@@ -555,6 +562,7 @@ d_strtod=''
 d_strtol=''
 d_strtold=''
 d_strtoll=''
+d_strtoq=''
 d_strtoul=''
 d_strtoull=''
 d_strtouq=''
@@ -714,6 +722,7 @@ installusrbinperl=''
 intsize=''
 longsize=''
 shortsize=''
+issymlink=''
 libc=''
 ldlibpthname=''
 libperl=''
@@ -773,6 +782,7 @@ d_eofnblk=''
 eagain=''
 o_nonblock=''
 rd_nodata=''
+need_va_copy=''
 netdb_hlen_type=''
 netdb_host_type=''
 netdb_name_type=''
@@ -1424,6 +1434,7 @@ case "$src" in
     */*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'`
          case "$src" in
         /*)    ;;
+        .)     ;;
          *)    src=`cd ../$src && pwd` ;;
         esac
          ;;
@@ -2051,6 +2062,7 @@ test)
 *)
        if `sh -c "PATH= test true" >/dev/null 2>&1`; then
                echo "Using the test built into your sh."
+               echo "Using the test built into your sh."
                test=test
                _test=test
        fi
@@ -2159,6 +2171,93 @@ else
 fi
 $rm -f blurfl sym
 
+: determine whether symbolic links are supported
+echo " "
+case "$lns" in
+*"ln -s")
+       echo "Checking how to test for symbolic links..." >&4
+       $lns blurfl sym
+       if $test "X$issymlink" = X; then
+               sh -c "PATH= test -h sym" >/dev/null 2>&1
+               if test $? = 0; then
+                       issymlink="test -h"
+               fi              
+       fi
+       if $test "X$issymlink" = X; then
+               if  $test -h >/dev/null 2>&1; then
+                       issymlink="$test -h"
+                       echo "Your builtin 'test -h' may be broken, I'm using external '$test -h'." >&4
+               fi              
+       fi
+       if $test "X$issymlink" = X; then
+               if $test -L sym 2>/dev/null; then
+                       issymlink="$test -L"
+               fi
+       fi
+       if $test "X$issymlink" != X; then
+               echo "You can test for symbolic links with '$issymlink'." >&4
+       else
+               echo "I do not know how you can test for symbolic links." >&4
+       fi
+       $rm -f blurfl sym
+       ;;
+*)     echo "No symbolic links, so not testing for their testing..." >&4
+       ;;
+esac
+echo " "
+
+
+case "$mksymlinks" in
+$define|true|[yY]*)
+       case "$src" in
+       ''|'.') echo "Cannot create symlinks in the original directory." >&4
+               exit 1
+               ;;
+       *)      case "$lns:$issymlink" in
+               *"ln -s:"*"test -"?)
+                       echo "Creating the symbolic links..." >&4
+                       echo "(First creating the subdirectories...)" >&4
+                       cd ..
+                       awk '{print $1}' $src/MANIFEST | grep / | sed 's:/[^/]*$::' | sort -u | while true; do
+                               read directory
+                               test -z "$directory" && break
+                               mkdir -p $directory
+                       done
+                       # Sanity check 1.
+                       if test ! -d t/base; then
+                               echo "Failed to create the subdirectories.  Aborting." >&4
+                               exit 1
+                       fi
+                       echo "(Then creating the symlinks...)" >&4
+                       awk '{print $1}' $src/MANIFEST | while true; do
+                               read filename
+                               test -z "$filename" && break
+                               if test -f $filename; then
+                                       if $issymlink $filename; then
+                                               rm -f $filename
+                                       fi
+                               fi
+                               if test -f $filename; then
+                                       echo "$filename already exists, not symlinking."
+                               else
+                                       ln -s $src/$filename $filename
+                               fi
+                       done
+                       # Sanity check 2.
+                       if test ! -f t/base/commonsense.t; then
+                               echo "Failed to create the symlinks.  Aborting." >&4
+                               exit 1
+                       fi
+                       cd UU
+                       ;;
+               *)      echo "(I cannot figure out how to do symbolic links, ignoring mksymlinks)." >&4
+                       ;;
+               esac
+               ;;
+       esac
+       ;;
+esac
+
 : see whether [:lower:] and [:upper:] are supported character classes
 echo " "
 case "`echo AbyZ | $tr '[:lower:]' '[:upper:]' 2>/dev/null`" in
@@ -2261,7 +2360,10 @@ if test -f config.sh; then
        rp="I see a config.sh file.  Shall I use it to set the defaults?"
        . UU/myread
        case "$ans" in
-       n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;;
+       n*|N*) echo "OK, I'll ignore it."
+               mv config.sh config.sh.old
+               myuname="$newmyuname"
+               ;;
        *)  echo "Fetching default answers from your old config.sh file..." >&4
                tmp_n="$n"
                tmp_c="$c"
@@ -2426,7 +2528,7 @@ EOM
                        esac
                        ;;
                next*) osname=next ;;
-               NonStop-UX) osname=nonstopux ;;
+               nonstop-ux) osname=nonstopux ;;
                POSIX-BC | posix-bc ) osname=posix-bc
                        osvers="$3"
                        ;;
@@ -2672,7 +2774,6 @@ cd UU
        ;;
 esac
 test "$override" && . ./optdef.sh
-myuname="$newmyuname"
 
 : Restore computed paths
 for file in $loclist $trylist; do
@@ -2906,7 +3007,7 @@ if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1
 then
        echo "Looks kind of like an OSF/1 system, but we'll see..."
        echo exit 0 >osf1
-elif test `echo abc | tr a-z A-Z` = Abc ; then
+elif test `echo abc | $tr a-z A-Z` = Abc ; then
        xxx=`./loc addbib blurfl $pth`
        if $test -f $xxx; then
        echo "Looks kind of like a USG system with BSD features, but we'll see..."
@@ -3286,7 +3387,7 @@ esac
 
 case "$fn" in
 *\(*)
-       expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok
+       expr $fn : '.*(\(.*\)).*' | $tr ',' $trnl >getfile.ok
        fn=`echo $fn | sed 's/(.*)//'`
        ;;
 esac
@@ -3663,7 +3764,8 @@ esac
 cat <<EOM
 
 Perl can be built to use the SOCKS proxy protocol library.  To do so,
-Configure must be run with -Dusesocks.
+Configure must be run with -Dusesocks.  If you use SOCKS you also need
+to use the PerlIO abstraction layer, this will be implicitly selected.
 
 If this doesn't make any sense to you, just accept the default '$dflt'.
 EOM
@@ -3676,6 +3778,10 @@ esac
 set usesocks
 eval $setvar
 
+case "$usesocks" in
+$define|true|[yY]*) useperlio="$define";;
+esac
+
 : Looking for optional libraries
 echo " "
 echo "Checking for optional libraries..." >&4
@@ -4041,8 +4147,8 @@ and I got the following output:
 
 EOM
 dflt=y
-if sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then
-       if sh -c './try' >>try.msg 2>&1; then
+if $sh -c "$cc -o try $optimize $ccflags $ldflags try.c $libs" >>try.msg 2>&1; then
+       if $sh -c './try' >>try.msg 2>&1; then
                xxx=`./try`
                case "$xxx" in
                "Ok") dflt=n ;;
@@ -4739,7 +4845,7 @@ unknown)
                                s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g
                                G
                                s/\n/ /' | \
-                        sort | $sed -e 's/^.* //'`
+                        $sort | $sed -e 's/^.* //'`
                eval set \$$#
        done
        $test -r $1 || set /usr/ccs/lib/libc.$so
@@ -4799,7 +4905,7 @@ compiler, or your machine supports multiple models), you can override it here.
 EOM
 else
        dflt=''
-       echo $libpth | tr ' ' $trnl | sort | uniq > libpath
+       echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath
        cat >&4 <<EOM
 I can't seem to find your C library.  I've looked in the following places:
 
@@ -4817,7 +4923,7 @@ rp='Where is your C library?'
 libc="$ans"
 
 echo " "
-echo $libc $libnames | tr ' ' $trnl | sort | uniq > libnames
+echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames
 set X `cat libnames`
 shift
 xxx=files
@@ -7266,6 +7372,25 @@ rp='Perl administrator e-mail address'
 . ./myread
 perladmin="$ans"
 
+: determine whether to only install version-specific parts.
+echo " "
+$cat <<EOM
+Do you want to install only the version-specific parts of the perl
+distribution?  Usually you do *not* want to do this.
+EOM
+case "$versiononly" in
+"$define"|[Yy]*|true) dflt='y' ;;
+*) dflt='n';
+esac
+rp="Do you want to install only the version-specific parts of perl?"
+. ./myread
+case "$ans" in
+[yY]*) val="$define";;
+*)     val="$undef" ;;
+esac
+set versiononly
+eval $setvar
+
 : figure out how to guarantee perl startup
 case "$startperl" in
 '')
@@ -7280,7 +7405,10 @@ want to share those scripts and perl is not in a standard place
 a shell by starting the script with a single ':' character.
 
 EOH
-               dflt="$binexp/perl"
+               case "$versiononly" in
+               "$define")      dflt="$binexp/perl$version";;  
+               *)              dflt="$binexp/perl";;
+               esac
                rp='What shall I put after the #! to start up perl ("none" to not use #!)?'
                . ./myread
                case "$ans" in
@@ -7396,13 +7524,12 @@ $define|true|[yY]*)     dflt='y';;
 esac
 cat <<EOM
 
-Previous version of $package used the standard IO mechanisms as defined
-in <stdio.h>.  Versions 5.003_02 and later of perl allow alternate IO
-mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still
-the default.  This abstraction layer can use AT&T's sfio (if you already
-have sfio installed) or regular stdio.  Using PerlIO with sfio may cause
-problems with some extension modules.  Using PerlIO with stdio is safe,
-but it is slower than plain stdio and therefore is not the default.
+Previous version of $package used the standard IO mechanisms as
+defined in <stdio.h>.  Versions 5.003_02 and later of perl allow
+alternate IO mechanisms via the PerlIO abstraction layer, but the
+stdio mechanism is still the default.  This abstraction layer can
+use AT&T's sfio (if you already have sfio installed) or regular stdio.
+Using PerlIO with sfio may cause problems with some extension modules.
 
 If this doesn't make any sense to you, just accept the default '$dflt'.
 EOM
@@ -7413,13 +7540,29 @@ y|Y)
        val="$define"
        ;;     
 *)      
-       echo "Ok, doing things the stdio way"
+       echo "Ok, doing things the stdio way."
        val="$undef"
        ;;
 esac
 set useperlio
 eval $setvar 
 
+case "$usesocks" in
+$define|true|[yY]*)
+       case "$useperlio" in
+       $define|true|[yY]*) ;;
+       *)      cat >&4 <<EOM
+
+You are using the SOCKS proxy protocol library which means that you
+should also use the PerlIO layer.  You may be headed for trouble.
+
+EOM
+               ;;
+       esac
+       ;;
+esac
+
+       
 case "$vendorprefix" in
 '')    d_vendorbin="$undef"
        vendorbin=''
@@ -7445,25 +7588,6 @@ else
        installvendorbin="$vendorbinexp"
 fi
 
-: determine whether to only install version-specific parts.
-echo " "
-$cat <<EOM
-Do you want to install only the version-specific parts of the perl
-distribution?  Usually you do *not* want to do this.
-EOM
-case "$versiononly" in
-"$define"|[Yy]*|true) dflt='y' ;;
-*) dflt='n';
-esac
-rp="Do you want to install only the version-specific parts of perl?"
-. ./myread
-case "$ans" in
-[yY]*) val="$define";;
-*)     val="$undef" ;;
-esac
-set versiononly
-eval $setvar
-
 : see if qgcvt exists
 set qgcvt d_qgcvt
 eval $inlibc
@@ -7744,6 +7868,10 @@ qgcvt) d_Gconvert='qgcvt((x),(n),(b))' ;;
    ;;  
 esac
 
+: see if _fwalk exists
+set fwalk d__fwalk
+eval $inlibc
+
 : Initialize h_fcntl
 h_fcntl=false
 
@@ -8843,6 +8971,54 @@ eval $inlibc
 set fcntl d_fcntl
 eval $inlibc
 
+echo " "
+: See if fcntl-based locking works.
+$cat >try.c <<'EOCP'
+#include <stdlib.h>
+#include <unistd.h>
+#include <fcntl.h>
+int main() {
+#if defined(F_SETLK) && defined(F_SETLKW)
+     struct flock flock;
+     int retval, fd;
+     fd = open("try.c", O_RDONLY);
+     flock.l_type = F_RDLCK;
+     flock.l_whence = SEEK_SET;
+     flock.l_start = flock.l_len = 0;
+     retval = fcntl(fd, F_SETLK, &flock);
+     close(fd);
+     (retval < 0 ? exit(2) : exit(0));
+#else
+     exit(2);
+#endif
+}
+EOCP
+echo "Checking if fcntl-based file locking works... "
+case "$d_fcntl" in
+"$define")
+       set try
+       if eval $compile_ok; then
+               if ./try; then
+                       echo "Yes, it seems to work."
+                       val="$define"
+               else
+                       echo "Nope, it didn't work."
+                       val="$undef"
+               fi
+       else
+               echo "I'm unable to compile the test program, so I'll assume not."
+               val="$undef"
+       fi
+       ;;
+*) val="$undef";
+       echo "Nope, since you don't even have fcntl()."
+       ;;
+esac
+set d_fcntl_can_lock
+eval $setvar
+$rm -f try*
+
+
 hasfield='varname=$1; struct=$2; field=$3; shift; shift; shift;
 while $test $# -ge 2; do
        case "$1" in
@@ -9219,6 +9395,10 @@ set fstatvfs d_fstatvfs
 eval $inlibc
 
 
+: see if fsync exists
+set fsync d_fsync
+eval $inlibc
+
 : see if ftello exists
 set ftello d_ftello
 eval $inlibc
@@ -9378,6 +9558,10 @@ echo " "
 set d_getnetprotos getnetent $i_netdb netdb.h
 eval $hasproto
 
+: see if getpagesize exists
+set getpagesize d_getpagsz
+eval $inlibc
+
 
 : see if getprotobyname exists
 set getprotobyname d_getpbyname
@@ -10040,6 +10224,37 @@ rp="What is the size of a character (in bytes)?"
 charsize="$ans"
 $rm -f try.c try
 
+: check for volatile keyword
+echo " "
+echo 'Checking to see if your C compiler knows about "volatile"...' >&4
+$cat >try.c <<'EOCP'
+int main()
+{
+       typedef struct _goo_struct goo_struct;
+       goo_struct * volatile goo = ((goo_struct *)0);
+       struct _goo_struct {
+               long long_int;
+               int reg_int;
+               char char_var;
+       };
+       typedef unsigned short foo_t;
+       char *volatile foo;
+       volatile int bar;
+       volatile foo_t blech;
+       foo = foo;
+}
+EOCP
+if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
+       val="$define"
+       echo "Yup, it does."
+else
+       val="$undef"
+       echo "Nope, it doesn't."
+fi
+set d_volatile
+eval $setvar
+$rm -f try.*
+
 
 echo " "
 $echo "Choosing the C types to be used for Perl's internal types..." >&4
@@ -10218,67 +10433,68 @@ case "$i64type" in
        ;;
 esac
 
-$echo "Checking whether your NVs can preserve your UVs..." >&4
+$echo "Checking how many bits of your UVs your NVs can preserve..." >&4
+: volatile so that the compiler has to store it out to memory.
+if test X"$d_volatile" = X"$define"; then
+       volatile=volatile
+fi
 $cat <<EOP >try.c
 #include <stdio.h>
-int main() {
-    $uvtype k = ($uvtype)~0, l;
-    $nvtype d;
-    l = k;
-    d = ($nvtype)l;
-    l = ($uvtype)d;
-    if (l == k)
-       printf("preserve\n");
-    exit(0);
-}
-EOP
-set try
-if eval $compile; then
-       case "`./try$exe_ext`" in
-       preserve) d_nv_preserves_uv="$define" ;;
-       esac
-fi     
-case "$d_nv_preserves_uv" in
-$define) $echo "Yes, they can."  2>&1 ;;
-*)      $echo "No, they can't." 2>&1
-        d_nv_preserves_uv="$undef"
-        ;;
-esac
-
-$rm -f try.* try
-
-case "$d_nv_preserves_uv" in
-"$define") d_nv_preserves_uv_bits=`expr $uvsize \* 8` ;;
-*)     $echo "Checking how many bits of your UVs your NVs can preserve..." >&4
-       $cat <<EOP >try.c
-#include <stdio.h>
+#include <sys/types.h>
+#include <signal.h>
+#ifdef SIGFPE
+$volatile int bletched = 0;
+$signal_t blech(s) int s; { bletched = 1; }
+#endif
 int main() {
     $uvtype u = 0;
+    $nvtype d;
     int     n = 8 * $uvsize;
     int     i;
+#ifdef SIGFPE
+    signal(SIGFPE, blech);
+#endif
+
     for (i = 0; i < n; i++) {
       u = u << 1 | ($uvtype)1;
-      if (($uvtype)($nvtype)u != u)
+      d = ($nvtype)u;
+      if (($uvtype)d != u)
+        break;
+      if (d <= 0)
+       break;
+      d = ($nvtype)(u - 1);
+      if (($uvtype)d != (u - 1))
         break;
+#ifdef SIGFPE
+      if (bletched) {
+       break;
+#endif
+      }        
     }
-    printf("%d\n", i);
+    printf("%d\n", ((i == n) ? -n : i));
     exit(0);
 }
 EOP
-       set try
-       if eval $compile; then
-               d_nv_preserves_uv_bits="`./try$exe_ext`"
-       fi
-       case "$d_nv_preserves_uv_bits" in
-       [1-9]*) $echo "Your NVs can preserve $d_nv_preserves_uv_bits bits of your UVs."  2>&1 ;;
-       *)      $echo "Can't figure out how many bits your NVs preserve." 2>&1
-               d_nv_preserves_uv_bits="$undef"
-               ;;
-       esac
-       $rm -f try.* try
+set try
+
+d_nv_preserves_uv="$undef"
+if eval $compile; then
+       d_nv_preserves_uv_bits="`./try$exe_ext`"
+fi
+case "$d_nv_preserves_uv_bits" in
+\-[1-9]*)      
+       d_nv_preserves_uv_bits=`expr 0 - $d_nv_preserves_uv_bits`
+       $echo "Your NVs can preserve all $d_nv_preserves_uv_bits bits of your UVs."  2>&1
+       d_nv_preserves_uv="$define"
        ;;
+[1-9]*)        $echo "Your NVs can preserve only $d_nv_preserves_uv_bits bits of your UVs."  2>&1
+       d_nv_preserves_uv="$undef" ;;
+*)     $echo "Can't figure out how many bits your NVs preserve." 2>&1
+       d_nv_preserves_uv_bits="$undef" ;;
 esac
 
+$rm -f try.* try
+
 
 : check for off64_t
 echo " "
@@ -10792,6 +11008,11 @@ $rm -f try.* try core
 set d_sanemcmp
 eval $setvar
 
+: see if prototype for sbrk is available
+echo " "
+set d_sbrkproto sbrk $i_unistd unistd.h
+eval $hasproto
+
 : see if select exists
 set select d_select
 eval $inlibc
@@ -11390,7 +11611,28 @@ esac
 
 : see if _ptr and _cnt from stdio act std
 echo " "
-if $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then
+
+if $contains '_lbfsize' `./findhdr stdio.h` >/dev/null 2>&1 ; then
+       echo "(Looks like you have stdio.h from BSD.)"
+       case "$stdio_ptr" in
+       '') stdio_ptr='((fp)->_p)'
+               ptr_lval=$define
+               ;;
+       *)      ptr_lval=$d_stdio_ptr_lval;;
+       esac
+       case "$stdio_cnt" in
+       '') stdio_cnt='((fp)->_r)'
+               cnt_lval=$define
+               ;;
+       *)      cnt_lval=$d_stdio_cnt_lval;;
+       esac
+       case "$stdio_base" in
+       '') stdio_base='((fp)->_ub._base ? (fp)->_ub._base : (fp)->_bf._base)';;
+       esac
+       case "$stdio_bufsiz" in
+       '') stdio_bufsiz='((fp)->_ub._base ? (fp)->_ub._size : (fp)->_bf._size)';;
+       esac
+elif $contains '_IO_fpos_t' `./findhdr stdio.h` `./findhdr libio.h` >/dev/null 2>&1 ; then
        echo "(Looks like you have stdio.h from Linux.)"
        case "$stdio_ptr" in
        '') stdio_ptr='((fp)->_IO_read_ptr)'
@@ -11430,6 +11672,7 @@ else
        '') stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)';;
        esac
 fi
+
 : test whether _ptr and _cnt really work
 echo "Checking how std your stdio is..." >&4
 $cat >try.c <<EOP
@@ -11479,6 +11722,93 @@ esac
 set d_stdio_cnt_lval
 eval $setvar
 
+
+: test whether setting _ptr sets _cnt as a side effect
+d_stdio_ptr_lval_sets_cnt="$undef"
+d_stdio_ptr_lval_nochange_cnt="$undef"
+case "$d_stdio_ptr_lval$d_stdstdio" in
+$define$define)
+       echo "Checking to see what happens if we set the stdio ptr..." >&4
+$cat >try.c <<EOP
+#include <stdio.h>
+/* Can we scream? */
+/* Eat dust sed :-) */
+/* In the buffer space, no one can hear you scream. */
+#define FILE_ptr(fp)   $stdio_ptr
+#define FILE_cnt(fp)   $stdio_cnt
+#include <sys/types.h>
+int main() {
+       FILE *fp = fopen("try.c", "r");
+       int c;
+       char *ptr;
+       size_t cnt;
+       if (!fp) {
+           puts("Fail even to read");
+           exit(1);
+       }
+       c = getc(fp); /* Read away the first # */
+       if (c == EOF) {
+           puts("Fail even to read");
+           exit(1);
+       }
+       if (!(
+               18 <= FILE_cnt(fp) &&
+               strncmp(FILE_ptr(fp), "include <stdio.h>\n", 18) == 0
+       )) {
+               puts("Fail even to read");
+               exit (1);
+       }
+       ptr = (char*) FILE_ptr(fp);
+       cnt = (size_t)FILE_cnt(fp);
+
+       FILE_ptr(fp) += 42;
+
+       if ((char*)FILE_ptr(fp) != (ptr + 42)) {
+               printf("Fail ptr check %p != %p", FILE_ptr(fp), (ptr + 42));
+               exit (1);
+       }
+       if (FILE_cnt(fp) <= 20) {
+               printf ("Fail (<20 chars to test)");
+               exit (1);
+       }
+       if (strncmp(FILE_ptr(fp), "Eat dust sed :-) */\n", 20) != 0) {
+               puts("Fail compare");
+               exit (1);
+       }
+       if (cnt == FILE_cnt(fp)) {
+               puts("Pass_unchanged");
+               exit (0);
+       }       
+       if (FILE_cnt(fp) == (cnt - 42)) {
+               puts("Pass_changed");
+               exit (0);
+       }
+       printf("Fail count was %d now %d\n", cnt, FILE_cnt(fp));
+       return 1;
+
+}
+EOP
+       set try
+       if eval $compile; then
+               case `./try$exe_ext` in
+               Pass_changed)
+                       echo "Increasing ptr in your stdio decreases cnt by the same amount.  Good." >&4
+                       d_stdio_ptr_lval_sets_cnt="$define" ;;
+               Pass_unchanged)
+                       echo "Increasing ptr in your stdio leaves cnt unchanged.  Good." >&4
+                       d_stdio_ptr_lval_nochange_cnt="$define" ;;
+               Fail*)
+                       echo "Increasing ptr in your stdio didn't do exactly what I expected.  We'll not be doing that then." >&4 ;;
+               *)
+                       echo "It appears attempting to set ptr in your stdio is a bad plan." >&4 ;;
+       esac
+       else
+               echo "It seems we can't set ptr in your stdio.  Nevermind." >&4
+       fi
+       $rm -f try.c try
+       ;;
+esac
+
 : see if _base is also standard
 val="$undef"
 case "$d_stdstdio" in
        ;;
 esac
 
-: see if strtoul exists
-set strtoul d_strtoul
+: see if strtoq exists
+set strtoq d_strtoq
 eval $inlibc
 
-: see if strtoull exists
-set strtoull d_strtoull
+: see if strtoul exists
+set strtoul d_strtoul
 eval $inlibc
 
-case "$d_longlong-$d_strtoull" in
-"$define-$define")
+case "$d_strtoul" in
+"$define")
        $cat <<EOM
-Checking whether your strtoull() works okay...
+Checking whether your strtoul() works okay...
 EOM
        $cat >try.c <<'EOCP'
 #include <errno.h>
-#ifdef __hpux
-#define strtoull __strtoull
-#endif
 #include <stdio.h>
-extern unsigned long long int strtoull(char *s, char **, int); 
+extern unsigned long int strtoul(char *s, char **, int); 
+static int bad = 0;
+void check(char *s, unsigned long eul, int een) {
+       unsigned long gul;
+       errno = 0;
+       gul = strtoul(s, 0, 10);
+       if (!((gul == eul) && (errno == een)))
+               bad++;
+}
+int main() {
+       check(" 1", 1L, 0);
+       check(" 0", 0L, 0);
+EOCP
+       case "$longsize" in
+       8)
+           $cat >>try.c <<'EOCP'
+       check("18446744073709551615", 18446744073709551615UL, 0);
+       check("18446744073709551616", 18446744073709551615UL, ERANGE);
+#if 0 /* strtoul() for /^-/ strings is undefined. */
+       check("-1", 18446744073709551615UL, 0);
+       check("-18446744073709551614", 2, 0);
+       check("-18446744073709551615", 1, 0);
+               check("-18446744073709551616", 18446744073709551615UL, ERANGE);
+       check("-18446744073709551617", 18446744073709551615UL, ERANGE);
+#endif
+EOCP
+               ;;
+       4)
+                   $cat >>try.c <<'EOCP'
+       check("4294967295", 4294967295UL, 0);
+       check("4294967296", 4294967295UL, ERANGE);
+#if 0 /* strtoul() for /^-/ strings is undefined. */
+       check("-1", 4294967295UL, 0);
+       check("-4294967294", 2, 0);
+       check("-4294967295", 1, 0);
+               check("-4294967296", 4294967295UL, ERANGE);
+       check("-4294967297", 4294967295UL, ERANGE);
+#endif
+EOCP
+               ;;
+       *)
+: Should we write these tests to be more portable by sprintf-ing
+: ~0 and then manipulating that char string as input for strtol?
+               ;;
+       esac
+       $cat >>try.c <<'EOCP'
+       if (!bad)
+               printf("ok\n");
+       return 0;
+}
+EOCP
+       set try
+       if eval $compile; then
+               case "`./try`" in
+               ok) echo "Your strtoul() seems to be working okay." ;;
+               *) cat <<EOM >&4
+Your strtoul() doesn't seem to be working okay.
+EOM
+                  d_strtoul="$undef"
+                  ;;
+               esac
+       fi
+       ;;
+esac
+
+: see if strtoull exists
+set strtoull d_strtoull
+eval $inlibc
+
+case "$d_longlong-$d_strtoull" in
+"$define-$define")
+       $cat <<EOM
+Checking whether your strtoull() works okay...
+EOM
+       $cat >try.c <<'EOCP'
+#include <errno.h>
+#ifdef __hpux
+#define strtoull __strtoull
+#endif
+#include <stdio.h>
+extern unsigned long long int strtoull(char *s, char **, int); 
 static int bad = 0;
 int check(char *s, long long eull, int een) {
        long long gull;
@@ -11717,10 +12124,17 @@ int check(char *s, long long eull, int een) {
                bad++;
 }
 int main() {
-       check(" 1",                                       1LL, 0);
-       check(" 0",                                       0LL, 0);
-       check("18446744073709551615", 18446744073709551615ULL, 0);
-       check("18446744073709551616", 18446744073709551615ULL, ERANGE);
+       check(" 1",                                        1LL, 0);
+       check(" 0",                                        0LL, 0);
+       check("18446744073709551615",  18446744073709551615ULL, 0);
+       check("18446744073709551616",  18446744073709551615ULL, ERANGE);
+#if 0 /* strtoull() for /^-/ strings is undefined. */
+       check("-1",                    18446744073709551615ULL, 0);
+       check("-18446744073709551614",                     2LL, 0);
+       check("-18446744073709551615",                     1LL, 0);
+               check("-18446744073709551616", 18446744073709551615ULL, ERANGE);
+       check("-18446744073709551617", 18446744073709551615ULL, ERANGE);
+#endif
        if (!bad)
                printf("ok\n");
 }
@@ -11743,6 +12157,54 @@ esac
 set strtouq d_strtouq
 eval $inlibc
 
+case "$d_strtouq" in
+"$define")
+       $cat <<EOM
+Checking whether your strtouq() works okay...
+EOM
+       $cat >try.c <<'EOCP'
+#include <errno.h>
+#include <stdio.h>
+extern unsigned long long int strtouq(char *s, char **, int); 
+static int bad = 0;
+void check(char *s, unsigned long long eull, int een) {
+       unsigned long long gull;
+       errno = 0;
+       gull = strtouq(s, 0, 10);
+       if (!((gull == eull) && (errno == een)))
+               bad++;
+}
+int main() {
+       check(" 1",                                        1LL, 0);
+       check(" 0",                                        0LL, 0);
+       check("18446744073709551615",  18446744073709551615ULL, 0);
+       check("18446744073709551616",  18446744073709551615ULL, ERANGE);
+#if 0 /* strtouq() for /^-/ strings is undefined. */
+       check("-1",                    18446744073709551615ULL, 0);
+       check("-18446744073709551614",                     2LL, 0);
+       check("-18446744073709551615",                     1LL, 0);
+               check("-18446744073709551616", 18446744073709551615ULL, ERANGE);
+       check("-18446744073709551617", 18446744073709551615ULL, ERANGE);
+#endif
+       if (!bad)
+               printf("ok\n");
+       return 0;
+}
+EOCP
+       set try
+       if eval $compile; then
+               case "`./try`" in
+               ok) echo "Your strtouq() seems to be working okay." ;;
+               *) cat <<EOM >&4
+Your strtouq() doesn't seem to be working okay.
+EOM
+                  d_strtouq="$undef"
+                  ;;
+               esac
+       fi
+       ;;
+esac
+
 : see if strxfrm exists
 set strxfrm d_strxfrm
 eval $inlibc
@@ -11934,37 +12396,6 @@ esac
 set d_void_closedir
 eval $setvar
 $rm -f closedir*
-: check for volatile keyword
-echo " "
-echo 'Checking to see if your C compiler knows about "volatile"...' >&4
-$cat >try.c <<'EOCP'
-int main()
-{
-       typedef struct _goo_struct goo_struct;
-       goo_struct * volatile goo = ((goo_struct *)0);
-       struct _goo_struct {
-               long long_int;
-               int reg_int;
-               char char_var;
-       };
-       typedef unsigned short foo_t;
-       char *volatile foo;
-       volatile int bar;
-       volatile foo_t blech;
-       foo = foo;
-}
-EOCP
-if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
-       val="$define"
-       echo "Yup, it does."
-else
-       val="$undef"
-       echo "Nope, it doesn't."
-fi
-set d_volatile
-eval $setvar
-$rm -f try.*
-
 : see if there is a wait4
 set wait4 d_wait4
 eval $inlibc
@@ -13274,6 +13705,168 @@ rp="What is the type used for file modes for system calls (e.g. fchmod())?"
 set mode_t modetype int stdio.h sys/types.h
 eval $typedef_ask
 
+: see if stdarg is available
+echo " "
+if $test `./findhdr stdarg.h`; then
+       echo "<stdarg.h> found." >&4
+       valstd="$define"
+else
+       echo "<stdarg.h> NOT found." >&4
+       valstd="$undef"
+fi
+
+: see if varags is available
+echo " "
+if $test `./findhdr varargs.h`; then
+       echo "<varargs.h> found." >&4
+else
+       echo "<varargs.h> NOT found, but that's ok (I hope)." >&4
+fi
+
+: set up the varargs testing programs
+$cat > varargs.c <<EOP
+#ifdef I_STDARG
+#include <stdarg.h>
+#endif
+#ifdef I_VARARGS
+#include <varargs.h>
+#endif
+
+#ifdef I_STDARG
+int f(char *p, ...)
+#else
+int f(va_alist)
+va_dcl
+#endif
+{
+       va_list ap;
+#ifndef I_STDARG
+       char *p;
+#endif
+#ifdef I_STDARG
+       va_start(ap,p);
+#else
+       va_start(ap);
+       p = va_arg(ap, char *);
+#endif
+       va_end(ap);
+}
+EOP
+$cat > varargs <<EOP
+$startsh
+if $cc -c $ccflags -D\$1 varargs.c >/dev/null 2>&1; then
+       echo "true"
+else
+       echo "false"
+fi
+$rm -f varargs$_o
+EOP
+chmod +x varargs
+
+: now check which varargs header should be included
+echo " "
+i_varhdr=''
+case "$valstd" in
+"$define")
+       if `./varargs I_STDARG`; then
+               val='stdarg.h'
+       elif `./varargs I_VARARGS`; then
+               val='varargs.h'
+       fi
+       ;;
+*)
+       if `./varargs I_VARARGS`; then
+               val='varargs.h'
+       fi
+       ;;
+esac
+case "$val" in
+'')
+echo "I could not find the definition for va_dcl... You have problems..." >&4
+       val="$undef"; set i_stdarg; eval $setvar
+       val="$undef"; set i_varargs; eval $setvar
+       ;;
+*) 
+       set i_varhdr
+       eval $setvar
+       case "$i_varhdr" in
+       stdarg.h)
+               val="$define"; set i_stdarg; eval $setvar
+               val="$undef"; set i_varargs; eval $setvar
+               ;;
+       varargs.h)
+               val="$undef"; set i_stdarg; eval $setvar
+               val="$define"; set i_varargs; eval $setvar
+               ;;
+       esac
+       echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;;
+esac
+$rm -f varargs*
+
+: see if we need va_copy
+echo " "
+case "$i_stdarg" in
+"$define")
+       $cat >try.c <<EOCP
+#include <stdarg.h>
+#include <stdio.h>
+#$i_stdlib I_STDLIB
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#include <signal.h>
+
+int
+ivfprintf(FILE *f, const char *fmt, va_list *valp)
+{
+  return vfprintf(f, fmt, *valp);
+}
+int    
+myvfprintf(FILE *f, const  char *fmt, va_list val)
+{
+  return ivfprintf(f, fmt, &val);
+}
+      
+int
+myprintf(char *fmt, ...) 
+{
+  va_list val;
+  va_start(val, fmt);
+  return myvfprintf(stdout, fmt, val); 
+}         
+
+int
+main(int ac, char **av)
+{
+  signal(SIGSEGV, exit);
+
+  myprintf("%s%cs all right, then\n", "that", '\'');                            
+  exit(0);      
+}
+EOCP
+       set try
+       if eval $compile && ./try 2>&1 >/dev/null; then
+               case "`./try`" in
+               "that's all right, then")
+                       okay=yes
+                       ;;
+               esac
+       fi
+       case "$okay" in
+       yes)    echo "It seems that you don't need va_copy()." >&4
+               need_va_copy="$undef"
+               ;;
+       *)      echo "It seems that va_copy() or similar will be needed." >&4
+               need_va_copy="$define"
+               ;;
+       esac
+       $rm -f try.* core core.* *.core *.core.*
+       ;;
+*)     echo "You don't have <stdarg.h>, not checking for va_copy()." >&4
+       ;;
+esac
+
 : define a fucntion to check prototypes
 $cat > protochk <<EOSH
 $startsh
@@ -14031,6 +14624,10 @@ $rm -f try try.*
 set d_socklen_t
 eval $setvar
 
+: see if this is a socks.h system
+set socks.h i_socks
+eval $inhdr
+
 : check for type of the size argument to socket calls
 case "$d_socket" in
 "$define")
@@ -14038,7 +14635,6 @@ case "$d_socket" in
 
 Checking to see what type is the last argument of accept().
 EOM
-       hdrs="$define sys/types.h $d_socket sys/socket.h" 
        yyy=''
        case "$d_socklen_t" in
        "$define") yyy="$yyy socklen_t"
@@ -14047,10 +14643,19 @@ EOM
        for xxx in $yyy; do
                case "$socksizetype" in
                '')     try="extern int accept(int, struct sockaddr *, $xxx *);"
-                       if ./protochk "$try" $hdrs; then
-                               echo "Your system accepts '$xxx *' for the last argument of accept()."
-                               socksizetype="$xxx"
-                       fi
+                       case "$usesocks" in
+                       "$define")
+                               if ./protochk "$try" $i_systypes sys/types.h $d_socket sys/socket.h literal '#define INCLUDE_PROTOTYPES' $i_socks socks.h.; then
+                                       echo "Your system accepts '$xxx *' for the last argument of accept()."
+                                       socksizetype="$xxx"
+                               fi
+                               ;;
+                       *)      if ./protochk "$try"  $i_systypes sys/types.h $d_socket sys/socket.h; then
+                                       echo "Your system accepts '$xxx *' for the last argument of accept()."
+                                       socksizetype="$xxx"
+                               fi
+                               ;;
+                       esac
                        ;;
                esac
        done
@@ -14111,13 +14716,17 @@ $rm -f ssize ssize.*
 
 : see what type of char stdio uses.
 echo " "
-if $contains 'unsigned.*char.*_ptr;' `./findhdr stdio.h` >/dev/null 2>&1 ; then
+echo '#include <stdio.h>' | $cppstdin $cppminus > stdioh
+if $contains 'unsigned.*char.*_ptr;' stdioh >/dev/null 2>&1 ; then
        echo "Your stdio uses unsigned chars." >&4
        stdchar="unsigned char"
 else
        echo "Your stdio uses signed chars." >&4
        stdchar="char"
 fi
+$rm -f stdioh
+
+
 
 : see if time exists
 echo " "
@@ -14514,7 +15123,7 @@ EOSH
 ./tr '[a-z]' '[A-Z]' < Cppsym.know > Cppsym.a
 ./tr '[A-Z]' '[a-z]' < Cppsym.know > Cppsym.b
 $cat Cppsym.know > Cppsym.c
-$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | sort | uniq > Cppsym.know
+$cat Cppsym.a Cppsym.b Cppsym.c | $tr ' ' $trnl | $sort | $uniq > Cppsym.know
 $rm -f Cppsym.a Cppsym.b Cppsym.c
 cat <<EOSH > Cppsym
 $startsh
@@ -14697,108 +15306,6 @@ val=$val3; set i_termios; eval $setvar
 set shadow.h i_shadow
 eval $inhdr
 
-: see if this is a socks.h system
-set socks.h i_socks
-eval $inhdr
-
-: see if stdarg is available
-echo " "
-if $test `./findhdr stdarg.h`; then
-       echo "<stdarg.h> found." >&4
-       valstd="$define"
-else
-       echo "<stdarg.h> NOT found." >&4
-       valstd="$undef"
-fi
-
-: see if varags is available
-echo " "
-if $test `./findhdr varargs.h`; then
-       echo "<varargs.h> found." >&4
-else
-       echo "<varargs.h> NOT found, but that's ok (I hope)." >&4
-fi
-
-: set up the varargs testing programs
-$cat > varargs.c <<EOP
-#ifdef I_STDARG
-#include <stdarg.h>
-#endif
-#ifdef I_VARARGS
-#include <varargs.h>
-#endif
-
-#ifdef I_STDARG
-int f(char *p, ...)
-#else
-int f(va_alist)
-va_dcl
-#endif
-{
-       va_list ap;
-#ifndef I_STDARG
-       char *p;
-#endif
-#ifdef I_STDARG
-       va_start(ap,p);
-#else
-       va_start(ap);
-       p = va_arg(ap, char *);
-#endif
-       va_end(ap);
-}
-EOP
-$cat > varargs <<EOP
-$startsh
-if $cc -c $ccflags -D\$1 varargs.c >/dev/null 2>&1; then
-       echo "true"
-else
-       echo "false"
-fi
-$rm -f varargs$_o
-EOP
-chmod +x varargs
-
-: now check which varargs header should be included
-echo " "
-i_varhdr=''
-case "$valstd" in
-"$define")
-       if `./varargs I_STDARG`; then
-               val='stdarg.h'
-       elif `./varargs I_VARARGS`; then
-               val='varargs.h'
-       fi
-       ;;
-*)
-       if `./varargs I_VARARGS`; then
-               val='varargs.h'
-       fi
-       ;;
-esac
-case "$val" in
-'')
-echo "I could not find the definition for va_dcl... You have problems..." >&4
-       val="$undef"; set i_stdarg; eval $setvar
-       val="$undef"; set i_varargs; eval $setvar
-       ;;
-*) 
-       set i_varhdr
-       eval $setvar
-       case "$i_varhdr" in
-       stdarg.h)
-               val="$define"; set i_stdarg; eval $setvar
-               val="$undef"; set i_varargs; eval $setvar
-               ;;
-       varargs.h)
-               val="$undef"; set i_stdarg; eval $setvar
-               val="$define"; set i_varargs; eval $setvar
-               ;;
-       esac
-       echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;;
-esac
-$rm -f varargs*
-
 : see if stddef is available
 set stddef.h i_stddef
 eval $inhdr
@@ -15343,6 +15850,7 @@ d_PRIo64='$d_PRIo64'
 d_PRIu64='$d_PRIu64'
 d_PRIx64='$d_PRIx64'
 d_SCNfldbl='$d_SCNfldbl'
+d__fwalk='$d__fwalk'
 d_access='$d_access'
 d_accessx='$d_accessx'
 d_alarm='$d_alarm'
@@ -15389,6 +15897,7 @@ d_eunice='$d_eunice'
 d_fchmod='$d_fchmod'
 d_fchown='$d_fchown'
 d_fcntl='$d_fcntl'
+d_fcntl_can_lock='$d_fcntl_can_lock'
 d_fd_macros='$d_fd_macros'
 d_fd_set='$d_fd_set'
 d_fds_bits='$d_fds_bits'
@@ -15404,6 +15913,7 @@ d_fseeko='$d_fseeko'
 d_fsetpos='$d_fsetpos'
 d_fstatfs='$d_fstatfs'
 d_fstatvfs='$d_fstatvfs'
+d_fsync='$d_fsync'
 d_ftello='$d_ftello'
 d_ftime='$d_ftime'
 d_getcwd='$d_getcwd'
@@ -15423,6 +15933,7 @@ d_getnbyaddr='$d_getnbyaddr'
 d_getnbyname='$d_getnbyname'
 d_getnent='$d_getnent'
 d_getnetprotos='$d_getnetprotos'
+d_getpagsz='$d_getpagsz'
 d_getpbyname='$d_getpbyname'
 d_getpbynumber='$d_getpbynumber'
 d_getpent='$d_getpent'
@@ -15526,6 +16037,7 @@ d_rmdir='$d_rmdir'
 d_safebcpy='$d_safebcpy'
 d_safemcpy='$d_safemcpy'
 d_sanemcmp='$d_sanemcmp'
+d_sbrkproto='$d_sbrkproto'
 d_sched_yield='$d_sched_yield'
 d_scm_rights='$d_scm_rights'
 d_seekdir='$d_seekdir'
@@ -15580,6 +16092,8 @@ d_statfs_s='$d_statfs_s'
 d_statvfs='$d_statvfs'
 d_stdio_cnt_lval='$d_stdio_cnt_lval'
 d_stdio_ptr_lval='$d_stdio_ptr_lval'
+d_stdio_ptr_lval_nochange_cnt='$d_stdio_ptr_lval_nochange_cnt'
+d_stdio_ptr_lval_sets_cnt='$d_stdio_ptr_lval_sets_cnt'
 d_stdio_stream_array='$d_stdio_stream_array'
 d_stdiobase='$d_stdiobase'
 d_stdstdio='$d_stdstdio'
@@ -15592,6 +16106,7 @@ d_strtod='$d_strtod'
 d_strtol='$d_strtol'
 d_strtold='$d_strtold'
 d_strtoll='$d_strtoll'
+d_strtoq='$d_strtoq'
 d_strtoul='$d_strtoul'
 d_strtoull='$d_strtoull'
 d_strtouq='$d_strtouq'
@@ -15783,6 +16298,7 @@ installvendorarch='$installvendorarch'
 installvendorbin='$installvendorbin'
 installvendorlib='$installvendorlib'
 intsize='$intsize'
+issymlink='$issymlink'
 ivdformat='$ivdformat'
 ivsize='$ivsize'
 ivtype='$ivtype'
@@ -15845,6 +16361,7 @@ mydomain='$mydomain'
 myhostname='$myhostname'
 myuname='$myuname'
 n='$n'
+need_va_copy='$need_va_copy'
 netdb_hlen_type='$netdb_hlen_type'
 netdb_host_type='$netdb_host_type'
 netdb_name_type='$netdb_name_type'
@@ -16057,9 +16574,9 @@ echo "CONFIGDOTSH=true" >>config.sh
 
 : propagate old symbols
 if $test -f UU/config.sh; then
-       <UU/config.sh sort | uniq >UU/oldconfig.sh
+       <UU/config.sh $sort | $uniq >UU/oldconfig.sh
        sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\
-       sort | uniq -u >UU/oldsyms
+       $sort | $uniq -u >UU/oldsyms
        set X `cat UU/oldsyms`
        shift
        case $# in
index 897fae6..1480551 100644 (file)
--- a/EXTERN.h
+++ b/EXTERN.h
@@ -1,6 +1,6 @@
 /*    EXTERN.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
diff --git a/INSTALL b/INSTALL
index 50e7773..3aa80ca 100644 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -517,6 +517,23 @@ directories to add to @INC.  By default, it will be empty.
 Perl will search these directories (including architecture and
 version-specific subdirectories) for add-on modules and extensions.
 
+=item APPLLIB_EXP
+
+There is one other way of adding paths to @INC at perl build time, and
+that is by setting the APPLLIB_EXP C pre-processor token to a colon-
+separated list of directories, like this
+
+       sh Configure -Accflags='-DAPPLLIB_EXP=\"/usr/libperl\"'
+
+The directories defined by APPLLIB_EXP get added to @INC I<first>,
+ahead of any others, and so provide a way to override the standard perl
+modules should you, for example, want to distribute fixes without
+touching the perl distribution proper.  And, like otherlib dirs,
+version and architecture specific subdirectories are also searched, if
+present, at run time.  Of course, you can still search other @INC
+directories ahead of those in APPLLIB_EXP by using any of the standard
+run-time methods: $PERLLIB, $PERL5LIB, -I, use lib, etc.
+
 =item Man Pages
 
 In versions 5.005_57 and earlier, the default was to store module man
@@ -1131,6 +1148,39 @@ you have some libraries under /usr/local/ and others under
 
 =back
 
+=head2 Building DB, NDBM, and ODBM interfaces with Berkeley DB 3
+
+Perl interface for DB3 is part of Berkeley DB, but if you want to
+compile standard Perl DB/ODBM/NDBM interfaces, you must follow
+following instructions.
+
+Berkeley DB3 from Sleepycat Software is by default installed without
+DB1 compatibility code (needed for DB_File interface) and without
+links to compatibility files. So if you want to use packages written
+for DB/ODBM/NDBM interfaces, you need to configure DB3 with
+--enable-compat185 (and optionally with --enable-dump185) and create
+additional references (suppose you are installing DB3 with
+--prefix=/usr):
+
+    ln -s libdb-3.so /usr/lib/libdbm.so
+    ln -s libdb-3.so /usr/lib/libndbm.so
+    echo '#define DB_DBM_HSEARCH 1' >dbm.h 
+    echo '#include <db.h>' >>dbm.h
+    install -m 0644 dbm.h /usr/include/dbm.h 
+    install -m 0644 dbm.h /usr/include/ndbm.h
+
+Optionally, if you have compiled with --enable-compat185 (not needed
+for ODBM/NDBM):
+
+    ln -s libdb-3.so /usr/lib/libdb1.so
+    ln -s libdb-3.so /usr/lib/libdb.so
+
+ODBM emulation seems not to be perfect, but is quite usable,
+using DB 3.1.17:
+
+    lib/odbm.............FAILED at test 9
+        Failed 1/64 tests, 98.44% okay
+
 =head2 What if it doesn't work?
 
 If you run into problems, try some of the following ideas.
@@ -1397,36 +1447,6 @@ numbers and function name may vary in different versions of perl):
 it might well be a symptom of the gcc "varargs problem".  See the
 previous L<"varargs"> item.
 
-=item Solaris and SunOS dynamic loading
-
-If you have problems with dynamic loading using gcc on SunOS or
-Solaris, and you are using GNU as and GNU ld, you may need to add
--B/bin/ (for SunOS) or -B/usr/ccs/bin/ (for Solaris) to your
-$ccflags, $ldflags, and $lddlflags so that the system's versions of as
-and ld are used.  Note that the trailing '/' is required.
-Alternatively, you can use the GCC_EXEC_PREFIX
-environment variable to ensure that Sun's as and ld are used.  Consult
-your gcc documentation for further information on the -B option and
-the GCC_EXEC_PREFIX variable.
-
-One convenient way to ensure you are not using GNU as and ld is to
-invoke Configure with
-
-    sh Configure -Dcc='gcc -B/usr/ccs/bin/'
-
-for Solaris systems.  For a SunOS system, you must use -B/bin/
-instead.
-
-Alternatively, recent versions of GNU ld reportedly work if you
-include C<-Wl,-export-dynamic> in the ccdlflags variable in
-config.sh.
-
-=item ld.so.1: ./perl: fatal: relocation error:
-
-If you get this message on SunOS or Solaris, and you're using gcc,
-it's probably the GNU as or GNU ld problem in the previous item
-L<"Solaris and SunOS dynamic loading">.
-
 =item LD_LIBRARY_PATH
 
 If you run into dynamic loading problems, check your setting of
@@ -1435,18 +1455,6 @@ Perl library (libperl.a rather than libperl.so) it should build
 fine with LD_LIBRARY_PATH unset, though that may depend on details
 of your local set-up.
 
-=item dlopen: stub interception failed
-
-The primary cause of the 'dlopen: stub interception failed' message is
-that the LD_LIBRARY_PATH environment variable includes a directory
-which is a symlink to /usr/lib (such as /lib).
-
-The reason this causes a problem is quite subtle.  The file libdl.so.1.0
-actually *only* contains functions which generate 'stub interception
-failed' errors!  The runtime linker intercepts links to
-"/usr/lib/libdl.so.1.0" and links in internal implementation of those
-functions instead.  [Thanks to Tim Bunce for this explanation.]
-
 =item nm extraction
 
 If Configure seems to be having trouble finding library functions,
@@ -1632,24 +1640,11 @@ official site named at the start of this document.  If you do find
 that any site is carrying a corrupted or incomplete source code
 archive, please report it to the site's maintainer.
 
-This message can also be a symptom of using (say) a GNU tar compiled
-for SunOS4 on Solaris.  When you run SunOS4 binaries on Solaris the
-run-time system magically alters pathnames matching m#lib/locale# - so
-when tar tries to create lib/locale.pm a differently-named file gets
-created instead.
-
-You may find the file under its assumed name and be able to rename it
-back.  Or use Sun's tar to do the extract.
-
 =item invalid token: ##
 
 You are using a non-ANSI-compliant C compiler.  See L<WARNING:  This
 version requires a compiler that supports ANSI C>.
 
-=item lib/locale.pm: No such file or directory
-
-See L<THIS PACKAGE SEEMS TO BE INCOMPLETE>.
-
 =item Miscellaneous
 
 Some additional things that have been reported for either perl4 or perl5:
index 286cc46..1b35c13 100644 (file)
--- a/INTERN.h
+++ b/INTERN.h
@@ -1,6 +1,6 @@
 /*    INTERN.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
diff --git a/MAINTAIN b/MAINTAIN
deleted file mode 100644 (file)
index cd1e4ed..0000000
--- a/MAINTAIN
+++ /dev/null
@@ -1,904 +0,0 @@
-# In addition to actual maintainers this file also lists "interested parties".
-#
-# The maintainer aliases come from AUTHORS.  They may be defined in
-# a layered way: 'doc' expands to tchrist which expands to Tom Christiansen.
-#
-# A file that is in MANIFEST need not be here at all.
-# In any case, if nobody else is listed as maintainer,
-# PUMPKING (from AUTHORS) should be it.
-#
-# Filenames can contain * which means qr(.*) on the filenames found
-# using File::Find (it's _not_ filename glob).
-#
-# Maintainership definitions are of course cumulative: if A maintains
-# X/* and B maintains X/Y/Z, if X/Y/Z is changed, both A and B should
-# be notified.
-#
-# The filename(glob) and the maintainer(s) are separated by one or more tabs.
-
-Artistic       
-Changes        
-Changes5.000   
-Changes5.001   
-Changes5.002   
-Changes5.003   
-Changes5.004   
-Changes5.005   
-Configure                      cfg
-Copying        
-EXTERN.h       
-INSTALL        
-INTERN.h       
-MANIFEST       
-Makefile.SH    
-Makefile.micro                 simon
-objXSUB.h      
-Policy_sh.SH   
-Porting/*                      cfg
-Porting/Contract       
-Porting/Glossary       
-Porting/config.sh      
-Porting/config_H       
-Porting/findvars       
-Porting/fixCORE        
-Porting/fixvars        
-Porting/genlog 
-Porting/makerel        
-Porting/p4d2p  
-Porting/p4desc 
-Porting/patching.pod           dgris
-Porting/patchls        
-Porting/pumpkin.pod    
-README 
-README.amiga                   amiga
-README.beos                    beos
-README.cygwin                  cygwin
-README.dos                     dos
-README.hpux                    hpux
-README.lexwarn                 lexwarn
-README.machten                 machten
-README.micro                   simon
-README.mpeix                   mpeix
-README.os2                     os2
-README.os390                   os390
-README.plan9                   plan9
-README.posix-bc                        posix-bc
-README.qnx                     qnx
-README.threads 
-README.vmesa                   vmesa
-README.vms                     vms
-README.vos                     vos
-README.win32                   win32
-Todo   
-Todo-5.005     
-Todo.micro                     simon
-XSlock.h       
-XSUB.h 
-av.c   
-av.h   
-beos/*                         beos
-bytecode.h     
-bytecode.pl    
-byterun.c      
-byterun.h      
-cc_runtime.h   
-cflags.SH      
-config_h.SH                    cfg
-configpm       
-configure.com                  vms
-configure.gnu  
-cop.h  
-cv.h   
-cygwin/*                       cygwin
-deb.c  
-djgpp/*                                dos
-doio.c 
-doop.c 
-dosish.h       
-dump.c 
-ebcdic.c               
-eg/ADB 
-eg/README      
-eg/cgi/*                       cgi
-eg/changes     
-eg/client      
-eg/down        
-eg/dus 
-eg/findcp      
-eg/findtar     
-eg/g/gcp       
-eg/g/gcp.man   
-eg/g/ged       
-eg/g/ghosts    
-eg/g/gsh       
-eg/g/gsh.man   
-eg/muck        
-eg/muck.man    
-eg/myrup       
-eg/nih 
-eg/relink      
-eg/rename      
-eg/rmfrom      
-eg/scan/scan_df        
-eg/scan/scan_last      
-eg/scan/scan_messages  
-eg/scan/scan_passwd    
-eg/scan/scan_ps        
-eg/scan/scan_sudo      
-eg/scan/scan_suid      
-eg/scan/scanner        
-eg/server      
-eg/shmkill     
-eg/sysvipc/README      
-eg/sysvipc/ipcmsg      
-eg/sysvipc/ipcsem      
-eg/sysvipc/ipcshm      
-eg/travesty    
-eg/unuc        
-eg/uudecode    
-eg/van/empty   
-eg/van/unvanish        
-eg/van/vanexp  
-eg/van/vanish  
-eg/who 
-eg/wrapsuid    
-emacs/*                                ilya
-embed.h        
-embed.pl       
-embedvar.h     
-ext/*/hints*                   cfg
-ext/B/*                                nik
-ext/B/B/Deparse.pm             smccam
-ext/DB_File*                   pmarquess
-ext/DB_File/hints/dynixptx.pl  dynix/ptx
-ext/Data/Dumper/*              gsar
-ext/Devel/DProf/*
-ext/Devel/Peek/*               ilya
-ext/DynaLoader/DynaLoader_pm.PL        
-ext/DynaLoader/Makefile.PL     
-ext/DynaLoader/README  
-ext/DynaLoader/dl_aix.xs       aix
-ext/DynaLoader/dl_dld.xs       rsanders
-ext/DynaLoader/dl_dlopen.xs    timb
-ext/DynaLoader/dl_hpux.xs      hpux
-ext/DynaLoader/dl_mpeix.xs     mpeix
-ext/DynaLoader/dl_next.xs      next
-ext/DynaLoader/dl_none.xs      
-ext/DynaLoader/dl_vms.xs       vms
-ext/DynaLoader/dl_vmesa.xs     vmesa
-ext/DynaLoader/dlutils.c       
-ext/DynaLoader/hints/linux.pl  linux
-ext/Errno/*                    gbarr
-ext/Fcntl/*                    jhi
-ext/GDBM_File/GDBM_File.pm     
-ext/GDBM_File/GDBM_File.xs     
-ext/GDBM_File/Makefile.PL      
-ext/GDBM_File/typemap  
-ext/IO/*                       
-ext/IPC/SysV/*                 gbarr
-ext/NDBM_File/Makefile.PL      
-ext/NDBM_File/NDBM_File.pm     
-ext/NDBM_File/NDBM_File.xs     
-ext/NDBM_File/hints/dec_osf.pl dec_osf
-ext/NDBM_File/hints/dynixptx.pl        dynix/ptx
-ext/NDBM_File/hints/solaris.pl solaris
-ext/NDBM_File/hints/svr4.pl    svr4
-ext/NDBM_File/typemap  
-ext/ODBM_File/Makefile.PL      
-ext/ODBM_File/ODBM_File.pm     
-ext/ODBM_File/ODBM_File.xs     
-ext/ODBM_File/hints/dec_osf.pl dec_osf
-ext/ODBM_File/hints/hpux.pl    hpux
-ext/ODBM_File/hints/sco.pl     sco
-ext/ODBM_File/hints/solaris.pl solaris
-ext/ODBM_File/hints/svr4.pl    svr4
-ext/ODBM_File/hints/ultrix.pl
-ext/ODBM_File/typemap  
-ext/Opcode/Makefile.PL 
-ext/Opcode/Opcode.pm   
-ext/Opcode/Opcode.xs   
-ext/Opcode/Safe.pm     
-ext/Opcode/ops.pm      
-ext/POSIX/Makefile.PL  
-ext/POSIX/POSIX.pm     
-ext/POSIX/POSIX.pod    
-ext/POSIX/POSIX.xs     
-ext/POSIX/hints/bsdos.pl       bsdos
-ext/POSIX/hints/dynixptx.pl    dynix/ptx
-ext/POSIX/hints/freebsd.pl     freebsd
-ext/POSIX/hints/linux.pl       linux
-ext/POSIX/hints/netbsd.pl      netbsd
-ext/POSIX/hints/next_3.pl      next
-ext/POSIX/hints/openbsd.pl     openbsd
-ext/POSIX/hints/sunos_4.pl     sunos4
-ext/POSIX/typemap      
-ext/SDBM_File/Makefile.PL      
-ext/SDBM_File/SDBM_File.pm     
-ext/SDBM_File/SDBM_File.xs     
-ext/SDBM_File/sdbm/CHANGES     
-ext/SDBM_File/sdbm/COMPARE     
-ext/SDBM_File/sdbm/Makefile.PL 
-ext/SDBM_File/sdbm/README      
-ext/SDBM_File/sdbm/README.too  
-ext/SDBM_File/sdbm/biblio      
-ext/SDBM_File/sdbm/dba.c       
-ext/SDBM_File/sdbm/dbd.c       
-ext/SDBM_File/sdbm/dbe.1       
-ext/SDBM_File/sdbm/dbe.c       
-ext/SDBM_File/sdbm/dbm.c       
-ext/SDBM_File/sdbm/dbm.h       
-ext/SDBM_File/sdbm/dbu.c       
-ext/SDBM_File/sdbm/grind       
-ext/SDBM_File/sdbm/hash.c      
-ext/SDBM_File/sdbm/linux.patches       
-ext/SDBM_File/sdbm/makefile.sdbm       
-ext/SDBM_File/sdbm/pair.c      
-ext/SDBM_File/sdbm/pair.h      
-ext/SDBM_File/sdbm/readme.ms   
-ext/SDBM_File/sdbm/sdbm.3      
-ext/SDBM_File/sdbm/sdbm.c      
-ext/SDBM_File/sdbm/sdbm.h      
-ext/SDBM_File/sdbm/tune.h      
-ext/SDBM_File/sdbm/util.c      
-ext/SDBM_File/typemap  
-ext/Socket/Makefile.PL 
-ext/Socket/Socket.pm   
-ext/Socket/Socket.xs   
-ext/Thread/Makefile.PL 
-ext/Thread/Notes       
-ext/Thread/README      
-ext/Thread/Thread.pm   
-ext/Thread/Thread.xs   
-ext/Thread/Thread/Queue.pm     
-ext/Thread/Thread/Semaphore.pm 
-ext/Thread/Thread/Signal.pm    
-ext/Thread/Thread/Specific.pm  
-ext/Thread/create.t    
-ext/Thread/die.t       
-ext/Thread/die2.t      
-ext/Thread/io.t        
-ext/Thread/join.t      
-ext/Thread/join2.t     
-ext/Thread/list.t      
-ext/Thread/lock.t      
-ext/Thread/queue.t     
-ext/Thread/specific.t  
-ext/Thread/sync.t      
-ext/Thread/sync2.t     
-ext/Thread/typemap     
-ext/Thread/unsync.t    
-ext/Thread/unsync2.t   
-ext/Thread/unsync3.t   
-ext/Thread/unsync4.t   
-ext/attrs/Makefile.PL  
-ext/attrs/attrs.pm     
-ext/attrs/attrs.xs     
-ext/re/Makefile.PL     
-ext/re/hints/mpeix.pl          mpeix
-ext/re/re.pm                   regex
-ext/re/re.xs                   regex
-ext/util/make_ext      
-ext/util/mkbootstrap   
-fakethr.h      
-form.h 
-global.sym     
-globals.c      
-globvar.sym    
-gv.c   
-gv.h   
-h2pl/README    
-h2pl/cbreak.pl 
-h2pl/cbreak2.pl        
-h2pl/eg/sizeof.ph      
-h2pl/eg/sys/errno.pl   
-h2pl/eg/sys/ioctl.pl   
-h2pl/eg/sysexits.pl    
-h2pl/getioctlsizes     
-h2pl/mksizes   
-h2pl/mkvars    
-h2pl/tcbreak   
-h2pl/tcbreak2  
-handy.h        
-hints/*                                cfg
-hints/3b1.sh   
-hints/3b1cc    
-hints/README.hints     
-hints/aix.sh                   aix
-hints/altos486.sh      
-hints/amigaos.sh               amiga
-hints/apollo.sh        
-hints/aux_3.sh 
-hints/beos.sh                  beos
-hints/broken-db.msg    
-hints/bsdos.sh                 bsdos
-hints/convexos.sh      
-hints/cxux.sh                  cxux
-hints/cygwin.sh                        cygwin
-hints/dcosx.sh 
-hints/dec_osf.sh               dec_osf
-hints/dgux.sh                  dgux
-hints/dos_djgpp.sh             dos
-hints/dynix.sh                 dynix/ptx
-hints/dynixptx.sh              dynix/ptx
-hints/epix.sh  
-hints/esix4.sh 
-hints/fps.sh   
-hints/freebsd.sh               freebsd
-hints/genix.sh 
-hints/greenhills.sh    
-hints/hpux.sh                  hpux
-hints/i386.sh  
-hints/irix*                    irix
-hints/isc.sh   
-hints/isc_2.sh 
-hints/linux.sh                 linux
-hints/lynxos.sh
-hints/machten.sh               machten
-hints/machten_2.sh     
-hints/mips.sh  
-hints/mpc.sh   
-hints/mpeix.sh                 mpeix
-hints/ncr_tower.sh     
-hints/netbsd.sh                        netbsd
-hints/newsos4.sh       
-hints/next*                    step
-hints/openbsd.sh               openbsd
-hints/opus.sh  
-hints/os2.sh                   os2
-hints/os390.sh                 os390
-hints/posix-bc.sh              posix-bc
-hints/powerux.sh               powerux
-hints/qnx.sh                   qnx
-hints/sco.sh   
-hints/sco_2_3_0.sh     
-hints/sco_2_3_1.sh     
-hints/sco_2_3_2.sh     
-hints/sco_2_3_3.sh     
-hints/sco_2_3_4.sh     
-hints/solaris_2.sh             solaris
-hints/stellar.sh       
-hints/sunos_4*                 sunos4
-hints/svr4.sh                  svr4
-hints/ti1500.sh        
-hints/titanos.sh       
-hints/ultrix_4.sh              ultrix
-hints/umips.sh 
-hints/unicos*                  unicos
-hints/unisysdynix.sh   
-hints/utekv.sh 
-hints/uts.sh   
-hints/uwin.sh                  uwin
-hints/vmesa.sh                 vmesa
-hv.c   
-hv.h   
-installhtml    
-installman     
-installperl    
-intrpvar.h     
-iperlsys.h     
-jpl/*                          jpl
-keywords.h     
-keywords.pl    
-lib/AnyDBM_File.pm     
-lib/AutoLoader.pm      
-lib/AutoSplit.pm       
-lib/Benchmark.pm               jhi,timb
-lib/CGI*                       cgi
-lib/CPAN*                      cpan
-lib/Carp.pm    
-lib/Class/Struct.pm            tchrist
-lib/Cwd.pm     
-lib/Devel/SelfStubber.pm       
-lib/DirHandle.pm       
-lib/English.pm 
-lib/Env.pm     
-lib/Exporter.pm        
-lib/ExtUtils/*                 mm
-lib/ExtUtils/Command.pm                nik
-lib/ExtUtils/Embed.pm          doug
-lib/ExtUtils/Installed.pm      alan.burlison
-lib/ExtUtils/Mksymlists.pm     cbail
-lib/ExtUtils/MM_OS2.pm         os2
-lib/ExtUtils/MM_VMS.pm         vms
-lib/ExtUtils/MM_Win32.pm       win32
-lib/ExtUtils/Packlist.pm       alan.burlison
-lib/Fatal.pm   
-lib/File/Basename.pm   
-lib/File/CheckTree.pm  
-lib/File/Compare.pm            nik
-lib/File/Copy.pm               cbail
-lib/File/DosGlob.pm            gsar
-lib/File/Find.pm       
-lib/File/Path.pm               timb,cbail
-lib/File/Spec*                 kjahds
-lib/File/Spec/Mac.pm           schinder
-lib/File/Spec/OS2.pm           ilya
-lib/File/Spec/VMS.pm           vms
-lib/File/Spec/Win32.pm         win32
-lib/File/Temp.pm               tjenness
-lib/File/stat.pm               tchrist
-lib/FileCache.pm       
-lib/FileHandle.pm      
-lib/FindBin.pm 
-lib/Getopt/Long.pm             jvromans
-lib/I18N/Collate.pm            jhi
-lib/IPC/Open2.pm       
-lib/IPC/Open3.pm       
-lib/Math/BigFloat.pm           mbiggar
-lib/Math/BigInt.pm             mbiggar
-lib/Math/Complex.pm            complex
-lib/Math/Trig.pm               complex
-lib/Net/Ping.pm        
-lib/Net/hostent.pm             tchrist
-lib/Net/netent.pm              tchrist
-lib/Net/protoent.pm            tchrist
-lib/Net/servent.pm             tchrist
-lib/Pod/Checker.pm             bradapp
-lib/Pod/Functions.pm   
-lib/Pod/Html.pm                        tchrist
-lib/Pod/InputObjects.pm                bradapp
-lib/Pod/LaTeX.pm               tjenness
-lib/Pod/Man.pm                 rra
-lib/Pod/Parser.pm              bradapp
-lib/Pod/PlainText.pm           bradapp
-lib/Pod/Select.pm              bradapp
-lib/Pod/Text.pm                        rra
-lib/Pod/Text/*                 rra
-lib/Pod/Usage.pm               bradapp
-lib/Search/Dict.pm     
-lib/SelectSaver.pm     
-lib/SelfLoader.pm      
-lib/Shell.pm   
-lib/Symbol.pm  
-lib/Sys/Hostname.pm            sundstrom
-lib/Sys/Syslog.pm              tchrist
-lib/Term/ANSIcolor.pm          rra
-lib/Term/Cap.pm        
-lib/Term/Complete.pm           wayne.thompson
-lib/Term/ReadLine.pm   
-lib/Test.pm    
-lib/Test/Harness.pm            k
-lib/Text/Abbrev.pm     
-lib/Text/ParseWords.pm         pomeranz
-lib/Text/Soundex.pm            mikestok
-lib/Text/Tabs.pm               muir
-lib/Text/Wrap.pm               muir
-lib/Tie/Array.pm               nik
-lib/Tie/Handle.pm      
-lib/Tie/Hash.pm        
-lib/Tie/RefHash.pm             gsar
-lib/Tie/Scalar.pm      
-lib/Tie/SubstrHash.pm  
-lib/Time/Local.pm              pomeranz
-lib/Time/gmtime.pm             tchrist
-lib/Time/localtime.pm          tchrist
-lib/Time/tm.pm                 tchrist
-lib/UNIVERSAL.pm       
-lib/User/grent.pm              tchrist
-lib/User/pwent.pm              tchrist
-lib/abbrev.pl  
-lib/assert.pl  
-lib/autouse.pm 
-lib/base.pm    
-lib/bigfloat.pl        
-lib/bigint.pl  
-lib/bigrat.pl  
-lib/blib.pm    
-lib/cacheout.pl        
-lib/charnames.pm               ilya
-lib/chat2.pl   
-lib/complete.pl        
-lib/constant.pm        
-lib/ctime.pl   
-lib/diagnostics.pm             doc
-lib/dotsh.pl   
-lib/dumpvar.pl 
-lib/exceptions.pl      
-lib/fastcwd.pl 
-lib/fields.pm  
-lib/filetest.pm        
-lib/find.pl    
-lib/finddepth.pl       
-lib/flush.pl   
-lib/ftp.pl     
-lib/getcwd.pl  
-lib/getopt.pl  
-lib/getopts.pl 
-lib/hostname.pl        
-lib/importenv.pl       
-lib/integer.pm 
-lib/less.pm    
-lib/lib.pm     
-lib/locale.pm                  locale
-lib/look.pl    
-lib/newgetopt.pl       
-lib/open2.pl   
-lib/open3.pl   
-lib/overload.pm                        ilya
-lib/perl5db.pl                 ilya
-lib/pwd.pl     
-lib/shellwords.pl      
-lib/sigtrap.pm 
-lib/stat.pl    
-lib/strict.pm  
-lib/subs.pm    
-lib/syslog.pl  
-lib/tainted.pl 
-lib/termcap.pl 
-lib/timelocal.pl       
-lib/unicode/*Ethiopic*         dmulholl
-lib/unicode*                   lwall
-lib/utf8*                      lwall
-lib/validate.pl        
-lib/vars.pm    
-lib/warning.pm                 lexwarn
-makeaperl.SH   
-makedepend.SH  
-makedir.SH     
-malloc.c                       ilya
-mg.c   
-mg.h   
-minimod.pl     
-miniperlmain.c 
-mpeix/*                                mpeix
-mv-if-diff     
-myconfig       
-nostdio.h      
-op.c   
-op.h   
-opcode.h       
-opcode.pl      
-os2/*                          ilya
-patchlevel.h   
-perl.c 
-perl.h 
-perl_exp.SH    
-perlio.c       
-perlio.h       
-perlio.sym     
-perlsdio.h     
-perlsfio.h     
-perlsh 
-perlvars.h     
-perly.c        
-perly_c.diff   
-perly.fixer    
-perly.h        
-perly.y        
-plan9/*                                plan9
-pod/pod2usage.PL               bradapp
-pod/podchecker.PL              bradapp
-pod/podselect.PL               bradapp
-pod/*                          doc
-pod/buildtoc   
-pod/checkpods.PL       
-pod/perl.pod   
-pod/perlapio.pod       
-pod/perlbook.pod       
-pod/perlbot.pod        
-pod/perlcall.pod               pmarquess
-pod/perldata.pod       
-pod/perldebug.pod      
-pod/perldelta.pod      
-pod/perl5005delta.pod  
-pod/perl5004delta.pod  
-pod/perldebtut.pod             richard
-pod/perldiag.pod       
-pod/perldsc.pod                        tchrist
-pod/perlembed.pod              doug,jon
-pod/perlebcdic.pod             pvhp
-pod/perlfaq*                   gnat
-pod/perlform.pod       
-pod/perlfunc.pod       
-pod/perlguts.pod       
-pod/perlhack.pod               simon
-pod/perlhist.pod               jhi
-pod/perlipc.pod                        tchrist
-pod/perllocale.pod             locale
-pod/perllol.pod                        tchrist
-pod/perlmod.pod        
-pod/perlmodinstall.pod         jon
-pod/perlmodlib.pod             simon
-pod/perlmodlib.PL              simon
-pod/perlnewmod.pod             simon
-pod/perlobj.pod        
-pod/perlop.pod 
-pod/perlpod.pod                        lwall
-pod/perlport.pod               pudge
-pod/perlposix-bc.pod           posix-bc
-pod/perlre.pod                 regex
-pod/perlref.pod        
-pod/perlreftut.pod             mjd
-pod/perlrequick.pod            mkvale
-pod/perlretut.pod              mkvale
-pod/perlrun.pod        
-pod/perlsec.pod        
-pod/perlstyle.pod      
-pod/perlsub.pod        
-pod/perlsyn.pod        
-pod/perltie.pod                        tchrist
-pod/perltoc.pod        
-pod/perltoot.pod               tchrist
-pod/perltrap.pod       
-pod/perlunicode.pod            simon
-pod/perlutil.pod               simon
-pod/perlvar.pod        
-pod/perlxs.pod                 roehrich
-pod/perlxstut.pod              okamoto
-pod/pod2html.PL        
-pod/pod2latex.PL       
-pod/pod2man.PL 
-pod/pod2text.PL        
-pod/roffitall  
-pod/rofftoc    
-pod/splitman   
-pod/splitpod   
-pp.c   
-pp.h   
-pp.sym 
-pp_ctl.c       
-pp_hot.c       
-pp_proto.h     
-pp_sys.c       
-proto.h        
-qnx/*                          qnx
-regcomp.c                      regex
-regcomp.h                      regex
-regcomp.pl                     regex
-regcomp.sym                    regex
-regexec.c                      regex
-regexp.h                       regex
-regnodes.h                     regex
-run.c  
-scope.c        
-scope.h        
-sv.c   
-sv.h   
-t/README       
-t/TEST 
-t/UTEST        
-t/base/cond.t  
-t/base/if.t    
-t/base/lex.t   
-t/base/pat.t   
-t/base/rs.t    
-t/base/term.t  
-t/cmd/elsif.t  
-t/cmd/for.t    
-t/cmd/mod.t    
-t/cmd/subval.t 
-t/cmd/switch.t 
-t/cmd/while.t  
-t/comp/cmdopt.t        
-t/comp/colon.t 
-t/comp/cpp.aux 
-t/comp/cpp.t   
-t/comp/decl.t  
-t/comp/multiline.t     
-t/comp/package.t       
-t/comp/proto.t 
-t/comp/redef.t 
-t/comp/require.t       
-t/comp/script.t        
-t/comp/term.t  
-t/comp/use.t   
-t/harness      
-t/io/argv.t    
-t/io/dup.t     
-t/io/fs.t      
-t/io/inplace.t 
-t/io/iprefix.t 
-t/io/pipe.t    
-t/io/print.t   
-t/io/read.t    
-t/io/tell.t    
-t/lib/abbrev.t 
-t/lib/anydbm.t 
-t/lib/ansicolor.t              rra
-t/lib/autoloader.t     
-t/lib/basename.t       
-t/lib/bigint.t 
-t/lib/bigintpm.t       
-t/lib/cgi-form.t       
-t/lib/cgi-function.t   
-t/lib/cgi-html.t       
-t/lib/cgi-request.t    
-t/lib/charnames.t              ilya
-t/lib/checktree.t      
-t/lib/complex.t                        complex
-t/lib/db-btree.t               pmarquess
-t/lib/db-hash.t                        pmarquess
-t/lib/db-recno.t               pmarquess
-t/lib/dirhand.t        
-t/lib/dosglob.t        
-t/lib/dumper-ovl.t             gsar
-t/lib/dumper.t                 gsar
-t/lib/english.t        
-t/lib/env.t    
-t/lib/errno.t                  gbarr
-t/lib/fields.t 
-t/lib/filecache.t      
-t/lib/filecopy.t       
-t/lib/filefind.t       
-t/lib/filehand.t       
-t/lib/filepath.t       
-t/lib/filespec.t               kjahds
-t/lib/findbin.t        
-t/lib/ftmp-*.t                 tjenness
-t/lib/gol-basic.t              jvromans
-t/lib/gol-compat.t             jvromans
-t/lib/gol-linkage.t            jvromans
-t/lib/gdbm.t   
-t/lib/getopt.t                 jvromans
-t/lib/h2ph*                    kstar
-t/lib/hostname.t       
-t/lib/io_*                     gbarr
-t/lib/ipc_sysv.t               gbarr
-t/lib/ndbm.t   
-t/lib/odbm.t   
-t/lib/opcode.t 
-t/lib/open2.t  
-t/lib/open3.t  
-t/lib/ops.t    
-t/lib/parsewords.t     
-t/lib/ph.t                     kstar
-t/lib/posix.t  
-t/lib/safe1.t  
-t/lib/safe2.t  
-t/lib/sdbm.t   
-t/lib/searchdict.t     
-t/lib/selectsaver.t    
-t/lib/socket.t 
-t/lib/soundex.t        
-t/lib/symbol.t 
-t/lib/texttabs.t               muir
-t/lib/textfill.t               muir
-t/lib/textwrap.t       
-t/lib/thr5005.t        
-t/lib/tie-push.t       
-t/lib/tie-stdarray.t   
-t/lib/tie-stdpush.t    
-t/lib/timelocal.t      
-t/lib/trig.t   
-t/op/append.t  
-t/op/arith.t   
-t/op/array.t   
-t/op/assignwarn.t      
-t/op/auto.t    
-t/op/avhv.t    
-t/op/bop.t     
-t/op/chop.t    
-t/op/closure.t 
-t/op/cmp.t     
-t/op/cond.t    
-t/op/context.t 
-t/op/defins.t  
-t/op/delete.t  
-t/op/die.t     
-t/op/die_exit.t        
-t/op/do.t      
-t/op/each.t    
-t/op/eval.t    
-t/op/exec.t    
-t/op/exp.t     
-t/op/filetest.t        
-t/op/flip.t    
-t/op/fork.t    
-t/op/glob.t    
-t/op/goto.t    
-t/op/goto_xs.t 
-t/op/grent.t   
-t/op/groups.t  
-t/op/gv.t      
-t/op/hashwarn.t        
-t/op/inc.t     
-t/op/index.t   
-t/op/int.t     
-t/op/join.t    
-t/op/lex_assign.t      
-t/op/list.t    
-t/op/local.t   
-t/op/magic.t   
-t/op/method.t  
-t/op/misc.t    
-t/op/mkdir.t   
-t/op/my.t      
-t/op/nothr5005.t       
-t/op/oct.t     
-t/op/ord.t     
-t/op/pack.t    
-t/op/pat.t     
-t/op/pos.t     
-t/op/push.t    
-t/op/pwent.t   
-t/op/quotemeta.t       
-t/op/rand.t    
-t/op/range.t   
-t/op/re_tests                  regex
-t/op/read.t    
-t/op/readdir.t 
-t/op/recurse.t 
-t/op/ref.t     
-t/op/regexp.t                  regex
-t/op/regexp_noamp.t            regex
-t/op/repeat.t  
-t/op/runlevel.t        
-t/op/sleep.t   
-t/op/sort.t    
-t/op/splice.t  
-t/op/split.t   
-t/op/sprintf.t 
-t/op/stat.t    
-t/op/study.t   
-t/op/subst.t   
-t/op/substr.t  
-t/op/sysio.t   
-t/op/taint.t   
-t/op/tie.t     
-t/op/tiearray.t        
-t/op/tiehandle.t       
-t/op/time.t    
-t/op/tr.t      
-t/op/undef.t   
-t/op/universal.t       
-t/op/unshift.t 
-t/op/vec.t     
-t/op/wantarray.t       
-t/op/write.t   
-t/pod/*                                bradapp
-t/pragma/constant.t    
-t/pragma/locale.t              locale
-t/pragma/overload.t            ilya
-t/pragma/strict-refs   
-t/pragma/strict-subs   
-t/pragma/strict-vars   
-t/pragma/strict.t      
-t/pragma/subs.t        
-t/pragma/warn/*                        lexwarn
-t/pragma/warn/regcomp          regex
-t/pragma/warn/regexec          regex
-t/pragma/warning.t             lexwarn
-taint.c        
-thrdvar.h      
-thread.h       
-toke.c 
-uconfig.h                      simon
-uconfig.sh                     simon
-universal.c    
-unixish.h      
-utf*                           lwall
-utils/Makefile
-utils/c2ph.PL                  tchrist
-utils/h2ph.PL                  kstar
-utils/h2xs.PL  
-utils/perlbug.PL       
-utils/perlcc.PL        
-utils/perldoc.PL       
-utils/pl2pm.PL 
-utils/splain.PL                        doc
-vmesa/*                                vmesa
-vms/*                          vms
-vos/*                          vos
-warning.h                      lexwarn
-warning.pl                     lexwarn
-win32/*
-writemain.SH   
-x2p/EXTERN.h   
-x2p/INTERN.h   
-x2p/Makefile.SH        
-x2p/a2p.c      
-x2p/a2p.h      
-x2p/a2p.pod    
-x2p/a2p.y      
-x2p/a2py.c     
-x2p/cflags.SH  
-x2p/find2perl.PL       
-x2p/hash.c     
-x2p/hash.h     
-x2p/proto.h    
-x2p/s2p.PL     
-x2p/str.c      
-x2p/str.h      
-x2p/util.c     
-x2p/util.h     
-x2p/walk.c     
index dbe97ca..18ae760 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -13,7 +13,6 @@ Copying                       The GNU General Public License
 EXTERN.h               Included before foreign .h files
 INSTALL                        Detailed installation instructions
 INTERN.h               Included before domestic .h files
-MAINTAIN               Who maintains which files
 MANIFEST               This list of files
 Makefile.SH            A script that generates Makefile
 Makefile.micro         microperl Makefile
@@ -32,6 +31,7 @@ Porting/p4desc                Smarter 'p4 describe', outputs diffs for new files
 Porting/patching.pod   How to report changes made to Perl
 Porting/patchls                Flexible patch file listing utility
 Porting/pumpkin.pod    Guidelines and hints for Perl maintainers
+Porting/repository.pod How to use the Perl repository
 README                 The Instructions
 README.Y2K             Notes about Year 2000 concerns
 README.aix             Notes about AIX port
@@ -52,6 +52,7 @@ README.os390          Notes about OS/390 (nee MVS) port
 README.plan9           Notes about Plan9 port
 README.posix-bc                Notes about BS2000 POSIX port
 README.qnx             Notes about QNX port
+README.solaris         Notes about Solaris port
 README.threads         Notes about multithreading
 README.vmesa           Notes about VM/ESA port
 README.vms             Notes about installing the VMS port
@@ -191,10 +192,11 @@ ext/DynaLoader/hints/netbsd.pl    Hint for DynaLoader for named architecture
 ext/DynaLoader/hints/openbsd.pl        Hint for DynaLoader for named architecture
 ext/Encode/Encode.pm           Encode extension
 ext/Encode/Encode.xs           Encode extension
-ext/Encode/Makefile.PL         Encode extension
-ext/Encode/Todo                        Encode extension
+ext/Encode/Encode/EncodeFormat.pod     Encoding table format
 ext/Encode/Encode/ascii.enc    Encoding tables
 ext/Encode/Encode/big5.enc     Encoding tables
+ext/Encode/Encode/cp1006.enc   Encoding tables
+ext/Encode/Encode/cp1047.enc   Encoding tables
 ext/Encode/Encode/cp1250.enc   Encoding tables
 ext/Encode/Encode/cp1251.enc   Encoding tables
 ext/Encode/Encode/cp1252.enc   Encoding tables
@@ -204,12 +206,15 @@ ext/Encode/Encode/cp1255.enc      Encoding tables
 ext/Encode/Encode/cp1256.enc   Encoding tables
 ext/Encode/Encode/cp1257.enc   Encoding tables
 ext/Encode/Encode/cp1258.enc   Encoding tables
+ext/Encode/Encode/cp37.enc     Encoding tables
+ext/Encode/Encode/cp424.enc    Encoding tables
 ext/Encode/Encode/cp437.enc    Encoding tables
 ext/Encode/Encode/cp737.enc    Encoding tables
 ext/Encode/Encode/cp775.enc    Encoding tables
 ext/Encode/Encode/cp850.enc    Encoding tables
 ext/Encode/Encode/cp852.enc    Encoding tables
 ext/Encode/Encode/cp855.enc    Encoding tables
+ext/Encode/Encode/cp856.enc    Encoding tables
 ext/Encode/Encode/cp857.enc    Encoding tables
 ext/Encode/Encode/cp860.enc    Encoding tables
 ext/Encode/Encode/cp861.enc    Encoding tables
@@ -231,10 +236,16 @@ ext/Encode/Encode/euc-kr.enc      Encoding tables
 ext/Encode/Encode/gb12345.enc  Encoding tables
 ext/Encode/Encode/gb1988.enc   Encoding tables
 ext/Encode/Encode/gb2312.enc   Encoding tables
+ext/Encode/Encode/gsm0338.enc          Encoding tables
 ext/Encode/Encode/iso2022-jp.enc       Encoding tables
 ext/Encode/Encode/iso2022-kr.enc       Encoding tables
 ext/Encode/Encode/iso2022.enc          Encoding tables
 ext/Encode/Encode/iso8859-1.enc                Encoding tables
+ext/Encode/Encode/iso8859-10.enc       Encoding tables
+ext/Encode/Encode/iso8859-13.enc       Encoding tables
+ext/Encode/Encode/iso8859-14.enc       Encoding tables
+ext/Encode/Encode/iso8859-15.enc       Encoding tables
+ext/Encode/Encode/iso8859-16.enc       Encoding tables
 ext/Encode/Encode/iso8859-2.enc                Encoding tables
 ext/Encode/Encode/iso8859-3.enc                Encoding tables
 ext/Encode/Encode/iso8859-4.enc                Encoding tables
@@ -260,8 +271,14 @@ ext/Encode/Encode/macRomania.enc   Encoding tables
 ext/Encode/Encode/macThai.enc          Encoding tables
 ext/Encode/Encode/macTurkish.enc       Encoding tables
 ext/Encode/Encode/macUkraine.enc       Encoding tables
+ext/Encode/Encode/posix-bc.enc         Encoding tables
 ext/Encode/Encode/shiftjis.enc         Encoding tables
 ext/Encode/Encode/symbol.enc           Encoding tables
+ext/Encode/Makefile.PL         Encode extension
+ext/Encode/Todo                        Encode extension
+ext/Encode/compile             Encode extension
+ext/Encode/encengine.c         Encode extension
+ext/Encode/encode.h            Encode extension
 ext/Errno/ChangeLog            Errno perl module change log
 ext/Errno/Errno_pm.PL          Errno perl module create script
 ext/Errno/Makefile.PL          Errno extension makefile writer
@@ -275,6 +292,9 @@ ext/File/Glob/Makefile.PL   File::Glob extension makefile writer
 ext/File/Glob/TODO             File::Glob extension todo list
 ext/File/Glob/bsd_glob.c       File::Glob extension run time code
 ext/File/Glob/bsd_glob.h       File::Glob extension header file
+ext/Filter/Util/Call/Call.pm   Filter::Util::Call extension module
+ext/Filter/Util/Call/Call.xs   Filter::Util::Call extension external subroutines
+ext/Filter/Util/Call/Makefile.PL       Filter::Util::Call extension makefile writer
 ext/GDBM_File/GDBM_File.pm     GDBM extension Perl module
 ext/GDBM_File/GDBM_File.xs     GDBM extension external subroutines
 ext/GDBM_File/Makefile.PL      GDBM extension makefile writer
@@ -348,6 +368,7 @@ ext/POSIX/hints/netbsd.pl       Hint for POSIX for named architecture
 ext/POSIX/hints/next_3.pl       Hint for POSIX for named architecture
 ext/POSIX/hints/openbsd.pl     Hint for POSIX for named architecture
 ext/POSIX/hints/sunos_4.pl     Hint for POSIX for named architecture
+ext/POSIX/hints/svr4.pl                Hint for POSIX for named architecture
 ext/POSIX/typemap              POSIX extension interface types
 ext/SDBM_File/Makefile.PL      SDBM extension makefile writer
 ext/SDBM_File/SDBM_File.pm     SDBM extension Perl module
@@ -382,8 +403,8 @@ ext/Socket/Makefile.PL      Socket extension makefile writer
 ext/Socket/Socket.pm   Socket extension Perl module
 ext/Socket/Socket.xs   Socket extension external subroutines
 ext/Storable/ChangeLog         Storable extension
-ext/Storable/Makefile.PL       Storable extension
 ext/Storable/MANIFEST          Storable extension
+ext/Storable/Makefile.PL       Storable extension
 ext/Storable/README            Storable extension
 ext/Storable/Storable.pm       Storable extension
 ext/Storable/Storable.xs       Storable extension
@@ -423,13 +444,14 @@ ext/attrs/Makefile.PL     attrs extension makefile writer
 ext/attrs/attrs.pm     attrs extension Perl module
 ext/attrs/attrs.xs     attrs extension external subroutines
 ext/re/Makefile.PL     re extension makefile writer
+ext/re/hints/aix.pl    Hints for re for named architecture
 ext/re/hints/mpeix.pl  Hints for re for named architecture
 ext/re/re.pm           re extension Perl module
 ext/re/re.xs           re extension external subroutines
 ext/util/make_ext      Used by Makefile to execute extension Makefiles
 ext/util/mkbootstrap   Turns ext/*/*_BS into bootstrap info
+fakesdio.h             stdio in terms of PerlIO
 fakethr.h              Fake threads header
-fix_pl                 Fix up patchlevel.h for repository perls
 form.h                 Public declarations for the above
 global.sym             Symbols that need hiding when embedded
 globals.c              File to declare global symbols (for shared library)
@@ -633,6 +655,7 @@ lib/ExtUtils/Embed.pm       Utilities for embedding Perl in C programs
 lib/ExtUtils/Install.pm        Handles 'make install' on extensions
 lib/ExtUtils/Installed.pm      Information on installed extensions
 lib/ExtUtils/Liblist.pm        Locates libraries
+lib/ExtUtils/MANIFEST.SKIP     The default MANIFEST.SKIP
 lib/ExtUtils/MM_Cygwin.pm      MakeMaker methods for Cygwin
 lib/ExtUtils/MM_OS2.pm         MakeMaker methods for OS/2
 lib/ExtUtils/MM_Unix.pm                MakeMaker base class for Unix
@@ -656,6 +679,7 @@ lib/File/DosGlob.pm Win32 DOS-globbing module
 lib/File/Find.pm       Routines to do a find
 lib/File/Path.pm       Do things like `mkdir -p' and `rm -r'
 lib/File/Spec.pm       portable operations on file names
+lib/File/Spec/Epoc.pm  portable operations on EPOC file names
 lib/File/Spec/Functions.pm     Function interface to File::Spec object methods
 lib/File/Spec/Mac.pm   portable operations on Mac file names
 lib/File/Spec/OS2.pm   portable operations on OS2 file names
@@ -666,6 +690,7 @@ lib/File/Temp.pm    create safe temporary files and file handles
 lib/File/stat.pm       By-name interface to Perl's builtin stat
 lib/FileCache.pm       Keep more files open than the system permits
 lib/FileHandle.pm      Backward-compatible front end to IO extension
+lib/Filter/Simple.pm   Simple frontend to Filter::Util::Call
 lib/FindBin.pm         Find name of currently executing program
 lib/Getopt/Long.pm     Fetch command options (GetOptions)
 lib/Getopt/Std.pm      Fetch command options (getopt, getopts)
@@ -694,6 +719,7 @@ lib/Pod/Plainer.pm  Pod migration utility module
 lib/Pod/Select.pm      Pod-Parser - select portions of POD docs
 lib/Pod/Text.pm                Pod-Parser - convert POD data to formatted ASCII text
 lib/Pod/Text/Color.pm  Convert POD data to color ASCII text
+lib/Pod/Text/Overstrike.pm     Convert POD data to formatted overstrike text
 lib/Pod/Text/Termcap.pm        Convert POD data to ASCII text with format escapes
 lib/Pod/Usage.pm       Pod-Parser - print usage messages
 lib/Search/Dict.pm     Perform binary search on dictionaries
@@ -769,6 +795,7 @@ lib/open2.pl                Open a two-ended pipe (uses IPC::Open2)
 lib/open3.pl           Open a three-ended pipe (uses IPC::Open3)
 lib/overload.pm                Module for overloading perl operators
 lib/perl5db.pl         Perl debugging routines
+lib/perlio.pm          Perl IO interface pragma
 lib/pwd.pl             Routines to keep track of PWD environment variable
 lib/shellwords.pl      Perl library to split into words with shell quoting
 lib/sigtrap.pm         For trapping an abort and giving traceback
@@ -902,6 +929,7 @@ lib/unicode/Is/BidiRLE.pl                   Unicode character database
 lib/unicode/Is/BidiRLO.pl                      Unicode character database
 lib/unicode/Is/BidiS.pl                                Unicode character database
 lib/unicode/Is/BidiWS.pl                       Unicode character database
+lib/unicode/Is/Blank.pl                                Unicode character database
 lib/unicode/Is/C.pl                            Unicode character database
 lib/unicode/Is/Cc.pl                           Unicode character database
 lib/unicode/Is/Cf.pl                           Unicode character database
@@ -914,9 +942,9 @@ lib/unicode/Is/DCcompat.pl                  Unicode character database
 lib/unicode/Is/DCfinal.pl                      Unicode character database
 lib/unicode/Is/DCfont.pl                       Unicode character database
 lib/unicode/Is/DCfraction.pl                   Unicode character database
-lib/unicode/Is/DCinital.pl                     Unicode character database
 lib/unicode/Is/DCinitial.pl                    Unicode character database
 lib/unicode/Is/DCisolated.pl                   Unicode character database
+lib/unicode/Is/DCmedial.pl                     Unicode character database
 lib/unicode/Is/DCnarrow.pl                     Unicode character database
 lib/unicode/Is/DCnoBreak.pl                    Unicode character database
 lib/unicode/Is/DCsmall.pl                      Unicode character database
@@ -990,6 +1018,7 @@ lib/unicode/Is/Sk.pl                               Unicode character database
 lib/unicode/Is/Sm.pl                           Unicode character database
 lib/unicode/Is/So.pl                           Unicode character database
 lib/unicode/Is/Space.pl                                Unicode character database
+lib/unicode/Is/SpacePerl.pl                    Unicode character database
 lib/unicode/Is/SylA.pl                         Unicode character database
 lib/unicode/Is/SylAA.pl                                Unicode character database
 lib/unicode/Is/SylAAI.pl                       Unicode character database
@@ -1043,6 +1072,7 @@ lib/unicode/To/Upper.pl                           Unicode character database
 lib/unicode/UCD301.html                                Unicode character database
 lib/unicode/UCDFF301.html                      Unicode character database
 lib/unicode/Unicode.301                                Unicode character database
+lib/unicode/distinct.pm                Perl pragma to strictly distinguish UTF8 data and non-UTF data
 lib/unicode/mktables.PL                                Unicode character database generator
 lib/unicode/syllables.txt                      Unicode character database
 lib/utf8.pm                                    Pragma to control Unicode support
@@ -1134,8 +1164,9 @@ perl.h                    Global declarations
 perlapi.c              Perl API functions
 perlapi.h              Perl API function declarations
 perlio.c               C code for PerlIO abstraction
-perlio.h               compatibility stub
+perlio.h               PerlIO abstraction
 perlio.sym             Symbols for PerlIO abstraction
+perliol.h              PerlIO Layer definition
 perlsdio.h             Fake stdio using perlio
 perlsfio.h             Prototype sfio mapping for PerlIO
 perlsh                 A poor man's perl shell
@@ -1275,6 +1306,7 @@ sv.h                      Scalar value header
 t/README               Instructions for regression tests
 t/TEST                 The regression tester
 t/UTEST                        Run regression tests with -Mutf8
+t/base/commonsense.t   See if configuration meets basic needs
 t/base/cond.t          See if conditionals work
 t/base/if.t            See if if works
 t/base/lex.t           See if lexical items work
@@ -1314,6 +1346,7 @@ t/io/pipe.t               See if secure pipes work
 t/io/print.t           See if print commands work
 t/io/read.t            See if read works
 t/io/tell.t            See if file seeking works
+t/io/utf8.t            See if file seeking works
 t/lib/abbrev.t         See if Text::Abbrev works
 t/lib/ansicolor.t      See if Term::ANSIColor works
 t/lib/anydbm.t         See if AnyDBM_File works
@@ -1332,6 +1365,7 @@ t/lib/cgi-pretty.t        See if CGI.pm works
 t/lib/cgi-request.t    See if CGI.pm works
 t/lib/charnames.t      See if character names work
 t/lib/checktree.t      See if File::CheckTree works
+t/lib/class-struct.t   See if Class::Struct works
 t/lib/complex.t                See if Math::Complex works
 t/lib/db-btree.t       See if DB_File works
 t/lib/db-hash.t                See if DB_File works
@@ -1354,9 +1388,9 @@ t/lib/dprof/test6_t       Perl code profiler tests
 t/lib/dprof/test6_v    Perl code profiler tests
 t/lib/dumper-ovl.t     See if Data::Dumper works for overloaded data
 t/lib/dumper.t         See if Data::Dumper works
+t/lib/encode.t         See if Encode works
 t/lib/english.t                See if English works
 t/lib/env-array.t      See if Env works for arrays
-t/lib/encode.t         See if Encode works
 t/lib/env.t            See if Env works
 t/lib/errno.t          See if Errno works
 t/lib/fatal.t           See if Fatal works
@@ -1368,6 +1402,8 @@ t/lib/filefunc.t  See if File::Spec::Functions works
 t/lib/filehand.t       See if FileHandle works
 t/lib/filepath.t       See if File::Path works
 t/lib/filespec.t       See if File::Spec works
+t/lib/filter-util.pl   See if Filter::Util::Call works
+t/lib/filter-util.t    See if Filter::Util::Call works
 t/lib/findbin.t                See if FindBin works
 t/lib/ftmp-mktemp.t    See if File::Temp works
 t/lib/ftmp-posix.t     See if File::Temp works
@@ -1403,6 +1439,7 @@ t/lib/io_unix.t           See if UNIX socket-related methods from IO work
 t/lib/io_xs.t          See if XSUB methods from IO work
 t/lib/ipc_sysv.t       See if IPC::SysV works
 t/lib/ndbm.t           See if NDBM_File works
+t/lib/net-hostent.t    See if Net::hostent works
 t/lib/odbm.t           See if ODBM_File works
 t/lib/opcode.t         See if Opcode works
 t/lib/open2.t          See if IPC::Open2 works
@@ -1444,9 +1481,12 @@ t/lib/texttabs.t See if Text::Tabs works
 t/lib/textwrap.t       See if Text::Wrap::wrap works
 t/lib/thr5005.t                Test 5.005-style threading (skipped if no use5005threads)
 t/lib/tie-push.t       Test for Tie::Array
+t/lib/tie-refhash.t    Test for Tie::RefHash and Tie::RefHash::Nestable
+t/lib/tie-splice.t     Test for Tie::Array::SPLICE
 t/lib/tie-stdarray.t   Test for Tie::StdArray
 t/lib/tie-stdhandle.t  Test for Tie::StdHandle
 t/lib/tie-stdpush.t    Test for Tie::StdArray
+t/lib/tie-substrhash.t Test for Tie::SubstrHash
 t/lib/timelocal.t      See if Time::Local works
 t/lib/trig.t           See if Math::Trig works
 t/op/64bitint.t                See if 64 bit integers work
@@ -1464,6 +1504,7 @@ t/op/chars.t              See if character escapes work
 t/op/chop.t            See if chop works
 t/op/closure.t         See if closures work
 t/op/cmp.t             See if the various string and numeric compare work
+t/op/concat.t          See if string concatenation works
 t/op/cond.t            See if conditional expressions work
 t/op/context.t         See if context propagation works
 t/op/defins.t          See if auto-insert of defined() works
@@ -1492,6 +1533,7 @@ t/op/inc.t                See if inc/dec of integers near 32 bit limit work
 t/op/index.t           See if index works
 t/op/int.t             See if int works
 t/op/join.t            See if join works
+t/op/length.t          See if length works
 t/op/lex_assign.t      See if ops involving lexicals or pad temps work
 t/op/lfs.t             See if large files work for perlio
 t/op/list.t            See if array lists work
@@ -1524,6 +1566,7 @@ t/op/regexp.t             See if regular expressions work
 t/op/regexp_noamp.t    See if regular expressions work with optimizations
 t/op/regmesg.t         See if one can get regular expression errors
 t/op/repeat.t          See if x operator works
+t/op/reverse.t         See if reverse operator works
 t/op/runlevel.t                See if die() works from perl_call_*()
 t/op/sleep.t           See if sleep works
 t/op/sort.t            See if sort works
@@ -1546,6 +1589,7 @@ t/op/tr.t         See if tr works
 t/op/undef.t           See if undef works
 t/op/universal.t       See if UNIVERSAL class works
 t/op/unshift.t         See if unshift works
+t/op/utf8decode.t      See if UTF-8 decoding works
 t/op/vec.t             See if vectors work
 t/op/ver.t             See if v-strings and the %v format flag work
 t/op/wantarray.t       See if wantarray works
@@ -1691,10 +1735,13 @@ vms/writemain.pl        Generate perlmain.c from miniperlmain.c+extensions
 vos/Changes            Changes made to port Perl to the VOS operating system
 vos/build.cm           VOS command macro to build Perl
 vos/compile_perl.cm    VOS command macro to build multiple version of Perl
-vos/config.def         input for config.pl
-vos/config.h           config.h for VOS
+vos/config.alpha.def   definitions used by config.pl
+vos/config.alpha.h     config.h for use with alpha VOS POSIX.1 support
+vos/config.ga.def      definitions used by config.pl
+vos/config.ga.h                config.h for use with generally-available VOS POSIX.1 support
 vos/config.pl          script to convert a config_h.SH to a config.h
-vos/config_h.SH_orig   config_h.SH at the time config.h was created
+vos/configure_perl.cm  VOS command macro to configure perl before building
+vos/install_perl.cm    VOS command macro to install perl after building
 vos/perl.bind          VOS bind control file
 vos/test_vos_dummies.c Test program for "vos_dummies.c"
 vos/vos_dummies.c      Wrappers to soak up undefined functions
@@ -1703,6 +1750,7 @@ warnings.h                The warning numbers
 warnings.pl            Program to write warnings.h and lib/warnings.pm
 win32/Makefile         Win32 makefile for NMAKE (Visual C++ build)
 win32/bin/exetype.pl   Set executable type to CONSOLE or WINDOWS
+win32/bin/mdelete.bat  multifile delete
 win32/bin/perlglob.pl  Win32 globbing
 win32/bin/pl2bat.pl    wrap perl scripts into batch files
 win32/bin/runperl.pl   run perl script via batch file namesake
@@ -1716,6 +1764,7 @@ win32/config_H.vc Win32 config header (Visual C++ build)
 win32/config_h.PL      Perl code to convert Win32 config.sh to config.h
 win32/config_sh.PL     Perl code to update Win32 config.sh from Makefile
 win32/des_fcrypt.patch Win32 port
+win32/distclean.bat    Remove _ALL_ files not listed here in MANIFEST
 win32/dl_win32.xs      Win32 port
 win32/genmk95.pl        Perl code to generate command.com-usable makefile.95
 win32/include/arpa/inet.h      Win32 port
index 5418fc4..d0b5465 100644 (file)
@@ -137,6 +137,7 @@ CLDFLAGS = $ldflags
 mallocsrc = $mallocsrc
 mallocobj = $mallocobj
 LNS = $lns
+CPS = $cp -f
 RMS = rm -f
 ranlib = $ranlib
 
@@ -300,9 +301,13 @@ utilities: miniperl lib/Config.pm $(plextract) lib/lib.pm FORCE
 FORCE:
        @sh -c true
 
-opmini$(OBJ_EXT): op.c
+# We do a copy of the op.c instead of a symlink because gcc gets huffy
+# if we have a symlink forest to another disk (it complains about too many
+# levels of symbolic links, even if we have only two)
+
+opmini$(OBJ_EXT): op.c config.h
        $(RMS) opmini.c
-       $(LNS) op.c opmini.c
+       $(CPS) op.c opmini.c
        $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c
        $(RMS) opmini.c
 
@@ -324,14 +329,6 @@ ext.libs: $(static_ext)
 
 !NO!SUBS!
 
-# if test -f .patch ; then $spitshell >>Makefile <<'!NO!SUBS!' 
-# patchlevel.h: .patch
-#      perl fix_pl || (make -f Makefile.micro && ./microperl fix_pl)
-#      $(SHELL) Makefile.SH
-# fi
-# 
-# !NO!SUBS!
-
 # How to build libperl.  This is still rather convoluted.
 # Load up custom Makefile.SH fragment for shared loading and executables:
 case "$osname" in
@@ -600,7 +597,7 @@ install.html: all installhtml
 
 run_byacc:     FORCE
        $(BYACC) -d perly.y
-       -chmod 664 perly.c
+       -chmod 664 perly.c perly.h
        sh $(shellflags) ./perly.fixer y.tab.c perly.c
        sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
            -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c
@@ -618,6 +615,11 @@ perly.c: perly.y
 perly.h: perly.y
        -@sh -c true
 
+PERLYVMS = vms/perly_c.vms vms/perly_h.vms
+
+$(PERLYVMS):   perly.c perly.h vms/vms_yfix.pl
+       perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
+
 # No compat3.sym here since and including the 5.004_50.
 # No interp.sym since 5.005_03.
 SYM  = global.sym globvar.sym perlio.sym pp.sym
@@ -642,6 +644,31 @@ CHMOD_W = chmod +w
 # To force them to be regenerated, type
 #      make regen_headers
 
+keywords.h:    keywords.pl
+       -perl keywords.pl
+
+OPCODE_PL_OUTPUT = opcode.h opnames.h pp_proto.h pp.sym
+
+$(OPCODE_PL_OUTPUT): opcode.pl
+       -perl opcode.pl
+
+# Really the prerequisites for the next rule  should only be "embed.pl pp.sym"
+# Writing it this way gives make a big hint to always run opcode.pl before
+# embed.pl. The alternative - running embed.pl then opcode.pl causes embed.pl
+# to be re-run next make invocation, and then all object files get recompiled.
+
+proto.h embed.h embedvar.h global.sym objXSUB.h perlapi.h perlapi.c pod/perlintern.pod pod/perlapi.pod: embed.pl $(OPCODE_PL_OUTPUT)
+       -perl embed.pl
+
+ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm: bytecode.pl
+       -perl bytecode.pl
+
+regnodes.h:    regcomp.pl
+       -perl regcomp.pl
+
+warnings.h lib/warnings.pm: warnings.pl
+       -perl warnings.pl
+
 AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \
                embed.h embedvar.h global.sym \
                pod/perlintern.pod pod/perlapi.pod \
@@ -661,6 +688,8 @@ regen_headers:      FORCE
 regen_pods:    FORCE
        -cd pod; $(LDLIBPTH) make regen_pods
 
+regen_all: $(PERLYVMS) regen_headers regen_pods
+
 # Extensions:
 # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will
 # automatically get built.  There should ordinarily be no need to change
@@ -734,11 +763,11 @@ _cleaner2:
        rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old
        rm -f $(private)
        rm -rf lib/auto
-       rm -f lib/.exists lib/*/.exists
+       rm -f lib/.exists lib/*/.exists lib/*/*/.exists
        rm -f h2ph.man pstruct
        rm -rf .config
        rm -f testcompile compilelog
-       -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Sys lib/Thread
+       -rmdir lib/B lib/Data lib/Encode lib/IO/Socket lib/IO lib/Filter/Util lib/Sys lib/Thread
 
 _realcleaner: 
        @$(LDLIBPTH) $(MAKE) _cleaner1 CLEAN=realclean
@@ -823,12 +852,24 @@ ok:       utilities
 okfile:        utilities
        $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok
 
+oknack:        utilities
+       $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -A
+
+okfilenack:    utilities
+       $(LDLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok -A
+
 nok:   utilities
        $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)'
 
 nokfile:       utilities
        $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok
 
+noknack:       utilities
+       $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -A
+
+nokfilenack:   utilities
+       $(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok -A
+
 clist: $(c)
        echo $(c) | tr ' ' $(TRNL) >.clist
 
index cc91af2..2b619fd 100644 (file)
@@ -19,7 +19,7 @@ community, mutual respect, trust, and good-faith cooperation.
 
 We recognize that the Perl core, defined as the software distributed with
 the heart of Perl itself, is a joint project on the part of all of us.
->From time to time, a script, module, or set of modules (hereafter referred
+From time to time, a script, module, or set of modules (hereafter referred
 to simply as a "module") will prove so widely useful and/or so integral to
 the correct functioning of Perl itself that it should be distributed with
 Perl core.  This should never be done without the author's explicit
index 1b93821..0095ef1 100644 (file)
@@ -340,6 +340,10 @@ csh (Loc.U):
        full pathname (if any) of the csh program.  After Configure runs,
        the value is reset to a plain "csh" and is not useful.
 
+d__fwalk (d__fwalk.U):
+       This variable conditionally defines HAS__FWALK if _fwalk() is
+       available to apply a function to all the file handles.
+
 d_access (d_access.U):
        This variable conditionally defines HAS_ACCESS if the access() system
        call is available to check for access permissions using real IDs.
@@ -545,6 +549,10 @@ d_fcntl (d_fcntl.U):
        This variable conditionally defines the HAS_FCNTL symbol, and indicates
        whether the fcntl() function exists
 
+d_fcntl_can_lock (d_fcntl_can_lock.U):
+       This variable conditionally defines the FCNTL_CAN_LOCK symbol
+       and indicates whether file locking with fcntl() works.
+
 d_fd_macros (d_fd_set.U):
        This variable contains the eventual value of the HAS_FD_MACROS symbol,
        which indicates if your C compiler knows about the macros which
@@ -610,6 +618,10 @@ d_fstatvfs (d_statvfs.U):
        This variable conditionally defines the HAS_FSTATVFS symbol, which
        indicates to the C program that the fstatvfs() routine is available.
 
+d_fsync (d_fsync.U):
+       This variable conditionally defines the HAS_FSYNC symbol, which
+       indicates to the C program that the fsync() routine is available.
+
 d_ftello (d_ftello.U):
        This variable conditionally defines the HAS_FTELLO symbol, which
        indicates to the C program that the ftello() routine is available.
@@ -711,6 +723,10 @@ d_getnetprotos (d_getnetprotos.U):
        prototypes for the various getnet*() functions.  
        See also netdbtype.U for probing for various netdb types.
 
+d_getpagsz (d_getpagsz.U):
+       This variable conditionally defines HAS_GETPAGESIZE if getpagesize()
+       is available to get the system page size.
+
 d_getpbyname (d_getprotby.U):
        This variable conditionally defines the HAS_GETPROTOBYNAME 
        symbol, which indicates to the C program that the 
@@ -1235,6 +1251,12 @@ d_sanemcmp (d_sanemcmp.U):
        the memcpy() routine is available and can be used to compare relative
        magnitudes of chars with their high bits set.
 
+d_sbrkproto (d_sbrkproto.U):
+       This variable conditionally defines the HAS_SBRK_PROTO symbol,
+       which indicates to the C program that the system provides
+       a prototype for the sbrk() function.  Otherwise, it is
+       up to the program to supply one.
+
 d_sched_yield (d_pthread_y.U):
        This variable conditionally defines the HAS_SCHED_YIELD
        symbol if the sched_yield routine is available to yield
@@ -1478,6 +1500,15 @@ d_stdio_ptr_lval (d_stdstdio.U):
        This variable conditionally defines STDIO_PTR_LVALUE if the
        FILE_ptr macro can be used as an lvalue.
 
+d_stdio_ptr_lval_nochange_cnt (d_stdstdio.U):
+       This symbol is defined if using the FILE_ptr macro as an lvalue
+       to increase the pointer by n leaves File_cnt(fp) unchanged.
+
+d_stdio_ptr_lval_sets_cnt (d_stdstdio.U):
+       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.
+
 d_stdio_stream_array (stdio_streams.U):
        This variable tells whether there is an array holding
        the stdio streams.
@@ -1533,6 +1564,10 @@ d_strtoll (d_strtoll.U):
        This variable conditionally defines the HAS_STRTOLL symbol, which
        indicates to the C program that the strtoll() routine is available.
 
+d_strtoq (d_strtoq.U):
+       This variable conditionally defines the HAS_STRTOQ symbol, which
+       indicates to the C program that the strtoq() routine is available.
+
 d_strtoul (d_strtoul.U):
        This variable conditionally defines the HAS_STRTOUL symbol, which
        indicates to the C program that the strtoul() routine is available
@@ -2408,6 +2443,11 @@ intsize (intsize.U):
        This variable contains the value of the INTSIZE symbol, which
        indicates to the C program how many bytes there are in an int.
 
+issymlink (issymlink.U):
+       This variable holds the switch of the test command to test
+       for a symbolic link (if they are supported).  Typical values
+       include '-h' and '-L'.
+
 ivdformat (perlxvf.U):
        This variable contains the format string used for printing
        a Perl IV as a signed decimal integer. 
@@ -2709,6 +2749,15 @@ n (n.U):
        command to suppress newline.  Otherwise it is null.  Correct usage is
        $echo $n "prompt for a question: $c".
 
+need_va_copy (need_va_copy.U):
+       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.
+
 netdb_hlen_type (netdbtype.U):
        This variable holds the type used for the 2nd argument to
        gethostbyaddr().  Usually, this is int or size_t or unsigned.
index 632c469..90e7dc5 100644 (file)
@@ -8,7 +8,7 @@
 
 # Package name      : perl5
 # Source directory  : /m/fs/work/work/permanent/perl/pp4/perl
-# Configuration time: Fri Oct 13 02:12:22 EET DST 2000
+# Configuration time: Thu Dec 21 18:13:27 EET 2000
 # Configured by     : jhi
 # Target system     : osf1 alpha.hut.fi v4.0 878 alpha 
 
@@ -62,7 +62,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_
 ccversion='V5.6-082'
 cf_by='jhi'
 cf_email='yourname@yourhost.yourplace.com'
-cf_time='Fri Oct 13 02:12:22 EET DST 2000'
+cf_time='Thu Dec 21 18:13:27 EET 2000'
 charsize='1'
 chgrp=''
 chmod=''
@@ -99,6 +99,7 @@ d_PRIo64='define'
 d_PRIu64='define'
 d_PRIx64='define'
 d_SCNfldbl='define'
+d__fwalk='undef'
 d_access='define'
 d_accessx='undef'
 d_alarm='define'
@@ -145,6 +146,7 @@ d_eunice='undef'
 d_fchmod='define'
 d_fchown='define'
 d_fcntl='define'
+d_fcntl_can_lock='define'
 d_fd_macros='define'
 d_fd_set='define'
 d_fds_bits='define'
@@ -160,6 +162,7 @@ d_fseeko='undef'
 d_fsetpos='define'
 d_fstatfs='define'
 d_fstatvfs='define'
+d_fsync='define'
 d_ftello='undef'
 d_ftime='undef'
 d_getcwd='define'
@@ -179,6 +182,7 @@ d_getnbyaddr='define'
 d_getnbyname='define'
 d_getnent='define'
 d_getnetprotos='define'
+d_getpagsz='define'
 d_getpbyname='define'
 d_getpbynumber='define'
 d_getpent='define'
@@ -282,6 +286,7 @@ d_rmdir='define'
 d_safebcpy='define'
 d_safemcpy='undef'
 d_sanemcmp='define'
+d_sbrkproto='define'
 d_sched_yield='define'
 d_scm_rights='define'
 d_seekdir='define'
@@ -336,6 +341,8 @@ d_statfs_s='define'
 d_statvfs='define'
 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='define'
 d_stdiobase='define'
 d_stdstdio='define'
@@ -348,6 +355,7 @@ d_strtod='define'
 d_strtol='define'
 d_strtold='undef'
 d_strtoll='undef'
+d_strtoq='undef'
 d_strtoul='define'
 d_strtoull='undef'
 d_strtouq='undef'
@@ -394,7 +402,7 @@ dlext='so'
 dlsrc='dl_dlopen.xs'
 doublesize='8'
 drand01='drand48()'
-dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re'
+dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re'
 eagain='EAGAIN'
 ebcdic='undef'
 echo='echo'
@@ -403,7 +411,7 @@ emacs=''
 eunicefix=':'
 exe_ext=''
 expr='expr'
-extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno'
+extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re Errno'
 fflushNULL='define'
 fflushall='undef'
 find=''
@@ -539,10 +547,11 @@ installvendorarch=''
 installvendorbin=''
 installvendorlib=''
 intsize='4'
+issymlink='-h'
 ivdformat='"ld"'
 ivsize='8'
 ivtype='long'
-known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re'
+known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Encode Fcntl File/Glob Filter/Util/Call GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread attrs re'
 ksh=''
 ld='ld'
 lddlflags='-shared -expect_unresolved "*" -msym -std -s'
@@ -601,6 +610,7 @@ mydomain='.yourplace.com'
 myhostname='yourhost'
 myuname='osf1 alpha.hut.fi v4.0 878 alpha '
 n=''
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='const char *'
 netdb_name_type='const char *'
index 149760c..039ed25 100644 (file)
@@ -17,7 +17,7 @@
 /*
  * Package name      : perl5
  * Source directory  : /m/fs/work/work/permanent/perl/pp4/perl
- * Configuration time: Fri Oct 13 02:12:22 EET DST 2000
+ * Configuration time: Thu Dec 21 18:13:27 EET 2000
  * Configured by     : jhi
  * Target system     : osf1 alpha.hut.fi v4.0 878 alpha 
  */
  */
 #define HAS_STRTOL     /**/
 
-/* 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_STRXFRM:
  *     This symbol, if defined, indicates that the strxfrm() routine is
  *     available to transform strings.
  */
 #define SH_PATH "/bin/sh"  /**/
 
-/* 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 unsigned char  /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
 #define CPPRUN "/usr/bin/cpp"
 #define CPPLAST ""
 
+/* 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_ACCESS:
  *     This manifest constant lets the C program know that the access()
  *     system call is available to check for accessibility using real UID/GID.
  */
 #define HAS_ENDSERVENT         /**/
 
+/* 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_FD_SET:
  *     This symbol, when defined, indicates presence of the fd_set typedef
  *     in <sys/types.h>
  */
 #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_GETNET_PROTOS       /**/
 
+/* 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_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.
  */
 #define HAS_SANE_MEMCMP        /**/
 
+/* 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_SEM:
  *     This symbol, if defined, indicates that the entire sem*(2) library is
  *     supported.
  */
 #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_SETPROCTITLE:
  *     This symbol, if defined, indicates that the setproctitle routine is
  *     available to set process title.
  *     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:
  */
 /*#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_STRTOUL:
+ *     This symbol, if defined, indicates that the strtoul routine is
+ *     available to provide conversion of strings to unsigned long.
+ */
+#define HAS_STRTOUL    /**/
+
 /* HAS_STRTOULL:
  *     This symbol, if defined, indicates that the strtoull routine is
  *     available to convert strings to unsigned long longs.
 #define RD_NODATA -1
 #define EOF_NONBLOCK
 
+/* 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            / **/
+
 /* Netdb_host_t:
  *     This symbol holds the type used for the 1st argument
  *     to gethostbyaddr().
  */
 #define STARTPERL "#!/opt/perl/bin/perl"               /**/
 
+/* 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 unsigned char  /**/
+
 /* HAS_STDIO_STREAM_ARRAY:
  *     This symbol, if defined, tells that there is an array
  *     holding the stdio streams.
 #define PERL_XS_APIVERSION "5.7.0"
 #define PERL_PM_APIVERSION "5.005"
 
-/* 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_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        /**/
-
 #endif
index 218da41..627ba31 100755 (executable)
@@ -73,6 +73,7 @@ else {
     while (@desc) {
        my ($change,$who,$date,$time,@log,$branch,$file,$type,%files);
        my $skip = 0;
+        my $nbranch = 0;
        $_ = shift @desc;
        if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) {
            ($change, $who, $date, $time) = ($1,$2,$3,$4);
@@ -88,6 +89,7 @@ else {
                    last unless /^\.\.\./;
                    if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) {
                        ($branch,$file,$type) = ($1,$2,$3);
+                       $nbranch++;
                        if (exists $branch_exclude{$branch} or
                            @branch_include and
                            not exists $branch_include{$branch}) {
@@ -103,7 +105,7 @@ else {
                }
            }
        }
-       next if not $change or $skip;
+       next if not $change;
        print "_" x 76, "\n";
        printf <<EOT, $change, $who, $date, $time;
 [%6s] By: %-25s             on %9s %9s
index d761059..3bc9d09 100644 (file)
@@ -58,7 +58,7 @@ and 1 is the subversion.
 
 For compatibility with the older numbering scheme the composite floating
 point version number continues to be available as the magic variable $],
-and amounts to C<$revision + $version/1000 + $subversion/1000000>.  This
+and amounts to C<$revision + $version/1000 + $subversion/100000>.  This
 can still be used in comparisons.
 
        print "You've got an old perl\n" if $] < 5.005_03;
@@ -210,7 +210,7 @@ unset appropriate Configure variables, based on the Configure command
 line options and possibly existing config.sh and Policy.sh files from
 previous Configure runs.
 
-The extension hints are written Perl (by the time they are used
+The extension hints are written in Perl (by the time they are used
 miniperl has been built) and control the building of their respective
 extensions.  They can be used to for example manipulate compilation
 and linking flags.
@@ -252,7 +252,8 @@ the first B<not> to have a system call also update the list of
 A file called F<README.youros> at the top level that explains things
 like how to install perl at this platform, where to get any possibly
 required additional software, and for example what test suite errors
-to expect, is nice too.
+to expect, is nice too.  Such files are in the process of being written
+in pod format and will eventually be renamed F<INSTALL.youros>.
 
 You may also want to write a separate F<.pod> file for your operating
 system to tell about existing mailing lists, os-specific modules,
@@ -449,7 +450,9 @@ safely be sorted, so it's easy to track (typically very small) changes
 to config.sh and then propoagate them to a canned 'config.h' by any
 number of means, including a perl script in win32/ or carrying 
 config.sh and config_h.SH to a Unix system and running sh
-config_h.SH.)
+config_h.SH.)  Vms uses configure.com to generate its own config.sh
+and config.h.  If you want to add a new variable to config.sh check
+with vms folk how to add it to configure.com too.
 XXX]
 
 The Porting/config.sh and Porting/config_H files are provided to
@@ -460,7 +463,7 @@ distinguish the file from config.h even on case-insensitive file systems.)
 Simply edit the existing config_H file; keep the first few explanatory
 lines and then copy your new config.h below.
 
-It may also be necessary to update win32/config.?c, vms/config.vms and
+It may also be necessary to update win32/config.?c, and
 plan9/config.plan9, though you should be quite careful in doing so if
 you are not familiar with those systems.  You might want to issue your
 patch with a promise to quickly issue a follow-up that handles those
@@ -481,8 +484,10 @@ output statements mean the patch won't apply cleanly.  Long ago I
 started to fix F<perly.fixer> to detect this, but I never completed the
 task.
 
-If C<perly.c> changes, make sure you run C<perl vms/vms_yfix.pl> to
-update the corresponding VMS files.  See L<VMS-specific updates>.
+If C<perly.c> or C<perly.h> changes, make sure you run C<perl vms/vms_yfix.pl> 
+to update the corresponding VMS files.  This could be taken care of by 
+the regen_all target in the Unix Makefile.  See also 
+L<VMS-specific updates>.
 
 Some additional notes from Larry on this:
 
@@ -507,6 +512,11 @@ could be automated, but it doesn't happen very often nowadays.
 
 Larry
 
+=head2 make regen_all
+
+This target takes care of the PERLYVMS, regen_headers, and regen_pods
+targets.
+
 =head2 make regen_headers
 
 The F<embed.h>, F<keywords.h>, and F<opcode.h> files are all automatically
@@ -532,6 +542,10 @@ and effort by manually running C<make regen_headers> myself rather
 than answering all the questions and complaints about the failing
 command.
 
+=head2 make regen_pods
+
+Will run `make regen_pods` in the pod directory for indexing. 
+
 =head2 global.sym, interp.sym and perlio.sym
 
 Make sure these files are up-to-date.  Read the comments in these
@@ -541,7 +555,7 @@ files and in perl_exp.SH to see what to do.
 
 If you do change F<global.sym> or F<interp.sym>, think carefully about
 what you are doing.  To the extent reasonable, we'd like to maintain
-souce and binary compatibility with older releases of perl.  That way,
+source and binary compatibility with older releases of perl.  That way,
 extensions built under one version of perl will continue to work with
 new versions of perl.
 
@@ -594,11 +608,11 @@ things that need to be fixed in Configure.
 =head2 VMS-specific updates
 
 If you have changed F<perly.y> or F<perly.c>, then you most probably want
-to update F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>.
+to update F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>, or
+by running `make regen_all` which will run that script for you.
 
-The Perl version number appears in several places under F<vms>.
-It is courteous to update these versions.  For example, if you are
-making 5.004_42, replace "5.00441" with "5.00442".
+The Perl revision number appears as "perl5" in configure.com.
+It is courteous to update that if necessary.
 
 =head2 Making the new distribution
 
@@ -1353,7 +1367,8 @@ have good reason to do otherwise, I see no reason not to support them.
 =item File locking
 
 Somehow, straighten out, document, and implement lockf(), flock(),
-and/or fcntl() file locking.  It's a mess.
+and/or fcntl() file locking.  It's a mess.  See $d_fcntl_can_lock
+in recent config.sh files though.
 
 =back
 
diff --git a/Porting/repository.pod b/Porting/repository.pod
new file mode 100644 (file)
index 0000000..5f1338d
--- /dev/null
@@ -0,0 +1,327 @@
+=head1 NAME
+
+repository - Using the Perl repository
+
+This document describes what a Perl Porter needs to do
+to start using the Perl repository.
+
+=head1 Prerequisites
+
+You'll need to get hold of the following software.
+
+=over 4
+
+=item Perforce
+
+Download a perforce client from:
+
+   http://www.perforce.com/perforce/loadprog.html
+
+You'll probably also want to look at:
+
+   http://www.perforce.com/perforce/technical.html
+
+where you can look at or download its documentation.
+
+=item ssh
+
+If you don't already have access to an ssh client, then look at its
+home site C<http://www.cs.hut.fi/ssh> which mentions ftp sites from
+which it's available. You only need to build the client parts (ssh
+and ssh-keygen should suffice).
+
+=back
+
+=head1 Creating an SSH Key Pair
+
+If you already use ssh and want to use the same key pair for perl
+repository access then you can skip the rest of this section.
+Otherwise, generate an ssh key pair for use with the repository
+by typing the command
+
+    ssh-keygen
+
+After generating a key pair and testing it, ssh-keygen will ask you
+to enter a filename in which to save the key. The default it offers
+will be the file F<~/.ssh/identity> which is suitable unless you
+particularly want to keep separate ssh identities for some reason.
+If so, you could save the perl repository private key in the file
+F<~/.ssh/perl>, for example, but I will use the standard filename
+in the remainder of the examples of this document.
+
+After typing in the filename, it will prompt you to type in a
+passphrase. The private key will itself be encrypted so that it is
+usable only when that passphrase is typed. (When using ssh, you will
+be prompted when it requires a pass phrase to unlock a private key.)
+If you provide a blank passphrase then no passphrase will be needed
+to unlock the key and, as a consequence, anyone who gains access to
+the key file gains access to accounts protected with that key
+(barring additional configuration to restrict access by IP address).
+
+When you have typed the passphrase in twice, ssh-keygen will confirm
+where it has saved the private key (in the filename you gave and
+with permissions set to be only readable by you), what your public
+key is (don't worry: you don't need to memorise it) and where it
+has saved the corresponding public key. The public key is saved in
+a filename corresponding to your private key's filename but with
+".pub" appended, usually F<~/.ssh/identity.pub>. That public key
+can be (but need not be) world readable. It is not used by your
+own system at all.
+
+=head1 Notifying the Repository Keeper
+
+Mail the contents of that public key file to the keeper of the perl
+repository (see L</Contact Information> below).
+When the key is added to the repository host's configuration file,
+you will be able to connect to it with ssh by using the corresponding
+private key file (after unlocking it with your chosen passphrase).
+
+=head1 Connecting to the Repository
+
+Connections to the repository are made by using ssh to provide a
+TCP "tunnel" rather than by using ssh to login to or invoke any
+ordinary commands on the repository. When you want to start a
+session using the repository, use the command
+
+    ssh -l perlrep -f -q -x -L 1666:127.0.0.1:1666 sickle.activestate.com 
+foo
+
+If you are not using the default filename of F<~/.ssh/identity>
+to hold your perl repository private key then you'll need to add
+the option B<-i filename> to tell ssh where it is. Unless you chose
+a blank passphrase for that private key, ssh will prompt you for the
+passphrase to unlock that key. Then ssh will fork and put itself
+in the background, returning you (silently) to your shell prompt.
+The tunnel for repository access is now ready for use.
+
+For the sake of completeness (and for the case where the chosen
+port of 1666 is already in use on your machine), I'll briefly
+describe what all those ssh arguments are for.
+
+=over 4
+
+=item B<-l perl>
+
+Use a remote username of perl. The account on the repository which
+provides the end-point of the ssh tunnel is named "perl".
+
+=item B<-f>
+
+Tells ssh to fork and remain running in the background. Since ssh
+is only being used for its tunnelling capabilities, the command
+that ssh runs never does any I/O and can sit silently in the
+background.
+
+=item B<-q>
+
+Tells ssh to be quiet. Without this option, ssh will output a
+message each time you use a p4 command (since each p4 command
+tunnels over the ssh connection to reach the repository).
+
+=item B<-x>
+
+Tells ssh not to bother to set up a tunnel for X11 connections.
+The repository doesn't allow this anyway.
+
+=item B<-L 1666:127.0.0.1:1666>
+
+This is the important option. It tells ssh to listen out for
+connections made to port 1666 on your local machine. When such
+a connection is made, the ssh client tells the remote side
+(the corresponding ssh daemon on the repository) to make a
+connection to IP address 127.0.0.1, port 1666. Data flowing
+along that connection is tunnelled over the ssh connection
+(encrypted). The perforce daemon running on the repository
+only accepts connections from localhost and that is exactly
+where ssh-tunnelled connections appear to come from.
+
+If port 1666 is already in use on your machine then you can
+choose any non-privileged port (a number between 1024 and 65535)
+which happens to be free on your machine. It's the first of the
+three colon separated values that you should change. Picking
+port 2345 would mean changing the option to
+B<-L 2345:127.0.0.1:1666>. Whatever port number you choose should
+be used for the value of the P4PORT environment variable (q.v.).
+
+=item sickle.activestate.com
+
+This is the canonical IP name of the host on which the perl
+repository runs. Its IP number is 199.60.48.20.
+
+=item foo
+
+This is a dummy place holder argument. Without an argument
+here, ssh will try to perform an interactive login to the
+repository which is not allowed. Ordinarily, this argument
+is for the one-off command which is to be executed on the
+remote host. However, the repository's ssh configuration
+file uses the "command=" option to force a particular
+command to run so the actual value of the argument is
+ignored. The command that's actually run merely pauses and
+waits for the ssh connection to drop, then exits.
+
+=back
+
+=head1 Problems
+
+You should normally get a prompt that asks for the passphrase
+for your RSA key when you connect with the ssh command shown
+above.  If you see a prompt that looks like:
+
+    perlrep@sickle.activestate.com's password:
+
+Then you either don't have a ~/.ssh/identity file corresponding
+to your public key, or your ~/.ssh/identity file is not readable.
+Fix the problem and try again.
+
+=head1 Using the Perforce Client
+
+Remember to read the documentation for Perforce. You need
+to make sure that three environment variable are set
+correctly before using the p4 client with the perl repository.
+
+=over 4
+
+=item P4PORT
+
+Set this to localhost:1666 (the port for your ssh client to listen on)
+unless that port is already in use on your host. If it is, see
+the section above on the B<-L 1666:127.0.0.1:1666> option to ssh.
+
+=item P4CLIENT
+
+The value of this is the name by which Perforce knows your
+host's workspace. You need to pick a name (for example, your
+hostname unless that clashes with someone else's client name)
+when you first start using the perl repository and then
+stick with it. If you connect from multiple hosts (with
+different workspaces) then maybe you could have multiple
+clients. There is a licence limit on the number of perforce
+clients which can be created. Although we have been told that
+Perforce will raise our licence limits within reason, it's
+probably best not to use additional clients unless needed.
+
+Note that perforce only needs the client name so that it can
+find the directory under which your client files are stored.
+If you have multiple hosts sharing the same directory structure
+via NFS then only one client name is necessary.
+
+The C<p4 clients> command lists all currently known clients.
+
+=item P4USER
+
+This is the username by which perforce knows you. Use your
+username if you have a well known or obvious one or else pick
+a new one which other perl5-porters will recognise. There is
+a licence limit on the number of these usernames. Perforce
+doesn't enforce security between usernames. If you set P4USER
+to be somebody else's username then perforce will believe you
+completely with regard to access control, logging and so on.
+
+The C<p4 users> command lists all currently known users.
+
+=back
+
+Once these three environment variables are set, you can use the
+perforce p4 client exactly as described in its documentation.
+After setting these variables and connecting to the repository
+for the first time, you should use the C<p4 user> and
+C<p4 client> commands to tell perforce the details of your
+new username and your new client workspace specifications.
+
+=head1 Ending a Repository Session
+
+When you have finished a session using the repository, you
+should kill off the ssh client process to break the tunnel.
+Since ssh forked itself into the background, you'll need to use
+something like ps with the appropriate options to find the ssh
+process and then kill it manually. The default signal of
+SIGTERM is fine.
+
+=head1 Overview of the Repository
+
+Please read at least the introductory sections of the Perforce
+User Guide (and perhaps the Quick Start Guide as well) before
+reading this section.
+
+Every repository user typically "owns" a "branch" of the mainline
+code in the repository.  They hold the "pumpkin" for things in this
+area, and are usually the only user who will modify files there.
+This is not strictly enforced in order to allow the flexibility
+of other users stealing the pumpkin for short periods with the
+owner's permission.
+
+Here is the current structure of the repository:
+
+    /----+-----perl                  - Mainline development (bleadperl)
+         +-----cfgperl               - Configure Pumpkin's Perl
+         +-----vmsperl               - VMS Pumpkin's Perl
+         +-----maint-5.004------perl - Maintainance branches
+         +-----maint-5.005------perl
+         +-----maint-5.6------perl
+
+Perforce uses a branching model that simply tracks relationships
+between files.  It does not care about directories at all, so
+any file can be a branch of any other file--the fully qualified
+depot path name (of the form //depot/foo/bar.c) uniquely determines
+a file for the purpose of establishing branching relationships.
+Since a branch usually involves hundreds of files, such relationships
+are typically specified en masse using a branch map (try `p4 help branch`).
+`p4 branches` lists the existing branches that have been set up.
+`p4 branch -o branchname` can be used to view the map for a particular
+branch, if you want to determine the ancestor for a particular set of
+files.
+
+The mainline (aka "trunk") code in the Perl repository is under
+"//depot/perl/...".  Most branches typically map its entire
+contents under a directory that goes by the same name as the branch
+name.  Thus the contents of the cfgperl branch are to be found
+in //depot/cfgperl.
+
+Run `p4 client` to specify how the repository contents should map to
+your local disk.  Most users will typically have a client map that
+includes at least their entire branch and the contents of the mainline.
+
+Run `p4 changes -l -m10` to check on the activity in the repository.
+//depot/perl/Porting/genlog is useful to get an annotated changelog
+that shows files and branches.  You can use this listing to determine
+if there are any changes in the mainline that you need to merge into
+your own branch.  A typical merging session looks like this:
+
+    % cd ~/p4view/cfgperl
+    % p4 integrate -b cfgperl    # to bring parent changes into cfgperl
+    % p4 resolve -a ./...        # auto merge the changes
+    % p4 resolve ./...           # manual merge conflicting changes
+    % p4 submit ./...            # check in
+
+If the owner of the mainline wants to bring the changes in cfgperl
+back into the mainline, they do:
+
+    % p4 integrate -r -b cfgperl
+    ...
+
+Generating a patch for change#42 is done as follows:
+
+    % p4 describe -du 42 | p4desc | p4d2p > change-42.patch
+
+p4desc and p4d2p are to be found in //depot/perl/Porting/.
+
+=head1 Contact Information
+
+The mail alias <perl-repository-keepers@perl.org> can be used to reach
+all current users of the repository.
+
+The repository keeper is currently Gurusamy Sarathy
+<gsar@activestate.com>.
+
+=head1 AUTHORS
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk, 24 June 1997.
+
+Gurusamy Sarathy, gsar@activestate.com, 8 May 1999.
+
+Slightly updated by Simon Cozens, simon@brecon.co.uk, 3 July 2000
+
+=cut
+
+
diff --git a/README b/README
index b828893..28c5de8 100644 (file)
--- a/README
+++ b/README
@@ -1,7 +1,7 @@
 
                           Perl Kit, Version 5.0
 
-                      Copyright 1989-2000, Larry Wall
+                      Copyright 1989-2001, Larry Wall
                            All rights reserved.
 
     This program is free software; you can redistribute it and/or modify
index 6346a18..bf83535 100644 (file)
@@ -8,13 +8,13 @@ README.aix - Perl version 5 on IBM Unix (AIX) systems
 
 =head1 DESCRIPTION
 
-This document describes various features of IBM's Unix operating system
-(AIX) that will affect how Perl version 5 (hereafter just Perl) is
-compiled and/or runs.
+This document describes various features of IBM's Unix operating
+system (AIX) that will affect how Perl version 5 (hereafter just Perl)
+is compiled and/or runs.
 
 =head2 Compiling Perl 5 on AIX
 
-When compiling Perl, you must use an ANSI C compiler. AIX does not shif
+When compiling Perl, you must use an ANSI C compiler. AIX does not ship
 an ANSI compliant C-compiler with AIX by default, but binary builds of
 gcc for AIX are widely available.
 
@@ -26,8 +26,8 @@ upgrade to the latest available patch level. Currently:
     xlC.C     3.1.4.0
     vac.C     4.4.0.3  (5.0 is already available)
 
-Perl can be compiled with either IBM's ANSI C compiler or with gcc.  The
-former is recommended, as not only can it compile Perl with no
+Perl can be compiled with either IBM's ANSI C compiler or with gcc.
+The former is recommended, as not only can it compile Perl with no
 difficulty, but also can take advantage of features listed later that
 require the use of IBM compiler-specific command-line flags.
 
@@ -39,7 +39,7 @@ details.
 
 Before installing the patches to the IBM C-compiler you need to know the
 level of patching for the Operating System. IBM's command 'oslevel' will
-show the base, but is not allways complete:
+show the base, but is not always complete:
 
     # oslevel
     4.3.0.0
@@ -52,7 +52,7 @@ show the base, but is not allways complete:
 
 AIX supports dynamically loadable libraries (shared libraries).
 Shared libraries end with the suffix .a, which is a bit misleading,
-cause *all* libraries are shared ;-).
+because *all* libraries are shared ;-).
 
 =head2 The IBM ANSI C Compiler
 
@@ -61,12 +61,86 @@ All defaults for Configure can be used.
 If you've chosen to use vac 4, be sure to run 4.4.0.3. Older versions
 will turn up nasty later on.
 
+Here's a brief lead of how to upgrade the compiler to the latest
+level.  Of course this is subject to changes.  You can only upgrade
+versions from ftp-available updates if the first three digit groups
+are the same (in where you can skip intermediate unlike the patches
+in the developer snapshots of perl), or to one version up where the
+`base' is available.  In other words, the AIX compiler patches are
+cumulative.
+
+ vac.C.4.4.0.1 => vac.C.4.4.0.3  is OK     (vac.C.4.4.0.2 not needed)
+ xlC.C.3.1.3.3 => xlC.C.3.1.4.10 is NOT OK (xlC.C.3.1.4.0 is not available)
+
+ # ftp ftp.software.ibm.com
+ Connected to service.boulder.ibm.com.
+ : welcome message ...
+ Name (ftp.software.ibm.com:merijn): anonymous
+ 331 Guest login ok, send your complete e-mail address as password.
+ Password:
+ ... accepted login stuff
+ ftp> cd /aix/fixes/v4/
+ ftp> dir other other.ll
+ output to local-file: other.ll? y
+ 200 PORT command successful.
+ 150 Opening ASCII mode data connection for /bin/ls.
+ 226 Transfer complete.
+ ftp> dir xlc xlc.ll
+ output to local-file: xlc.ll? y
+ 200 PORT command successful.
+ 150 Opening ASCII mode data connection for /bin/ls.
+ 226 Transfer complete.
+ ftp> bye
+ ... goodbye messages
+ # ls -l *.ll
+ -rw-rw-rw-   1 merijn   system    1169432 Nov  2 17:29 other.ll
+ -rw-rw-rw-   1 merijn   system      29170 Nov  2 17:29 xlc.ll
+
+On AIX 4.2 using xlC, we continue:
+
+ # lslpp -l | fgrep 'xlC.C '
+   xlC.C                     3.1.4.9  COMMITTED  C for AIX Compiler
+   xlC.C                     3.1.4.0  COMMITTED  C for AIX Compiler
+ # grep 'xlC.C.3.1.4.*.bff' xlc.ll
+ -rw-r--r--   1 45776101 1        6286336 Jul 22 1996  xlC.C.3.1.4.1.bff
+ -rw-rw-r--   1 45776101 1        6173696 Aug 24 1998  xlC.C.3.1.4.10.bff
+ -rw-r--r--   1 45776101 1        6319104 Aug 14 1996  xlC.C.3.1.4.2.bff
+ -rw-r--r--   1 45776101 1        6316032 Oct 21 1996  xlC.C.3.1.4.3.bff
+ -rw-r--r--   1 45776101 1        6315008 Dec 20 1996  xlC.C.3.1.4.4.bff
+ -rw-rw-r--   1 45776101 1        6178816 Mar 28 1997  xlC.C.3.1.4.5.bff
+ -rw-rw-r--   1 45776101 1        6188032 May 22 1997  xlC.C.3.1.4.6.bff
+ -rw-rw-r--   1 45776101 1        6191104 Sep  5 1997  xlC.C.3.1.4.7.bff
+ -rw-rw-r--   1 45776101 1        6185984 Jan 13 1998  xlC.C.3.1.4.8.bff
+ -rw-rw-r--   1 45776101 1        6169600 May 27 1998  xlC.C.3.1.4.9.bff
+ # wget ftp://ftp.software.ibm.com/aix/fixes/v4/xlc/xlC.C.3.1.4.10.bff
+ #
+
+On AIX 4.3 using vac, we continue:
+
+ # lslpp -l | fgrep 'vac.C '
+   vac.C                      4.4.0.2  COMMITTED  C for AIX Compiler
+   vac.C                      4.4.0.0  COMMITTED  C for AIX Compiler
+ # grep 'vac.C.4.4.0.*.bff' other.ll
+ -rw-rw-r--   1 45776101 1        13466624 May 26 1999  vac.C.4.4.0.1.bff
+ -rw-rw-r--   1 45776101 1        13473792 Aug 31 1999  vac.C.4.4.0.2.bff
+ -rw-rw-r--   1 45776101 1        13480960 May 19 20:32 vac.C.4.4.0.3.bff
+ # wget ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.4.4.0.3.bff
+ #
+
+Then execute the following command, and fill in its choices
+
+ # smit install_update
+  -> Install and Update from LATEST Available Software
+  * INPUT device / directory for software [ vac.C.4.4.0.3.bff    ]
+  [ OK ]
+  [ OK ]
+
+Follow the messages ... and you're done.
+
 =head2 Using GNU's gcc for building perl
 
 ... ?
 
-Wait, I'll have to scan perlbug ...
-
 =head2 Using Large Files with Perl
 
 ... ?
index 8951f35..3b2a1bd 100644 (file)
@@ -4,18 +4,10 @@ specially designed to be readable as is.
 
 =head1 NAME
 
-perlamiga - Perl under Amiga OS (possibly very outdated information)
+perlamiga - Perl under Amiga OS
 
 =head1 SYNOPSIS
 
-NOTE: No one has reported building Perl on the Amiga in a long
-time.  The following information is highly unlikely to be correct.
-If you would like to help the Amiga port to stay current, see:
-
-    http://us.aminet.net/aminet/dirs/dev_gg.html
-
-for Amiga resources and information.
-
 One can read this document in the following formats:
 
        man perlamiga
@@ -24,6 +16,11 @@ One can read this document in the following formats:
 to list some (not all may be available simultaneously), or it may
 be read I<as is>: either as F<README.amiga>, or F<pod/perlamiga.pod>.
 
+A recent version of perl for the Amiga can be found at the Geek Gadgets
+section of the Aminet:
+  
+      http://www.aminet.net/~aminet/dirs/dev_gg.html
+
 =cut
 
 Contents
@@ -61,16 +58,12 @@ Contents
 =item B<Unix emulation for AmigaOS: ixemul.library>
 
 You need the Unix emulation for AmigaOS, whose most important part is
-B<ixemul.library>. For a minimum setup, get the following archives from
-ftp://ftp.ninemoons.com/pub/ade/current or a mirror:
+B<ixemul.library>. For a minimum setup, get the latest versions
+of the following packages from the Aminet archives (http://www.aminet.net/~aminet/):
 
-ixemul-46.0-bin.lha
-ixemul-46.0-env-bin.lha
-pdksh-4.9-bin.lha
-ADE-misc-bin.lha
-
-Note that there might be newer versions available by the time you read
-this.
+       ixemul-bin
+       ixemul-env-bin
+       pdksh-bin
 
 Note also that this is a minimum setup; you might want to add other
 packages of B<ADE> (the I<Amiga Developers Environment>).
@@ -108,16 +101,24 @@ easier to use your script under *nix.)
 Perl under AmigaOS lacks some features of perl under UNIX because of
 deficiencies in the UNIX-emulation, most notably:
 
-=over 6
+=over 4
+
+=item * 
+
+fork()
 
-=item fork()
+=item *
 
-=item some features of the UNIX filesystem regarding link count and file dates
+some features of the UNIX filesystem regarding link count and file dates
 
-=item inplace operation (the -i switch) without backup file
+=item *
 
-=item umask() works, but the correct permissions are only set when the file is
-      finally close()d
+inplace operation (the -i switch) without backup file
+
+=item *
+
+umask() works, but the correct permissions are only set when the file is
+finally close()d
 
 =back
 
@@ -126,11 +127,11 @@ deficiencies in the UNIX-emulation, most notably:
 Change to the installation directory (most probably ADE:), and
 extract the binary distribution:
 
-lha -mraxe x perl-5.003-bin.lha
+lha -mraxe x perl-$VERSION-bin.lha
 
 or
 
-tar xvzpf perl-5.003-bin.tgz
+tar xvzpf perl-$VERSION-bin.tgz
 
 (Of course you need lha or tar and gunzip for this.)
 
@@ -189,16 +190,15 @@ Here we discuss how to build Perl under AmigaOS.
 
 =head2 Prerequisites
 
-You need to have the latest B<ADE> (Amiga Developers Environment)
-from ftp://ftp.ninemoons.com/pub/ade/current.
-Also, you need a lot of free memory, probably at least 8MB.
+You need to have the latest B<ixemul> (Unix emulation for Amiga)
+from Aminet.
 
 =head2 Getting the perl source
 
 You can either get the latest perl-for-amiga source from Ninemoons
 and extract it with:
 
-  tar xvzpf perl-5.004-src.tgz
+  tar xvzpf perl-$VERSION-src.tgz
 
 or get the official source from CPAN:
 
@@ -206,7 +206,7 @@ or get the official source from CPAN:
 
 Extract it like this
 
-  tar xvzpf perl5.004.tar.gz
+  tar xvzpf perl-$VERSION.tar.gz
 
 You will see a message about errors while extracting F<Configure>. This
 is normal and expected. (There is a conflict with a similarly-named file
@@ -214,12 +214,60 @@ F<configure>, but it causes no harm.)
 
 =head2 Making
 
-  sh configure.gnu --prefix=/ade
+=over 4
+
+=item *
+
+remember to use a healthy sized stack (I used 2000000)
+
+=item *
+
+your PATH environment variable must include /bin (e.g. ".:/bin" is good)
+(or, more precisely, it must include the directory where you have your
+basic UNIX utilities like test, cat, sed, and so on)
+
+=item *
+       
+  sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib
 
-Now
+=item *
+
+fix makedepend
+
+       In the file 'makedepend' there are three spots like this `$cat ...`:
+       a for loop near line 75, an egrep near line 161, and a for loop near
+       line 175.  In all those spots using an editor change the $cat to
+       /bin/cat.
+
+=item *
+
+now type make depend
+
+       When the make depend has ended load the gnumakefile into
+       an editor and go to the end of the file.
+
+       Move upwards in the file until you reach av.o: EXTERN.h
+       and delete all lines down to # WARNING: Put....
+
+=item *
+
+now go to the x2p directory
+
+       Load the gnumakefile into an editor.
+
+       Go to the end moveup until you reach hash.o: EXTERN.h
+       and delete all lines dowonwards until you reach a line saying
+
+       # WARNING: Put nothing....
+
+=item *
+
+Now!
 
   make
 
+=back
+
 =head2 Testing
 
 Now run
@@ -237,9 +285,10 @@ Run
 
   make install
 
-=head1 AUTHOR
+=head1 AUTHORS
 
 Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de
+Jan-Erik Karlsson, trg@privat.utfors.se
 
 =head1 SEE ALSO
 
index 9718bb5..6264a15 100644 (file)
@@ -27,11 +27,11 @@ platforms.  They run thanks to the Cygwin library which provides the UNIX
 system calls and environment these programs expect.  More information
 about this project can be found at:
 
-  http://sources.redhat.com/cygwin/
+  http://www.cygwin.com/
 
 A recent net or commercial release of Cygwin is required.
 
-At the time this document was last updated, Cygwin 1.1.4 was current.
+At the time this document was last updated, Cygwin 1.1.5 was current.
 
 B<NOTE:> At this point, minimal effort has been made to provide
 compatibility with old (beta) Cygwin releases.  The focus has been to
@@ -253,14 +253,6 @@ closed pipe.  You will see the following messages:
 At least for consistency with WinNT, you should keep the recommended
 value.
 
-=item * Checking how std your stdio is...
-
-Configure reports:
-
-  Your stdio doesn't appear very std.
-
-This is correct.
-
 =item * Compiler/Preprocessor defines
 
 The following error occurs because of the Cygwin C<#define> of
@@ -500,12 +492,11 @@ be kept as clean as possible.
 
 =item Documentation
 
-  INSTALL README.cygwin
+  INSTALL README.cygwin README.win32 MANIFEST
   Changes Changes5.005 Changes5.004 Changes5.6
-  AUTHORS MAINTAIN MANIFEST README.win32
-  pod/buildtoc.PL pod/perl.pod pod/perl5004delta.pod pod/perl56delta.pod
-  pod/perlfaq3.pod pod/perlhist.pod pod/perlmodlib.pod pod/perlport.pod
-  pod/perltoc.pod
+  pod/perl.pod pod/perlport.pod pod/perlfaq3.pod
+  pod/perldelta.pod pod/perl5004delta.pod pod/perl56delta.pod
+  pod/perlhist.pod pod/perlmodlib.pod pod/buildtoc.PL pod/perltoc.pod
 
 =item Build, Configure, Make, Install
 
@@ -543,9 +534,7 @@ be kept as clean as possible.
   perl.h                - binmode
   doio.c                - win9x can not rename a file when it is open
   pp_sys.c              - do not define h_errno, pp_system with spawn
-  mg.c                  - environ WORKAROUND
-  unixish.h             - environ WORKAROUND
-  util.c                - environ WORKAROUND
+  util.c                - use setenv
 
 =item Compiled Module Source
 
@@ -585,10 +574,14 @@ On WinNT Cygwin provides setuid(), seteuid(), setgid() and setegid().
 However, additional Cygwin calls for manipulating WinNT access tokens
 and security contexts are required.
 
+When building DLLs, `C<dllwrap --export-all-symbols>' is used to export
+global symbols.  It might be better to generate an explicit F<.def> file
+(see F<makedef.pl>).  Also, DLLs can now be build with `C<gcc -shared>'.
+
 =head1 AUTHORS
 
 Charles Wilson <cwilson@ece.gatech.edu>,
-Eric Fifer <efifer@sanwaint.com>,
+Eric Fifer <egf7@columbia.edu>,
 alexander smishlajev <als@turnhere.com>,
 Steven Morlock <newspost@morlock.net>,
 Sebastien Barre <Sebastien.Barre@utc.fr>,
@@ -596,4 +589,4 @@ Teun Burgers <burgers@ecn.nl>.
 
 =head1 HISTORY
 
-Last updated: 15 August 2000
+Last updated: 9 November 2000
index 51cd1d6..fe649ed 100644 (file)
@@ -9,7 +9,7 @@ perldos - Perl under DOS, W31, W95.
 =head1 SYNOPSIS
 
 These are instructions for building Perl under DOS (or w??), using
-DJGPP v2.01 or later. Under w95 long filenames are supported.
+DJGPP v2.03 or later.  Under w95 long filenames are supported.
 
 =head1 DESCRIPTION
 
@@ -22,6 +22,10 @@ This port currently supports MakeMaker (the set of modules that
 is used to build extensions to perl).  Therefore, you should be
 able to build and install most extensions found in the CPAN sites.
 
+Detailed instructions on how to build and install perl extension
+modules, including XS-type modules, is included.  See 'BUILDING AND
+INSTALLING MODULES'.
+
 =head2 Prerequisites
 
 =over 4
@@ -46,19 +50,19 @@ the world. Like:
 
 You need the following files to build perl (or add new modules):
 
-        v2/djdev202.zip
-        v2/bnu27b.zip
-        v2gnu/gcc2721b.zip
-        v2gnu/bsh1147b.zip
-        v2gnu/mak3761b.zip
+        v2/djdev203.zip
+        v2/bnu2951b.zip
+        v2gnu/gcc2952b.zip
+        v2gnu/bsh204b.zip
+        v2gnu/mak3791b.zip
         v2gnu/fil316b.zip
-        v2gnu/sed118b.zip
-        v2gnu/txt122b.zip
-        v2gnu/dif271b.zip
-        v2gnu/grep21b.zip
+        v2gnu/sed302b.zip
+        v2gnu/txt20b.zip
+        v2gnu/dif272b.zip
+        v2gnu/grep24b.zip
         v2gnu/shl112b.zip
         v2gnu/gawk303b.zip
-        v2misc/csdpmi4b.zip 
+        v2misc/csdpmi4b.zip
 
 or possibly any newer version.
 
@@ -104,7 +108,7 @@ to use long file names under w95 and also to get Perl to pass all its
 tests, don't forget to use
 
         set LFN=y
-       set FNCASE=y
+        set FNCASE=y
 
 before unpacking the archive.
 
@@ -115,6 +119,9 @@ directory.
 
         ln -s bash.exe sh.exe
 
+[If you have the recommended version of bash for DJGPP, this is already
+done for you.]
+
 And make the C<SHELL> environment variable point to this F<sh.exe>:
 
         set SHELL=c:/djgpp/bin/sh.exe (use full path name!)
@@ -131,20 +138,34 @@ F<split.exe> to F<djsplit.exe>, and F<gsplit.exe> to F<split.exe>.
 Copy or link F<gecho.exe> to F<echo.exe> if you don't have F<echo.exe>.
 Copy or link F<gawk.exe> to F<awk.exe> if you don't have F<awk.exe>.
 
+[If you have the recommended versions of djdev, shell utilities and
+gawk, all these are already done for you, and you will not need to do
+anything.]
+
 =item *
 
 Chdir to the djgpp subdirectory of perl toplevel and type the following
-command:
+commands:
 
+        set FNCASE=y
         configure.bat
 
 This will do some preprocessing then run the Configure script for you.
-The Configure script is interactive, but in most cases you
-just need to press ENTER.
+The Configure script is interactive, but in most cases you just need to
+press ENTER.  The "set" command ensures that DJGPP preserves the letter
+case of file names when reading directories.  If you already issued this
+set command when unpacking the archive, and you are in the same DOS
+session as when you unpacked the archive, you don't have to issue the
+set command again.  This command is necessary *before* you start to 
+(re)configure or (re)build perl in order to ensure both that perl builds 
+correctly and that building XS-type modules can succeed.  See the DJGPP 
+info entry for "_preserve_fncase" for more information:
+
+        info libc alphabetical _preserve_fncase
 
 If the script says that your package is incomplete, and asks whether
 to continue, just answer with Y (this can only happen if you don't use
-long filenames).
+long filenames or forget to issue "set FNCASE=y" first).
 
 When Configure asks about the extensions, I suggest IO and Fcntl,
 and if you want database handling then SDBM_File or GDBM_File
@@ -203,9 +224,106 @@ directory structure. Perl.exe and the utilities go into C<($DJDIR)/bin>,
 and the library goes under C<($DJDIR)/lib/perl5>. The pod documentation
 goes under C<($DJDIR)/lib/perl5/pod>.
 
+=head1 BUILDING AND INSTALLING MODULES
+
+
+=head2 Prerequisites
+
+For building and installing non-XS modules, all you need is a working
+perl under DJGPP.  Non-XS modules do not require re-linking the perl
+binary, and so are simpler to build and install.
+
+XS-type modules do require re-linking the perl binary, because part of
+an XS module is written in "C", and has to be linked together with the
+perl binary to be executed.  This is required because perl under DJGPP
+is built with the "static link" option, due to the lack of "dynamic
+linking" in the DJGPP environment.
+
+Because XS modules require re-linking of the perl binary, you need both
+the perl binary distribution and the perl source distribution to build
+an XS extension module.  In addition, you will have to have built your
+perl binary from the source distribution so that all of the components
+of the perl binary are available for the required link step.
+
+=head2 Unpacking CPAN Modules
+
+First, download the module package from CPAN (e.g., the "Comma Separated
+Value" text package, Text-CSV-0.01.tar.gz).  Then expand the contents of
+the package into some location on your disk.  Most CPAN modules are
+built with an internal directory structure, so it is usually safe to
+expand it in the root of your DJGPP installation.  Some people prefer to
+locate source trees under /usr/src (i.e., C<($DJDIR)/usr/src>), but you may
+put it wherever seems most logical to you, *EXCEPT* under the same
+directory as your perl source code.  There are special rules that apply
+to modules which live in the perl source tree that do not apply to most
+of the modules in CPAN.
+
+Unlike other DJGPP packages, which are normal "zip" files, most CPAN
+module packages are "gzipped tarballs".  Recent versions of WinZip will
+safely unpack and expand them, *UNLESS* they have zero-length files.  It
+is a known WinZip bug (as of v7.0) that it will not extract zero-length
+files.
+
+From the command line, you can use the djtar utility provided with DJGPP
+to unpack and expand these files.  For example:
+
+        C:\djgpp>djtarx -v Text-CSV-0.01.tar.gz
+
+This will create the new directory C<($DJDIR)/Text-CSV-0.01>, filling
+it with the source for this module.
+
+=head2 Building Non-XS Modules
+
+To build a non-XS module, you can use the standard module-building
+instructions distributed with perl modules.
+
+    perl Makefile.PL
+    make
+    make test
+    make install
+
+This is sufficient because non-XS modules install only ".pm" files and
+(sometimes) pod and/or man documentation.  No re-linking of the perl
+binary is needed to build, install or use non-XS modules.
+
+=head2 Building XS Modules
+
+To build an XS module, you must use the standard module-building
+instructions distributed with perl modules *PLUS* three extra
+instructions specific to the DJGPP "static link" build environment.
+
+    set FNCASE=y
+    perl Makefile.PL
+    make
+    make perl
+    make test
+    make -f Makefile.aperl inst_perl MAP_TARGET=perl.exe
+    make install
+
+The first extra instruction sets DJGPP's FNCASE environment variable so
+that the new perl binary which you must build for an XS-type module will
+build correctly.  The second extra instruction re-builds the perl binary
+in your module directory before you run "make test", so that you are
+testing with the new module code you built with "make".  The third extra
+instruction installs the perl binary from your module directory into the
+standard DJGPP binary directory, C<($DJDIR)/bin>, replacing your
+previous perl binary.
+
+Note that the MAP_TARGET value *must* have the ".exe" extension or you
+will not create a "perl.exe" to replace the one in C<($DJDIR)/bin>.
+
+When you are done, the XS-module install process will have added information
+to yout "perllocal" information telling that the perl binary has been replaced,
+and what module was installed.  you can view this information at any time
+by using the command:
+
+        perl -S perldoc perllocal
+
 =head1 AUTHOR
 
-Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se>
+Laszlo Molnar, F<laszlo.molnar@eth.ericsson.se> [Installing/building perl]
+
+Peter J. Farley III F<pjfarley@banet.net> [Building/installing modules]
 
 =head1 SEE ALSO
 
index 06290c3..6c62565 100644 (file)
@@ -1,14 +1,16 @@
-=====================================================================
-Perl 5 README file for the EPOC operating system.
-=====================================================================
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see pod/perlpod.pod) which is
+specially designed to be readable as is.
 
-Olaf Flebbe <o.flebbe@gmx.de>
-http://members.linuxstart.com/~oflebbe/perl/perl5.html
-2000-09-18
+=head1 NAME
+
+README.epoc - Perl for EPOC
 
-=====================================================================
-Introduction
-=====================================================================
+=head1 SYNOPSIS
+
+Perl 5 README file for the EPOC operating system.
+
+=head1 INTRODUCTION
 
 EPOC is a OS for palmtops and mobile phones. For more informations look at:
 http://www.symbian.com/
@@ -18,9 +20,7 @@ This is a port of perl to EPOC. It runs on the Psion Series 5, 5mx,
 the Psion Netbook or the S7. For information about this hardware
 please refer to http://www.psion.com.
 
-=====================================================================
-Installation/Usage
-=====================================================================
+=head1 INSTALLING PERL ON EPOC
 
 You will need ~4MB free space in order to install and run perl.
 
@@ -40,9 +40,9 @@ you are leaving perl, you get into the system screen. You have to
 switch back manually to ESHELL. When perl is running, you will see
 a task with the name STDOUT in the task list.
 
-======================================================================
-IO Redirection
-======================================================================
+=head1 USING PERL ON EPOC
+
+=head2 IO Redirection
 
 You can redirect the output with the UNIX bourne shell syntax (this is
 built into perl rather then eshell) For instance the following command
@@ -51,12 +51,10 @@ stdout_file, the errors to stderr_file and input from stdin_file.
 
 perl test.pl >stdout_file <stdin_file 2>stderr_file
 
-Alternativly you can use 2>&1 in order to add the standard error
+Alternatively you can use 2>&1 in order to add the standard error
 output to stdout.
 
-======================================================================
-PATH Names
-======================================================================
+=head2 PATH Names
 
 ESHELL looks for executables in ?:/System/Programs. The SIS file
 installs perl in this special folder directory. The default drive and
@@ -80,68 +78,96 @@ You can automatically search for file on all EPOC drives with a ? as
 the driver letter. For instance ?:\a.txt searches for C:\a.txt,
 D:\b.txt (and Z:\a.txt).
 
-======================================================================
-Editors
-======================================================================
+=head2 Editors
 
 A suitable text-editor can be downloaded 
 from symbian http://developer.epocworld.com/downloads/progs/Editor.zip
 
-====================================================================
-Features
-====================================================================
+=head2 Features
 
 The built-in function EPOC::getcwd returns the current directory.
 
-======================================================================
-Restrictions
-======================================================================
+=head2 Restrictions
 
 Features are left out, because of restrictions of the POSIX support in
 EPOC:
 
-+ backquoting, pipes etc.
+=over 4
+
+=item *
+
+backquoting, pipes etc.
+
+=item *
+
+system() does not inherit ressources like: file descriptors,
+environment etc.
+
+=item *
+
+signal, kill, alarm. Do not try to use them. This may be
+impossible to implement on EPOC.
+
+=item *
+
+select is missing.
+
+=item *
 
-+ system() does not inherit ressources like: file descriptors,
-  environment etc.
+binmode does not exist. (No CR LF to LF translation for text files)
 
-+ signal, kill, alarm. Do not try to use them. This may be
-  impossible to implement on EPOC.
+=item *
 
-+ select is missing.
+EPOC does not handle the notion of current drive and current
+directory very well (i.e. not at all, but it tries hard to emulate
+one) See PATH.
 
-+ binmode does not exist. (No CR LF to LF translation for text files)
+=item *
 
-+ EPOC does not handle the notion of current drive and current
-  directory very well (i.e. not at all, but it tries hard to emulate
-  one) See PATH.
+You need the shell eshell.exe in order to run perl.exe and supply
+it with arguments.
 
-+ You need the shell eshell.exe in order to run perl.exe and supply
-  it with arguments.
+=item *
 
-+ Heap is limited to 4MB.
+Heap is limited to 4MB.
 
-===================================================================
-Compiling Perl 5 on the EPOC cross compiling envionment.
-===================================================================
+=back
+
+=head2 Compiling Perl 5 on the EPOC cross compiling environment
 
 Sorry, this is far too short.
 
-    You will need the C++ SDK from http://developer.epocworld.com/. 
+=over 4
+
+=item *
+
+You will need the C++ SDK from http://developer.epocworld.com/. 
+
+=item *
+
+You will need to set up the cross SDK from 
+http://www.science-computing.de/o.flebbe/sdk
+
+=item *
+
+You may have to adjust config.sh (cc, cppflags) for your epoc 
+install location.
+
+=item *
+
+You may have to adjust config.sh for your cross SDK location
 
-    You will need to set up the cross SDK from 
-    http://members.linuxstart.com/~oflebbe
+=item *
 
-    You may have to adjust config.sh (cc, cppflags) for your epoc 
-    install location.
+Get the Perl sources from your nearest CPAN site.
 
-    You may have to adjust config.sh for your cross SDK location
+=item *
 
-    Get the Perl sources from your nearest CPAN site.
+Unpack the sources. 
 
-    Unpack the sources. 
+=item *
 
-      Build a native perl from this sources... 
+Build a native perl from this sources... 
 
       cp epoc/* .
       ./Configure -S
@@ -159,10 +185,20 @@ Sorry, this is far too short.
 
       wine G:/bin/makesis perl.pkg perl.sis
 
+=back
 
-====================================================================
-Support Status
-====================================================================
+=head1 SUPPORT STATUS
 
 I'm offering this port "as is". You can ask me questions, but I can't
 guarantee I'll be able to answer them.
+
+=head1 AUTHOR
+
+Olaf Flebbe <o.flebbe@gmx.de>
+http://members.linuxstart.com/~oflebbe/perl/perl5.html
+
+=head1 LAST UPDATE
+
+2000-09-18
+
+=cut
index e12c60d..e850441 100644 (file)
@@ -243,22 +243,22 @@ fix is currently available.
 
 =head2 perl -P and //
 
-In HP-UX perl is compiled with flags that will cause problems if the
+In HP-UX Perl is compiled with flags that will cause problems if the
 -P flag of Perl (preprocess Perl code with the C preprocessor before
 perl sees it) is used.  The problem is that C<//>, being a C++-style
 until-end-of-line comment, will disappear along with the remainder
 of the line.  This means that common Perl constructs like
 
-       s/foo//;
+    s/foo//;
 
 will turn into illegal code
 
-       s/foo
+    s/foo
 
-The workaround is to use some other quoting characters than /,
-like for example !
+The workaround is to use some other quoting separator than C<"/">,
+like for example C<"!">:
 
-       s!foo!!;
+    s!foo!!;
 
 =head1 AUTHOR
 
index 9e0b51d..7976db5 100644 (file)
-Perl/iX for HP 3000 MPE
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see perlpod manpage) which is
+specially designed to be readable as is.
 
-http://www.cccd.edu/~markb/perlix.html
-Perl language for MPE
-Last updated July 15, 1998 @ 2030 UTC
+=head1 NAME
 
-  ------------------------------------------------------------------------
+README.mpeix - Perl/iX for HP e3000 MPE
+                                       
+=head1 SYNOPSIS
 
-What's New
+   http://www.bixby.org/mark/perlix.html
+   Perl language for MPE
+   Last updated June 2, 2000 @ 0400 UTC
+   
+=head1 NOTE
 
-   * July 15, 1998
-        o Changed startperl to #!/PERL/PUB/perl so that Perl will recognize
-          scripts more easily and efficiently.
-   * July 8, 1998
-        o Updated to version 5.004_70 (internal developer release) which is
-          now MPE-ready.  The next public freeware release of Perl should
-          compile "straight out of the box" on MPE.  Note that this version
-          of Perl/iX was strictly internal to me and never publicly
-          released.  Note that BIND/iX is now required (well, the include
-          files and libbind.a) if you wish to compile Perl/iX.
-   * November 6, 1997
-        o Updated to version 5.004_04.  No changes in MPE-specific
-          functionality.
+This is a podified version of the above-mentioned web page,
+podified by Jarkko Hietaniemi 2001-Jan-01.
 
-  ------------------------------------------------------------------------
+=head1 What's New
 
-Welcome
+June 1, 2000
+       
+=over 4
 
-This is the official home page for the HP 3000 MPE port of the Perl
-scripting language which gives you all of the power of C, awk, sed, and sh
-in a single language. Check here for the latest news, implemented
-functionality, known bugs, to-do list, etc. Status reports about major
-milestones will also be posted to the HP3000-L mailing list and its
-associated gatewayed newsgroup comp.sys.hp.mpe.
+=item *
 
-I'm doing this port because I can't live without Perl on the HPUX machines
-that I administer for the Coast Community College District, and I want to
-have the same power available to me on MPE.
+Rebuilt to be compatible with mod_perl.  If you plan on using
+mod_perl, you MUST download and install this version of Perl/iX!
+       
+=item *
 
-Please send your comments, questions, and bug reports directly to me, Mark
-Bixby, by e-mailing to markb@cccd.edu. Or just post them to HP3000-L. You
-can also telephone me at +1 714 438-4647 Monday-Friday 0815-1745 PDT
-(1615-0145 UTC).
+bincompat5005="undef": sorry, but you will have to recompile any
+binary 5.005 extensions that you may be using (if any; there is no
+5.005 code in what you download from bixby.org)
+uselargefiles="undef": not available in MPE for POSIX files yet.
+       
+=item *
 
-The platform I'm using to do this port is an HP 3000 969KS200 running
-MPE/iX 5.5 and using the gcc 2.8 compiler from
-http://www.interex.org/sources/freeware.html.
+Now bundled with various add-on packages:
 
-The combined porting wisdom from all of my ports can be found in my MPE/iX
-Porting Guide.
+=over 8
 
-  ------------------------------------------------------------------------
+=item *
 
-System Requirements
+libnet (http://www.gbarr.demon.co.uk/libnet/FAQ.html)
 
-   * MPE/iX 5.5 or later. This version of Perl/iX does NOT run on MPE/iX
-     5.0 or earlier, nor does it run on "classic" MPE/V machines.
-   * The Perl binary requires that you must have converted your NMRL
-     libraries in /lib/lib*.a and /usr/lib/lib*.a to NMXL libraries
-     /lib/lib*.sl and /usr/lib/lib*.sl via the LIBSHP3K script that comes
-     with the GNUCORE portion of the  FREEWARE tape.
-   * If you wish to recompile Perl, you must install both GNUCORE and
-     GNUGCC from the FREEWARE tape.
-   * Perl/iX will be happier if you install the MPEKX76A additional POSIX
-     filename characters patch, but this is optional.
-   * If you will be compiling Perl/iX yourself, you will also need the
-     /BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX.
+=item *
 
-  ------------------------------------------------------------------------
+libwww-perl (LWP) which lets Perl programs behave like web browsers:
+       
+    1. #!/PERL/PUB/perl
+    2. use LWP::Simple;
+    3. $doc = get('http://www.bixby.org/mark/perlix.html');  # reads the
+       web page into variable $doc
+       
+(http://www.bixby.org/mark/perlix.html)
 
-Demos
+=item *
 
-Here is a brief selection of some sample Perl/iX uses:
+mod_perl (just the perl portion; the actual DSO will be released
+soon with Apache/iX 1.3.12 from bixby.org).  This module allows you to
+write high performance persistent Perl CGI scripts and all sorts of
+cool things. (http://perl.apache.org/)
+   
+and much much more hiding under /PERL/PUB/.cpan/
+   
+=item *
 
-   * A web feedback CGI form that lets a web browser user enter some data
-     and send e-mail to the person responsible for reading the feedback
-     comments.  The CGI is written in Perl and requires Sendmail/iX.
+The CPAN module now works for automatic downloading and
+installing of add-on packages:
 
-  ------------------------------------------------------------------------
+    1. export FTP_PASSIVE=1
+    2. perl -MCPAN -e shell
+    3. Ignore any terminal I/O related complaints!
+       
+(http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html)
 
-How to Obtain Perl/iX
+=back
 
-  1. Download Perl using either FTP.ARPA.SYS or some other client
-  2. Extract the installation script
-  3. Edit the installation script
-  4. Run the installation script
+=back
+
+May 20, 2000
+
+=over 4
+
+=item *
+
+Updated to version 5.6.0.  Builds straight out of the box on MPE/iX.
+
+=item *
+
+Perl's getpwnam() function which had regressed to being
+unimplemented on MPE is now implemented once again.
+       
+=back
+
+September 17, 1999
+
+=over 4
+
+=item *
+
+Migrated from cccd.edu to bixby.org.
+
+=back
+   
+=head1 Welcome
+
+This is the official home page for the HP e3000 MPE/iX
+(http://www.businessservers.hp.com/) port of the Perl scripting
+language (http://www.perl.com/) which gives you all of the power of C,
+awk, sed, and sh in a single language. Check here for the latest news,
+implemented functionality, known bugs, to-do list, etc. Status reports
+about major milestones will also be posted to the HP3000-L mailing list
+(http://www.lsoft.com/scripts/wl.exe?SL1=HP3000-L&H=RAVEN.UTC.EDU) and
+its associated gatewayed newsgroup comp.sys.hp.mpe.
+   
+I'm doing this port because I can't live without Perl on the Unix
+machines that I administer, and I want to have the same power
+available to me on MPE.
+   
+Please send your comments, questions, and bug reports directly to me,
+Mark Bixby (http://www.bixby.org/mark/), by e-mailing to
+mark@bixby.org. Or just post them to HP3000-L.
+   
+The platform I'm using to do this port is an HP 3000 957RX running
+MPE/iX 6.0 and using the GNU gcc C compiler
+(http://jazz.external.hp.com/src/gnu/gnuframe.html).
+   
+The combined porting wisdom from all of my ports can be found in my
+MPE/iX Porting Guide (http://www.bixby.org/mark/porting.html).
+   
+IMPORTANT NOTICE: Yes, I do work for the HP CSY R&D lab, but ALL of
+the software you download from bixby.org is my personal freeware that
+is NOT supported by HP.
+
+=head1 System Requirements
+
+=over 4
+
+=item *
+
+MPE/iX 5.5 or later. This version of Perl/iX does NOT run on
+MPE/iX 5.0 or earlier, nor does it run on "classic" MPE/V machines.
+
+=item *
+
+If you wish to recompile Perl, you must install both GNUCORE and
+GNUGCC from jazz (http://jazz.external.hp.com/src/gnu/gnuframe.html).
+
+=item *
+
+Perl/iX will be happier on MPE/iX 5.5 if you install the MPEKX40B
+extended POSIX filename characters patch, but this is optional.
+
+=item *
+
+Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to
+prevent Perl/iX from dying with an unresolved external reference
+to _getenv_libc.
+
+=item *
+
+If you will be compiling Perl/iX yourself, you will also need
+Syslog/iX (http://www.bixby.org/mark/syslogix.html) and the
+/BIND/PUB/include and /BIND/PUB/lib portions of BIND/iX
+(http://www.bixby.org/mark/bindix.html).
+
+=back
+
+=head1 How to Obtain Perl/iX
+
+=over 4
+
+=item 1.
+
+Download Perl using either FTP.ARPA.SYS or some other client
+
+=item 2.
+
+Extract the installation script
+
+=item 3.
+
+Edit the installation script
+
+=item 4.
+
+Run the installation script
+
+=item 5.
+
+Convert your *.a system archive libraries to *.sl shared libraries
+       
+=back
 
 Download Perl using FTP.ARPA.SYS from your HP 3000 (the preferred
 method).....
-
-:HELLO MANAGER.SYS
-:XEQ FTP.ARPA.SYS
-open ftp.cccd.edu
-anonymous
-your@email.address
-bytestream
-cd /pub/mpe
-get perl5.005.tar.Z /tmp/perl.tar.Z
-exit
+  
+    :HELLO MANAGER.SYS
+    :XEQ FTP.ARPA.SYS
+    open ftp.bixby.org
+    anonymous
+    your@email.address
+    bytestream
+    cd /pub/mpe
+    get perl-5.6.0-mpe.tar.Z /tmp/perl.tar.Z;disc=2147483647
+    exit
 
 .....Or download using some other generic web or ftp client (the alternate
 method)
-
+  
 Download the following files (make sure that you use "binary mode" or
 whatever client feature that is 8-bit clean):
 
-   * Perl from http://www.cccd.edu/ftp/pub/mpe/perl5.005.tar.Z or
-     ftp://ftp.cccd.edu/pub/mpe/perl5.005.tar.Z
+=over 4
+
+=item *
+
+Perl from
+
+    http://www.bixby.org/ftp/pub/mpe/perl-5.6.0-mpe.tar.Z
+
+or
+
+    ftp://ftp.bixby.org/pub/mpe/perl-5.6.0-mpe.tar.Z
+       
+=item *
 
 Upload those files to your HP 3000 in an 8-bit clean bytestream manner to:
 
-   * /tmp/perl.tar.Z
+    /tmp/perl.tar.Z
+       
+=item *
 
 Then extract the installation script (after both download methods)
+  
+    :CHDIR /tmp
+    :XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL'
 
-:CHDIR /tmp
-:XEQ TAR.HPBIN.SYS 'xvfopz /tmp/perl.tar.Z INSTALL'
+=item *
 
 Edit the installation script
+  
+Examine the accounting structure creation commands and modify if
+necessary (adding additional capabilities, choosing a non-system
+volume set, etc).
 
-Examine the accounting structure creation commands and modify if necessary
-(adding additional capabilities, choosing a non-system volume set, etc).
+    :XEQ VI.HPBIN.SYS /tmp/INSTALL
 
-:XEQ VI.HPBIN.SYS /tmp/INSTALL
-
-Run the installation script
+=item *
 
+Run the installation script.
+  
 The accounting structure will be created and then all files will be
 extracted from the archive.
 
-:XEQ SH.HPBIN.SYS /tmp/INSTALL
-
-  ------------------------------------------------------------------------
-
-Distribution Contents Highlights
-
-README
-     The file you're reading now.
-INSTALL
-     Perl/iX Installation script.
-PERL
-     Perl NMPRG executable.  A version-numbered backup copy also exists.
-     You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl".
-lib/
-     Perl libraries, both core and add-on.
-man/
-     Perl man page documentation.
-public_html/feedback.cgi
-     Sample feedback CGI form written in Perl.
-src/perl5.005
-     Source code.
-
-  ------------------------------------------------------------------------
-
-How to Compile Perl/iX
-
-  1. cd src/perl5.005
-  2. Read the INSTALL file for the official instructions
-  3. ./Configure
-  4. make
-  5. ./mpeix/relink
-  6. make test (expect 31 out of 5899 subtests to fail, mostly due to MPE
-     not supporting hard links and handling exit() return codes improperly)
-  7. make install
-  8. Optionally create symbolic links that point to the Perl executable,
-     i.e. ln -s /usr/local/bin/perl /PERL/PUB/PERL
+    :XEQ SH.HPBIN.SYS /tmp/INSTALL
+
+=item *
+
+Convert your *.a system archive libraries to *.sl shared libraries
+  
+You only have to do this ONCE on your MPE/iX 5.5 machine in order to
+convert /lib/lib*.a and /usr/lib/lib*.a libraries to their *.sl
+equivalents.  This step should not be necessary on MPE/iX 6.0 or later
+machines because the 6.0 or later update process does it for you.
+
+    :XEQ SH.HPBIN.SYS /PERL/PUB/LIBSHP3K
+
+=back
+
+=head1 Distribution Contents Highlights
+
+=over 4
+
+=item README
+
+The file you're reading now.
+          
+=item INSTALL
+
+Perl/iX Installation script.
+          
+=item LIBSHP3K
+
+Script to convert *.a system archive libraries to *.sl shared libraries.
+          
+=item PERL
+
+Perl NMPRG executable.  A version-numbered backup copy also
+exists.  You might wish to "ln -s /PERL/PUB/PERL /usr/local/bin/perl".
+          
+=item .cpan/
+
+Much add-on source code downloaded with the CPAN module.
+          
+=item lib/
+
+Perl libraries, both core and add-on.
+          
+=item man/
+
+Perl man page documentation.
+
+=item public_html/feedback.cgi
+
+Sample feedback CGI form written in Perl.
+          
+=item src/perl-5.6.0-mpe
+
+Source code.
+
+=back
+   
+=head1 How to Compile Perl/iX
+
+=over 4
+
+=item 1.
+
+cd src/perl-5.6.0-mpe
+
+=item 2.
+
+Read the INSTALL file for the official instructions
+
+=item 3.
+
+./Configure -d
+
+=item  4.
+
+make
+
+=item 5.
+
+./mpeix/relink
+
+=item  6.
+
+make test (expect approximately 15 out of 11306 subtests to fail,
+mostly due to MPE not supporting hard links, UDP socket problems,
+and handling exit() return codes improperly)
+
+=item 7.
+
+make install
+
+=item 8.
+
+Optionally create symbolic links that point to the Perl
+executable, i.e. ln -s /PERL/PUB/PERL /usr/local/bin/perl
+       
+=back
 
 The summary test results from "cd t; ./perl -I../lib harness":
 
-Failed Test  Status Wstat Total Fail  Failed  List of failed
--------------------------------------------------------------------------------
-io/fs.t                      26    8  30.77%  2-5, 7-9, 11
-io/pipe.t                    12    2  16.67%  11-12
-lib/posix.t                  18    1   5.56%  12
-op/die_exit.t                16   16 100.00%  1-16
-op/exec.t                     8    2  25.00%  5-6
-op/stat.t                    58    2   3.45%  3, 35
-Failed 6/183 test scripts, 96.72% okay. 31/5899 subtests failed, 99.47% okay.
-
-  ------------------------------------------------------------------------
-
-Getting Started with Perl/iX
-
-Create your Perl script files with "#!/PERL/PUB/perl" (or an equivalent
-symbolic link) as the first line.  Use the chmod command to make sure that
-your script has execute permission. Run your script!
-
-If you want to use Perl to write web server CGI scripts, obtain and install
-CGI.pm. Build CGI.pm and all other add-on modules below /PERL/PUB/src/.
-
-Be sure to take a look at the CPAN module list. A wide variety of free Perl
-software is available.
-
-  ------------------------------------------------------------------------
-
-MPE/iX Implementation Considerations
-
-There some minor functionality issues to be aware of when comparing Perl
-for Unix (Perl/UX) to Perl/iX:
-
-   * MPE gcc/ld doesn't properly support linking NMPRG executables against
-     NMXL dynamic libraries, so you must manually run mpeix/relink after
-     each re-build of Perl.
-   * Perl/iX File::Copy will use MPE's /bin/cp command to copy files by
-     name in order to preserve file attributes like file code.
-   * MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(),
-     setpwent(), endpwent().
-   * MPE (and thus Perl/iX) lacks support for hard links.
-   * MPE requires GETPRIVMODE() in order to bind() to ports less than
-     1024.  Perl/iX will call GETPRIVMODE() automatically on your behalf if
-     you attempt to bind() to these low-numbered ports.  Note that the
-     Perl/iX executable and the PERL account do not normally have CAP=PM,
-     so if you will be bind()-ing to these privileged ports, you will
-     manually need to add PM capability as appropriate.
-   * MPE requires that you bind() to an IP address of zero.  Perl/iX
-     automatically replaces the IP address that you pass to bind() with a
-     zero.
-   * If you use Perl/iX fcntl() against a socket it will fail, because MPE
-     requires that you use sfcntl() instead.  Perl/iX does not presently
-     support sfcntl().
-   * MPE requires GETPRIVMODE() in order to setuid().  There are too many
-     calls to setuid() within Perl/iX, so I have not attempted an automatic
-     GETPRIVMODE() solution similar to bind().
-
-  ------------------------------------------------------------------------
-
-Known Bugs Under Investigation
-
-   * None
-
-  ------------------------------------------------------------------------
-
-To-Do List
-
-   * Make setuid()/setgid() support work.
-   * Make sure that fcntl() against a socket descriptor is redirected to
-     sfcntl().
-   * Add support for Berkeley DB once I've finished porting Berkeley DB.
-   * Write an MPE XS extension library containing miscellaneous important
-     MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl().
-
-  ------------------------------------------------------------------------
-
-Change History
-
-   * October 16, 1997
-        o Added Demos section to the Perl/iX home page so you can see some
-          sample Perl applications running on my 3000.
-   * October 3, 1997
-        o Added System Requirements section to the Perl/iX home page just
-          so the prerequisites stand out more. Various other home page
-          tweaks.
-   * October 2, 1997
-        o Initial public release.
-   * September 1997
-        o Porting begins.
-
-  ------------------------------------------------------------------------
-
-Mark Bixby, markb@cccd.edu
+  Failed Test  Status Wstat Total Fail  Failed  List of failed
+  ---------------------------------------------------------------------------
+  io/fs.t                      29    8  27.59%  2-5, 7-9, 11
+  io/openpid.t                 10    1  10.00%  7
+  lib/io_sock.t                14    1   7.14%  13
+  lib/io_udp.t                  7    2  28.57%  3, 5
+  lib/posix.t                  27    1   3.70%  12
+  op/lex_assign.t             187    1   0.53%  13
+  op/stat.t                    58    1   1.72%  3
+  15 tests and 94 subtests skipped.
+  Failed 7/236 test scripts, 97.03% okay. 15/11306 subtests failed, 99.87% okay.
+
+=head1 Getting Started with Perl/iX
+
+Create your Perl script files with "#!/PERL/PUB/perl" (or an
+equivalent symbolic link) as the first line.  Use the chmod command to
+make sure that your script has execute permission. Run your script!
+   
+Be sure to take a look at the CPAN module list
+(http://www.cpan.org/CPAN.html). A wide variety of free Perl software
+is available.  You can automatically download these packages by using
+the CPAN module (http://theoryx5.uwinnipeg.ca/CPAN/data/perl/CPAN.html).
+
+=head1 MPE/iX Implementation Considerations
+
+There some minor functionality issues to be aware of when comparing
+Perl for Unix (Perl/UX) to Perl/iX:
+
+=over 4
+
+=item *
+
+MPE gcc/ld doesn't properly support linking NMPRG executables against
+NMXL dynamic libraries, so you must manually run mpeix/relink after
+each re-build of Perl.
+
+=item *
+
+Perl/iX File::Copy will use MPE's /bin/cp command to copy files by
+name in order to preserve file attributes like file code.
+
+=item *
+
+MPE (and thus Perl/iX) lacks support for setgrent(), endgrent(),
+setpwent(), endpwent().
+
+=item *
+
+MPE (and thus Perl/iX) lacks support for hard links.
+
+=item *
+
+MPE requires GETPRIVMODE() in order to bind() to ports less than 1024.
+Perl/iX will call GETPRIVMODE() automatically on your behalf if you
+attempt to bind() to these low-numbered ports.  Note that the Perl/iX
+executable and the PERL account do not normally have CAP=PM, so if you
+will be bind()-ing to these privileged ports, you will manually need
+to add PM capability as appropriate.
+
+=item *
+
+MPE requires that you bind() to an IP address of zero.  Perl/iX
+automatically replaces the IP address that you pass to bind() with
+a zero.
+
+=item *
+
+If you use Perl/iX fcntl() against a socket it will fail, because MPE
+requires that you use sfcntl() instead.  Perl/iX does not presently
+support sfcntl().
+
+=item *
+
+MPE requires GETPRIVMODE() in order to setuid().  There are too many
+calls to setuid() within Perl/iX, so I have not attempted an automatic
+GETPRIVMODE() solution similar to bind().
+
+=back
+   
+=head1 Known Bugs Under Investigation
+
+None.
+   
+=head1 To-Do List
+
+=over 4
+
+=item *
+
+Make setuid()/setgid() support work.
+
+=item *
+
+Make sure that fcntl() against a socket descriptor is redirected to sfcntl().
+
+=item *
+
+Add support for Berkeley DB once I've finished porting Berkeley DB.
+
+=item *
+
+Write an MPE XS extension library containing miscellaneous important
+MPE functions like GETPRIVMODE(), GETUSERMODE(), and sfcntl().
+   
+=back
+
+=head1 Change History
+
+May 6, 1999
+       
+=over 4
+
+=item *
+
+Patch LBCJXT6A is required on MPE/iX 5.5 machines in order to prevent
+Perl/iX from dying with an unresolved external reference to _getenv_libc.
+       
+=back
+
+April 7, 1999
+
+=over 4
+
+=item *
+
+Updated to version 5.005_03.
+
+=item *
+
+The official source distribution once again compiles "straight out
+of the box" for MPE.
+
+=item *
+
+The current incarnation of the 5.5 POSIX filename extended
+characters patch is now MPEKX40B.
+
+=item *
+
+The LIBSHP3K *.a -> *.sl library conversion script is now included
+as /PERL/PUB/LIBSHP3K.
+       
+=back
+
+November 20, 1998
+
+=over 4
+
+=item *
+
+Updated to version 5.005_02.
+
+=item *
+
+Fixed a DynaLoader bug that was unable to load symbols from relative
+path name libraries.
+
+=item *
+
+Fixed a .xs compilation bug where the mpeixish.sh include file wasn't
+being installed into the proper directory.
+
+=item *
+
+All bugfixes will be submitted back to the official Perl developers.
+
+=item *
+
+The current incarnation of the POSIX filename extended characters
+patch is now MPEKXJ3A.
+       
+=back
+   
+August 14, 1998
+
+=over 4
+
+=item *
+
+The previous POSIX filename extended characters patch MPEKX44C has
+been superseded by MPEKXB5A.
+       
+=back
+   
+August 7, 1998
+
+=over 4
+
+=item *
+
+The previous POSIX filename extended characters patch MPEKX76A has
+been superseded by MPEKX44C.
+       
+=over 4
+
+=back
+   
+July 28, 1998
+
+=item *
+
+Updated to version 5.005_01.
+       
+=back
+   
+July 23, 1998
+
+=over 4
+
+=item *
+
+Updated to version 5.005 (production release).  The public
+freeware sources are now 100% MPE-ready "straight out of the box".
+       
+=back
+   
+July 17, 1998
+
+=over 4
+
+=item *
+
+Updated to version 5.005b1 (public beta release).  The public
+freeware sources are now 99.9% MPE-ready.  By installing and
+testing this beta on your own HP3000, you will be helping to
+insure that the final release of 5.005 will be 100% MPE-ready and
+100% bug free.
+
+=item *
+
+My MPE binary release is now extracted using my standard INSTALL script.
+       
+=back
+   
+July 15, 1998
+
+=over 4
+
+=item *
+
+Changed startperl to #!/PERL/PUB/perl so that Perl will recognize
+scripts more easily and efficiently.
+       
+=back
+   
+July 8, 1998
+
+=over 4
+
+=item *
+
+Updated to version 5.004_70 (internal developer release) which is now
+MPE-ready.  The next public freeware release of Perl should compile
+"straight out of the box" on MPE.  Note that this version of Perl/iX
+was strictly internal to me and never publicly released.  Note that
+[21]BIND/iX is now required (well, the include files and libbind.a) if
+you wish to compile Perl/iX.
+       
+=back
+   
+November 6, 1997
+
+=over 4
+
+=item *
+
+Updated to version 5.004_04.  No changes in MPE-specific functionality.
+       
+=back
+   
+October 16, 1997
+
+=over 4
+
+=item *
+
+Added Demos section to the Perl/iX home page so you can see some
+sample Perl applications running on my 3000.
+       
+=back
+   
+October 3, 1997
+
+=over 4
+
+=item *
+
+Added System Requirements section to the Perl/iX home page just so the
+prerequisites stand out more. Various other home page tweaks.
+       
+=back
+   
+October 2, 1997
+
+=over 4
+
+=item *
+
+Initial public release.
+       
+=back
+   
+September 1997
+
+=over 4
+
+=item *
+
+Porting begins.
+
+=back
+   
+=head1 Author
+   
+Mark Bixby, mark@bixby.org
+
index b46fa7a..19af8c5 100644 (file)
@@ -115,7 +115,7 @@ Contents
          -  Threads
       AUTHOR 
       SEE ALSO 
-  
+
 =head1 DESCRIPTION
 
 =head2 Target
@@ -394,12 +394,12 @@ is considered a bug and should be fixed soon.
 
 =over 4
 
-=item
+=item *
 
 Did you run your programs with C<-w> switch? See 
 L<Starting OS/2 (and DOS) programs under Perl>.
 
-=item
+=item *
 
 Do you try to run I<internal> shell commands, like C<`copy a b`>
 (internal for F<cmd.exe>), or C<`glob a*b`> (internal for ksh)? You
@@ -1163,18 +1163,18 @@ eventually).
 
 =over 4
 
-=item
+=item *
 
 Since L<flock(3)> is present in EMX, but is not functional, it is 
 emulated by perl.  To disable the emulations, set environment variable
 C<USE_PERL_FLOCK=0>.
 
-=item
+=item *
 
 Here is the list of things which may be "broken" on
 EMX (from EMX docs):
 
-=over
+=over 4
 
 =item *
 
@@ -1205,7 +1205,7 @@ L<waitpid(3)>:
 
 Note that C<kill -9> does not work with the current version of EMX.
 
-=item
+=item *
 
 Since F<sh.exe> is used for globing (see L<perlfunc/glob>), the bugs
 of F<sh.exe> plague perl as well. 
@@ -1517,9 +1517,9 @@ cannot test it.
 For the details of the current situation with calling external programs,
 see L<Starting OS/2 (and DOS) programs under Perl>.
 
-=over
+=over 4
 
-=item
+=item *
 
 External scripts may be called by name.  Perl will try the same extensions
 as when processing B<-S> command-line switch.
@@ -1549,7 +1549,7 @@ preliminary.
 
 Most notable problems: 
 
-=over
+=over 4
 
 =item C<COND_WAIT> 
 
index 571d027..8dd0483 100644 (file)
@@ -1,5 +1,6 @@
+
 This document is written in pod format hence there are punctuation 
-characters in in odd places.  Do not worry, you've apparently got 
+characters in odd places.  Do not worry, you've apparently got 
 the ASCII->EBCDIC translation worked out correctly.  You can read 
 more about pod in pod/perlpod.pod or the short summary in the 
 INSTALL file.
@@ -15,12 +16,12 @@ on OS/390 Unix System Services.
 
 =head1 DESCRIPTION
 
-This is a fully ported perl for OS/390 Release 3, 5 and 6.
-It may work on other versions, but those are the ones we've 
-tested it on.
+This is a fully ported Perl for OS/390 Version 2 Release 3, 5, 6, 7, 
+8, and 9.  It may work on other versions or releases, but those are 
+the ones we've tested it on.
 
 You may need to carry out some system configuration tasks before 
-running the Configure script for perl.  
+running the Configure script for Perl.  
 
 =head2 Unpacking
 
@@ -41,12 +42,39 @@ parser template files. If you have not already done so then be sure to:
 
 This may also be a good time to ensure that your /etc/protocol file 
 and either your /etc/resolv.conf or /etc/hosts files are in place.
+The IBM document that described such USS system setup issues was
+SC28-1890-07 "OS/390 UNIX System Services Planning", in particular
+Chapter 6 on customizing the OE shell.
 
-GNU make for OS/390, which may be required for the build of perl, 
-is available from:
+GNU make for OS/390, which is required for the build of perl (as well as
+building CPAN modules and extensions), is available from:
 
   http://www.mks.com/s390/gnu/index.htm
 
+Some people have reported encountering "Out of memory!" errors while 
+trying to build Perl using GNU make binaries.  If you encounter such 
+trouble then try to download the source code kit and build GNU make 
+from source to eliminate any such trouble.  You might also find GNU make 
+(as well as Perl and Apache) in the red-piece/book "Open Source Software 
+for OS/390 UNIX", SG24-5944-00 from IBM.
+
+There is a syntax error in the /usr/include/sys/socket.h header file
+that IBM supplies with USS V2R7, V2R8, and possibly V2R9.  The problem with
+the header file is that near the definition of the SO_REUSEPORT constant
+there is a spurious extra '/' character outside of a comment like so:
+
+ #define SO_REUSEPORT    0x0200    /* allow local address & port
+                                      reuse */                    /
+
+You could edit that header yourself to remove that last '/', or you might 
+note that Language Environment (LE) APAR PQ39997 describes the problem 
+and PTF's UQ46272 and UQ46271 are the (R8 at least) fixes and apply them.
+If left unattended that syntax error will turn up as an inability for Perl 
+to build its "Socket" extension.
+
+For successful testing you may need to turn on the sticky bit for your 
+world readable /tmp directory if you have not already done so (see man chmod).
+
 =head2 Configure
 
 Once you've unpacked the distribution, run "sh Configure" (see INSTALL 
@@ -58,25 +86,83 @@ to watch out for include:
 
 =item *
 
+A message of the form:
+
+ (I see you are using the Korn shell.  Some ksh's blow up on Configure,
+ mainly on older exotic systems.  If yours does, try the Bourne shell instead.)
+
+is nothing to worry about at all.
+
+=item *
+
 Some of the parser default template files in /samples are needed in /etc.
 In particular be sure that you at least copy /samples/yyparse.c to /etc
-before running perl's Configure.  This step ensures successful extraction
-of EBCDIC versions of parser files such as perly.c.
+before running Perl's Configure.  This step ensures successful extraction
+of EBCDIC versions of parser files such as perly.c.  This has to be done
+before running Configure the first time.  If you failed to do so then the
+easiest way to re-Configure Perl is to delete your misconfigured build root
+and re extract the source from the tar ball.  If for some reason you do not
+want to do that then, after ensuring that /etc/yyparse.c is properly in place 
+run the following commands from within the Perl build directory:
+
+    rm -f y.tab.c y.tab.h
+    yacc -d perly.y 
+    mv -f y.tab.c perly.c
+    chmod u+w perly.c
+    sed -e '/^#include "perl\.h"/a\
+ \
+ #define yydebug    PL_yydebug\
+ #define yynerrs    PL_yynerrs\
+ #define yyerrflag  PL_yyerrflag\
+ #define yychar     PL_yychar\
+ #define yyval      PL_yyval\
+ #define yylval     PL_yylval'                           \
+            -e '/YYSTYPE *yyval;/D'                     \
+            -e '/YYSTYPE *yylval;/D'                    \
+            -e '/int  yychar,/,/yynerrs;/D'             \
+            -e 's/int yydebug = 0;/yydebug = 0;/'       \
+            -e 's/[^_]realloc(/PerlMem_realloc(/g'      \
+            -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
+            -e 's/y\.tab/perly/g' perly.c >perly.tmp
+    mv -f perly.tmp perly.c
+    mv -f y.tab.h perly.h
+    cd x2p
+    rm -f y.tab.c y.tab.h
+    yacc  a2p.y
+    mv -f y.tab.c a2p.c
+    chmod u+w a2p.c
+    sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
+                -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp
+    mv -f a2p.tmp a2p.c
+    mv -f y.tab.h a2p.h
+    cd ..
+
+There, easy huh?  If you find typing all that in difficult then perhaps
+you should reconsider the rm -rf of the perl build directory and 
+re extraction of the source tar ball.
 
 =item *
 
-This port doesn't support dynamic loading.  Although
-OS/390 has support for DLLs, there are some differences
-that cause problems for perl.
+This port doesn't support dynamic loading.  Although OS/390 has support 
+for DLLs via dllload(), there are some differences that cause problems 
+for Perl.  (We need a volunteer to write a ext/DynaLoader/dl_dllload.xs 
+file).
 
 =item *
 
-You may see a "WHOA THERE!!!" message for $d_shmatprototype
-it is OK to keep the recommended "define".
+A message of the form:
+
+ shmat() found.
+ and it returns (void *).
+ *** WHOA THERE!!! ***
+     The recommended value for $d_shmatprototype on this machine was "define"!
+     Keep the recommended value? [y]
+
+is nothing to worry about at all.
 
 =item *
 
-Don't turn on the compiler optimization flag "-O".  There's
+Do not turn on the compiler optimization flag "-O".  There is
 a bug in either the optimizer or perl that causes perl to
 not work correctly when the optimizer is on.
 
@@ -85,7 +171,7 @@ not work correctly when the optimizer is on.
 Some of the configuration files in /etc used by the
 networking APIs are either missing or have the wrong
 names.  In particular, make sure that there's either
-an /etc/resolv.conf or and /etc/hosts, so that
+an /etc/resolv.conf or an /etc/hosts, so that
 gethostbyname() works, and make sure that the file
 /etc/proto has been renamed to /etc/protocol (NOT
 /etc/protocols, as used by other Unix systems).
@@ -100,7 +186,7 @@ Simply put:
     make
     make test
 
-if everything looks ok then:
+if everything looks ok (see the next section for test/IVP diagnosis) then:
 
     make install
 
@@ -108,51 +194,168 @@ this last step may or may not require UID=0 privileges depending
 on how you answered the questions that Configure asked and whether
 or not you have write access to the directories you specified.
 
+=head2 build anomalies
+
+"Out of memory!" messages during the build of Perl are most often fixed
+by re building the GNU make utility for OS/390 from a source code kit.
+
+Another memory limiting item to check is your MAXASSIZE parameter in your
+'SYS1.PARMLIB(BPXPRMxx)' data set (note too that as of V2R8 address space
+limits can be set on a per user ID basis in the USS segment of a RACF 
+profile).  People have reported successful builds of Perl with MAXASSIZE
+parameters as small as 503316480 (and it may be possible to build Perl
+with a MAXASSIZE smaller than that).
+
+Within USS your /etc/profile or $HOME/.profile may limit your ulimit 
+settings.  Check that the following command returns reasonable values:
+
+    ulimit -a
+
+To conserve memory you should have your compiler modules loaded into the
+Link Pack Area (LPA/ELPA) rather than in a link list or step lib.
+
+If the c89 compiler complains of syntax errors during the build of the
+Socket extension then be sure to fix the syntax error in the system
+header /usr/include/sys/socket.h.
+
+=head2 testing anomalies
+
+The `make test` step runs a Perl Verification Procedure, usually before
+installation.  You might encounter STDERR messages even during a successful
+run of `make test`.  Here is a guide to some of the more commonly seen
+anomalies:
+
+=over 4
+
+=item *
+
+A message of the form:
+
+ comp/cpp.............ERROR CBC3191 ./.301989890.c:1     The character $ is not a
+  valid C source character.
+ FSUM3065 The COMPILE step ended with return code 12.
+ FSUM3017 Could not compile .301989890.c. Correct the errors and try again.
+ ok
+
+indicates that the t/comp/cpp.t test of Perl's -P command line switch has
+passed but that the particular invocation of c89 -E in the cpp script does
+not suppress the C compiler check of source code validity.
+
+=item *
+
+A message of the form:
+
+ io/openpid...........CEE5210S The signal SIGHUP was received.
+ CEE5210S The signal SIGHUP was received.
+ CEE5210S The signal SIGHUP was received.
+ ok
+
+indicates that the t/io/openpid.t test of Perl has passed but done so
+with extraneous messages on stderr from CEE.
+
+=item *
+
+A message of the form:
+
+ lib/ftmp-security....File::Temp::_gettemp: Parent directory (/tmp/) is not safe
+ (sticky bit not set when world writable?) at lib/ftmp-security.t line 100
+ File::Temp::_gettemp: Parent directory (/tmp/) is not safe (sticky bit not
+ set when world writable?) at lib/ftmp-security.t line 100
+ ok
+
+indicates a problem with the permissions on your /tmp directory within the HFS.
+To correct that problem issue the command:
+
+     chmod a+t /tmp
+
+from an account with write access to the directory entry for /tmp.
+
+=back
+
 =head2 Usage Hints
 
 When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
-character sets are different.  Perl builtin functions that may behave
-differently under EBCDIC are mentioned in the perlport.pod document.
+character sets are different.  See perlebcdic.pod for more on such character 
+set issues.  Perl builtin functions that may behave differently under 
+EBCDIC are also mentioned in the perlport.pod document.
 
-OpenEdition (UNIX System Services) does not (yet) support the #! means 
-of script invocation.
-See:
+Open Edition (UNIX System Services) from V2R8 onward does support 
+#!/path/to/perl script invocation.  There is a PTF available from 
+IBM for V2R7 that will allow shell/kernel support for #!.  USS
+releases prior to V2R7 did not support the #! means of script invocation.  
+If you are running V2R6 or earlier then see:
 
     head `whence perldoc`
 
 for an example of how to use the "eval exec" trick to ask the shell to
-have perl run your scripts for you.
+have Perl run your scripts on those older releases of Unix System Services.
+
+=head2 Modules and Extensions
+
+Pure pure (that is non xs) modules may be installed via the usual:
+
+    perl Makefile.PL
+    make
+    make test
+    make install
+
+You can also build xs based extensions to Perl for OS/390 but will need 
+to follow the instructions in ExtUtils::MakeMaker for building 
+statically linked perl binaries.  In the simplest configurations building
+a static perl + xs extension boils down to:
 
-=head2 Extensions
+    perl Makefile.PL
+    make
+    make perl
+    make test
+    make install
+    make -f Makefile.aperl inst_perl MAP_TARGET=perl
 
-You can build xs based extensions to Perl for OS/390 but will need to
-follow the instructions in ExtUtils::MakeMaker for building statically
-linked perl binaries.  In most cases people have reported better 
-results with GNU make rather than the system's /bin/make.
+In most cases people have reported better results with GNU make rather 
+than the system's /bin/make program, whether for plain modules or for
+xs based extensions.
 
 =head1 AUTHORS
 
-David Fiander and Peter Prymmer.
+David Fiander and Peter Prymmer with thanks to Dennis Longnecker
+and William Raffloer for valuable reports, LPAR and PTF feedback.
+Thanks to Mike MacIsaac and Egon Terwedow for SG24-5944-00.
 
 =head1 SEE ALSO
 
-L<INSTALL>, L<perlport>, L<ExtUtils::MakeMaker>.
+L<INSTALL>, L<perlport>, L<perlebcdic>, L<ExtUtils::MakeMaker>.
+
+    http://www.mks.com/s390/gnu/index.htm
+
+    http://www.redbooks.ibm.com/abstracts/sg245944.html
+
+    http://www.s390.ibm.com/products/oe/bpxa1ty1.html#opensrc
+
+    http://www.s390.ibm.com/products/oe/portbk/bpxacenv.html
+
+    http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/
 
 =head2 Mailing list
 
 The Perl Institute (http://www.perl.org/) maintains a perl-mvs 
 mailing list of interest to all folks building and/or
-using perl on EBCDIC platforms.  To subscribe, send a message of:
+using perl on all EBCDIC platforms (not just OS/390).  
+To subscribe, send a message of:
 
     subscribe perl-mvs
 
-to majordomo@perl.org.
+to majordomo@perl.org.  There is a web archive of the mailing list at:
+
+    http://www.xray.mpe.mpg.de/mailing-lists/perl-mvs/
 
 =head1 HISTORY
 
 This document was originally written by David Fiander for the 5.005
 release of Perl.
 
-This document was podified for the 5.005_03 release of perl 11 March 1999.
+This document was podified for the 5.005_03 release of Perl 11 March 1999.
+
+Updated 12 November 2000 for the 5.7.1 release of Perl.
 
 =cut
+
diff --git a/README.solaris b/README.solaris
new file mode 100644 (file)
index 0000000..97e84a3
--- /dev/null
@@ -0,0 +1,522 @@
+If you read this file _as_is_, just ignore the funny characters you
+see.  It is written in the POD format (see pod/perlpod.pod) which is
+specifically designed to be readable as is.
+
+=head1 NAME
+
+README.solaris - Perl version 5 on Solaris systems
+
+=head1 DESCRIPTION
+
+This document describes various features of Sun's Solaris operating system
+that will affect how Perl version 5 (hereafter just perl) is
+compiled and/or runs.  Some issues relating to the older SunOS 4.x are
+also discussed, though they may be out of date.
+
+For the most part, everything should just work.
+
+Starting with Solaris 8, perl5.00503 (or higher) is supplied with the
+operating system, so you might not even need to build a newer version
+of perl at all.  The Sun-supplied version is installed in /usr/perl5
+with /usr/bin/perl pointing to /usr/perl5/bin/perl.  Do not disturb
+that installation unless you really know what you are doing.  If you
+remove the perl supplied with the OS, there is a good chance you will
+render some bits of your system inoperable.  If you wish to install a
+newer version of perl, install it under a different prefix from
+/usr/perl5.  Common prefixes to use are /usr/local and /opt/perl.
+
+You may wish to put your version of perl in the PATH of all users by
+changing the link /usr/bin/perl. This is OK, as all Perl scripts
+shipped with Solaris use /usr/perl5/bin/perl.
+
+=head2 Solaris Version Numbers.
+
+For consistency with common usage, perl's Configure script performs
+some minor manipulations on the operating system name and version
+number as reported by uname.  Here's a partial translation table:
+
+             Sun:                      perl's Configure:
+    uname    uname -r   Name           osname     osvers
+    SunOS    4.1.3     Solaris 1.1     sunos      4.1.3
+    SunOS    5.6       Solaris 2.6     solaris    2.6
+    SunOS    5.8       Solaris 8       solaris    2.8
+
+The complete table can be found in the Sun Managers' FAQ
+L<ftp://ftp.cs.toronto.edu/pub/jdd/sun-managers/faq> under
+"9.1) Which Sun models run which versions of SunOS?".
+
+=head1 RESOURCES
+
+There are many, many source for Solaris information.  A few of the
+important ones for perl:
+
+=over 4
+
+=item Solaris FAQ
+
+The Solaris FAQ is available at
+L<http://www.science.uva.nl/pub/solaris/solaris2.html>.
+
+The Sun Managers' FAQ is available at
+L<ftp://ftp.cs.toronto.edu/pub/jdd/sun-managers/faq>
+
+=item Precompiled Binaries
+
+Precompiled binaries, links to many sites, and much, much more is
+available at L<http://www.sunfreeware.com>.
+
+=item Solaris Documentation
+
+All Solaris documentation is available on-line at L<http://docs.sun.com>.
+
+=back
+
+=head1 SETTING UP
+
+=head2 File Extraction Problems.
+
+Be sure to use a tar program compiled under Solaris (not SunOS 4.x)
+to extract the perl-5.x.x.tar.gz file.  Do not use GNU tar compiled
+for SunOS4 on Solaris.  (GNU tar compiled for Solaris should be fine.)
+When you run SunOS4 binaries on Solaris, the run-time system magically
+alters pathnames matching m#lib/locale# so that when tar tries to create
+lib/locale.pm, a file named lib/oldlocale.pm gets created instead.
+If you found this advice it too late and used a SunOS4-compiled tar
+anyway, you must find the incorrectly renamed file and move it back
+to lib/locale.pm.
+
+=head2 Compiler and Related Tools.
+
+You must use an ANSI C compiler to build perl.  Perl can be compiled
+with either Sun's add-on C compiler or with gcc.  The C compiler that
+shipped with SunOS4 will not do.
+
+=head3 Include /usr/ccs/bin/ in your PATH.
+
+Several tools needed to build perl are located in /usr/ccs/bin/:  ar,
+as, ld, and make.  Make sure that /usr/ccs/bin/ is in your PATH.
+
+You need to make sure the following packages are installed
+(this info is extracted from the Solaris FAQ):
+
+for tools (sccs, lex, yacc, make, nm, truss, ld, as): SUNWbtool,
+SUNWsprot, SUNWtoo
+
+for libraries & headers: SUNWhea, SUNWarc, SUNWlibm, SUNWlibms, SUNWdfbh,
+SUNWcg6h, SUNWxwinc, SUNWolinc
+
+for 64 bit development: SUNWarcx, SUNWbtoox, SUNWdplx, SUNWscpux,
+SUNWsprox, SUNWtoox, SUNWlmsx, SUNWlmx, SUNWlibCx
+
+If you are in doubt which package contains a file you are missing,
+try to find an installation that has that file. Then do a
+
+       grep /my/missing/file /var/sadm/install/contents
+
+This will display a line like this:
+
+/usr/include/sys/errno.h f none 0644 root bin 7471 37605 956241356 SUNWhea
+
+The last item listed (SUNWhea in this example) is the package you need.
+
+=head3 Avoid /usr/ucb/cc.
+
+You don't need to have /usr/ucb/ in your PATH to build perl.  If you
+want /usr/ucb/ in your PATH anyway, make sure that /usr/ucb/ is NOT
+in your PATH before the directory containing the right C compiler.
+
+=head3 Sun's C Compiler
+
+If you use Sun's C compiler, make sure the correct directory
+(usually /opt/SUNWspro/bin/) is in your PATH (before /usr/ucb/).
+
+=head3 GCC
+
+If you use gcc, make sure your installation is recent and
+complete.  As a point of reference, perl-5.6.0 built fine with
+gcc-2.8.1 on both Solaris 2.6 and Solaris 8.  You'll be able to
+Configure perl with
+
+       sh Configure -Dcc=gcc
+
+If you have updated your Solaris version, you may also have to update
+your GCC.  For example, if you are running Solaris 2.6 and your gcc is
+installed under /usr/local, check in /usr/local/lib/gcc-lib and make
+sure you have the appropriate directory, sparc-sun-solaris2.6/ or
+i386-pc-solaris2.6/.  If gcc's directory is for a different version of
+Solaris than you are running, then you will need to rebuild gcc for
+your new version of Solaris.
+
+You can get a precompiled version of gcc from
+L<http://www.sunfreeware.com/>. Make sure you pick up the package for
+your Solaris release.
+
+=head3 GNU as and GNU ld
+
+The versions of as and ld supplied with Solaris work fine for building
+perl.  There is normally no need to install the GNU versions.
+
+If you decide to ignore this advice and use the GNU versions anyway,
+then be sure that they are relatively recent.  Versions newer than 2.7
+are apparently new enough.  Older versions may have trouble with
+dynamic loading.
+
+If your gcc is configured to use GNU as and ld but you want to use the
+Solaris ones instead to build perl, then you'll need to add
+-B/usr/ccs/bin/ to the gcc command line.  One convenient way to do
+that is with
+
+       sh Configure -Dcc='gcc -B/usr/ccs/bin/'
+
+Note that the trailing slash is required.  This will result in some
+harmless warnings as Configure is run:
+
+       gcc: file path prefix `/usr/ccs/bin/' never used
+
+These messages may safely be ignored.
+(Note that for a SunOS4 system, you must use -B/bin/ instead.)
+
+Alternatively, you can use the GCC_EXEC_PREFIX environment variable to
+ensure that Sun's as and ld are used.  Consult your gcc documentation
+for further information on the -B option and the GCC_EXEC_PREFIX variable.
+
+=head3 GNU make
+
+Sun's make works fine for building perl.
+If you wish to use GNU make anyway, be sure that the set-group-id bit is not
+set.  If it is, then arrange your PATH so that /usr/ccs/bin/make is
+before GNU make or else have the system administrator disable the
+set-group-id bit on GNU make.
+
+=head3 Avoid libucb.
+
+Solaris provides some BSD-compatibility functions in /usr/ucblib/libucb.a.
+Perl will not build and run correctly if linked against -lucb since it
+contains routines that are incompatible with the standard Solaris libc.
+Normally this is not a problem since the solaris hints file prevents
+Configure from even looking in /usr/ucblib for libraries, and also
+explicitly omits -lucb.
+
+=head2 Environment
+
+=head3 PATH
+
+Make sure your PATH includes the compiler (/opt/SUNWspro/bin/ if you're
+using Sun's compiler) as well as /usr/ccs/bin/ to pick up the other
+development tools (such as make, ar, as, and ld).  Make sure your path
+either doesn't include /usr/ucb or that it includes it after the
+compiler and compiler tools and other standard Solaris directories.
+You definitely don't want /usr/ucb/cc.
+
+=head3 LD_LIBRARY_PATH
+
+If you have the LD_LIBRARY_PATH environment variable set, be sure that
+it does NOT include /lib or /usr/lib.  If you will be building
+extensions that call third-party shared libraries (e.g. Berkeley DB)
+then make sure that your LD_LIBRARY_PATH environment variable includes
+the directory with that library (e.g. /usr/local/lib).
+
+If you get an error message
+
+       dlopen: stub interception failed
+
+it is probably because your LD_LIBRARY_PATH environment variable
+includes a directory which is a symlink to /usr/lib (such as /lib).
+The reason this causes a problem is quite subtle.  The file
+libdl.so.1.0 actually *only* contains functions which generate 'stub
+interception failed' errors!  The runtime linker intercepts links to
+"/usr/lib/libdl.so.1.0" and links in internal implementations of those
+functions instead.  [Thanks to Tim Bunce for this explanation.]
+
+=head1 RUN CONFIGURE.
+
+See the INSTALL file for general information regarding Configure.
+Only Solaris-specific issues are discussed here.  Usually, the
+defaults should be fine.
+
+=head2 64-bit Issues.
+
+See the INSTALL file for general information regarding 64-bit compiles.
+In general, the defaults should be fine for most people.
+
+By default, perl-5.6.0 (or later) is compiled as a 32-bit application
+with largefile and long-long support.
+
+=head3 General 32-bit vs. 64-bit issues.
+
+Solaris 7 and above will run in either 32 bit or 64 bit mode on SPARC
+CPUs, via a reboot. You can build 64 bit apps whilst running 32 bit
+mode and vice-versa. 32 bit apps will run under Solaris running in
+either 32 or 64 bit mode.  64 bit apps require Solaris to be running
+64 bit mode.
+
+Existing 32 bit apps are properly known as LP32, i.e. Longs and
+Pointers are 32 bit.  64-bit apps are more properly known as LP64.
+The discriminating feature of a LP64 bit app is its ability to utilise a
+64-bit address space.  It is perfectly possible to have a LP32 bit app
+that supports both 64-bit integers (long long) and largefiles (> 2GB),
+and this is the default for perl-5.6.0.
+
+For a more complete explanation of 64-bit issues, see the Solaris 64-bit
+Developer's Guide at http://docs.sun.com:80/ab2/coll.45.13/SOL64TRANS/
+
+You can detect the OS mode using "isainfo -v", e.g.
+
+      fubar$ isainfo -v   # Ultra 30 in 64 bit mode
+      64-bit sparcv9 applications
+      32-bit sparc applications
+
+By default, perl will be compiled as a 32-bit application.  Unless you
+want to allocate more than ~ 4GB of memory inside Perl, you probably
+don't need Perl to be a 64-bit app.
+
+=head3 Large File Suppprt
+
+For Solaris 2.6 and onwards, there are two different ways for 32-bit
+applications to manipulate large files (files whose size is > 2GByte).
+(A 64-bit application automatically has largefile support built in
+by default.)
+
+First is the "transitional compilation environment", described in
+lfcompile64(5).  According to the man page,
+
+    The transitional compilation  environment  exports  all  the
+    explicit 64-bit functions (xxx64()) and types in addition to
+    all the regular functions (xxx()) and types. Both xxx()  and
+    xxx64()  functions  are  available to the program source.  A
+    32-bit application must use the xxx64() functions in  order
+    to  access  large  files.  See the lf64(5) manual page for a
+    complete listing of the 64-bit transitional interfaces.
+
+The transitional compilation environment is obtained with the
+following compiler and linker flags:
+
+    getconf LFS64_CFLAGS        -D_LARGEFILE64_SOURCE
+    getconf LFS64_LDFLAG        # nothing special needed
+    getconf LFS64_LIBS          # nothing special needed
+
+Second is the "large file compilation environment", described in
+lfcompile(5).  According to the man page,
+
+    Each interface named xxx() that needs to access 64-bit entities
+    to  access  large  files maps to a xxx64() call in the
+    resulting binary. All relevant data types are defined to  be
+    of correct size (for example, off_t has a typedef definition
+    for a 64-bit entity).
+
+    An application compiled in this environment is able  to  use
+    the  xxx()  source interfaces to access both large and small
+    files, rather than having to explicitly utilize the  transitional
+    xxx64()  interface  calls to access large files.
+
+Two exceptions are fseek() and ftell().  32-bit applications should
+use fseeko(3C) and ftello(3C).  These will get automatically mapped
+to fseeko64() and ftello64().
+
+The large file compilation environment is obtained with
+
+       getconf LFS_CFLAGS      -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64
+       getconf LFS_LDFLAGS     # nothing special needed
+       getconf LFS_LIBS        # nothing special needed
+
+By default, perl uses the large file compilation environment and
+relies on Solaris to do the underlying mapping of interfaces.
+
+=head3 Building an LP64 Perl
+
+To compile a 64-bit application on an UltraSparc with a recent Sun Compiler,
+you need to use the flag "-xarch=v9".  getconf(1) will tell you this, e.g.
+
+      fubar$ getconf -a | grep v9
+      XBS5_LP64_OFF64_CFLAGS:         -xarch=v9
+      XBS5_LP64_OFF64_LDFLAGS:        -xarch=v9
+      XBS5_LP64_OFF64_LINTFLAGS:      -xarch=v9
+      XBS5_LPBIG_OFFBIG_CFLAGS:       -xarch=v9
+      XBS5_LPBIG_OFFBIG_LDFLAGS:      -xarch=v9
+      XBS5_LPBIG_OFFBIG_LINTFLAGS:    -xarch=v9
+      _XBS5_LP64_OFF64_CFLAGS:        -xarch=v9
+      _XBS5_LP64_OFF64_LDFLAGS:       -xarch=v9
+      _XBS5_LP64_OFF64_LINTFLAGS:     -xarch=v9
+      _XBS5_LPBIG_OFFBIG_CFLAGS:      -xarch=v9
+      _XBS5_LPBIG_OFFBIG_LDFLAGS:     -xarch=v9
+      _XBS5_LPBIG_OFFBIG_LINTFLAGS:   -xarch=v9
+
+This flag is supported in Sun WorkShop Compilers 5.0 and onwards
+(now marketed under the name Forte) when used on Solaris 7 or later on
+UltraSparc systems.
+
+If you are using gcc, you would need to use -mcpu=v9 -m64 instead.  This
+option is not yet supported as of gcc 2.95.2; from install/SPECIFIC
+in that release:
+
+GCC version 2.95 is not able to compile code correctly for sparc64
+targets. Users of the Linux kernel, at least, can use the sparc32
+program to start up a new shell invocation with an environment that
+causes configure to recognize (via uname -a) the system as sparc-*-*
+instead.
+
+All this should be handled automatically by the hints file, if
+requested.
+
+If you do want to be able to allocate more than 4GB memory inside
+perl, then you should use the Solaris malloc, since the perl
+malloc breaks when dealing with more than 2GB of memory.  You can do
+this with
+
+       sh Configure -Uusemymalloc
+
+=head3 Long Doubles.
+
+As of 5.6.0, long doubles are not working.
+
+=head2 Threads.
+
+It is possible to build a threaded version of perl on Solaris.  The entire
+perl thread implementation is still experimental, however, so beware.
+Perl uses the sched_yield(3RT) function.  In versions of Solaris up
+to 2.6, that function is in -lposix4.  Starting with Solaris 7, it is
+in -lrt.  The hints file should handle adding this automatically.
+
+=head2 Malloc Issues.
+
+You should not use perl's malloc if you are building with gcc.  There
+are reports of core dumps, especially in the PDL module.  The problem
+appears to go away under -DDEBUGGING, so it has been difficult to
+track down.  Sun's compiler appears to be ok with or without perl's
+malloc. [XXX further investigation is needed here.]
+
+You should also not use perl's malloc if you are building perl as
+an LP64 application, since perl's malloc has trouble allocating more
+than 2GB of memory.
+
+You can avoid perl's malloc by Configuring with
+
+       sh Configure -Uusemymalloc
+
+[XXX Update hints file.]
+
+=head1 MAKE PROBLEMS.
+
+=over 4
+
+=item Dynamic Loading Problems With GNU as and GNU ld
+
+If you have problems with dynamic loading using gcc on SunOS or
+Solaris, and you are using GNU as and GNU ld, see the section
+L<"GNU as and GNU ld"> above.
+
+=item ld.so.1: ./perl: fatal: relocation error:
+
+If you get this message on SunOS or Solaris, and you're using gcc,
+it's probably the GNU as or GNU ld problem in the previous item
+L<"GNU as and GNU ld">.
+
+=item dlopen: stub interception failed
+
+The primary cause of the 'dlopen: stub interception failed' message is
+that the LD_LIBRARY_PATH environment variable includes a directory
+which is a symlink to /usr/lib (such as /lib).  See
+L<"LD_LIBRARY_PATH"> above.
+
+=item #error "No DATAMODEL_NATIVE specified"
+
+This is a common error when trying to build perl on Solaris 2.6 with a
+gcc installation from Solaris 2.5 or 2.5.1.  The Solaris header files
+changed, so you need to update your gcc installation.  You can either
+rerun the fixincludes script from gcc or take the opportunity to
+update your gcc installation.
+
+=item sh: ar: not found
+
+This is a message from your shell telling you that the command 'ar'
+was not found.  You need to check your PATH environment variable to
+make sure that it includes the directory with the 'ar' command.  This
+is a common problem on Solaris, where 'ar' is in the /usr/ccs/bin/
+directory.
+
+=back
+
+=head1 MAKE TEST
+
+=head2 op/stat.t test 4
+
+op/stat.t test 4 may fail if you are on a tmpfs of some sort.
+Building in /tmp sometimes shows this behavior.  The
+test suite detects if you are building in /tmp, but it may not be able
+to catch all tmpfs situations.
+
+=head1 PREBUILT BINARIES.
+
+You can pick up prebuilt binaries for Solaris from
+L<http://www.sunfreeware.com/>, ActiveState L<http://www.activestate.com/>,
+and L<http://www.perl.com/> under the Binaries list at the top of the page.
+There are probably other sources as well.  Please note that these sites
+are under the control of their respective owners, not the perl developers.
+
+=head1 RUNTIME ISSUES.
+
+=head2 Limits on Numbers of Open Files.
+
+The stdio(3C) manpage notes that only 255 files may be opened using
+fopen(), and only file descriptors 0 through 255 can be used in a
+stream.  Since perl calls open() and then fdopen(3C) with the
+resulting file descriptor, perl is limited to 255 simultaneous open
+files.
+
+=head1 SOLARIS-SPECIFIC MODULES.
+
+See the modules under the Solaris:: namespace on CPAN,
+L<http://www.cpan.org/modules/by-module/Solaris/>.
+
+=head1 SOLARIS-SPECIFIC PROBLEMS WITH MODULES.
+
+=head2 Proc::ProcessTable
+
+Proc::ProcessTable does not compile on Solaris with perl5.6.0 and higher
+if you have LARGEFILES defined.  Since largefile support is the
+default in 5.6.0 and later, you have to take special steps to use this
+module.
+
+The problem is that various structures visible via procfs use off_t,
+and if you compile with largefile support these change from 32 bits to
+64 bits.  Thus what you get back from procfs doesn't match up with
+the structures in perl, resulting in garbage.  See proc(4) for further
+discussion.
+
+A fix for Proc::ProcessTable is to edit Makefile to
+explicitly remove the largefile flags from the ones MakeMaker picks up
+from Config.pm.  This will result in Proc::ProcessTable being built
+under the correct environment.  Everything should then be OK as long as
+Proc::ProcessTable doesn't try to share off_t's with the rest of perl,
+or if it does they should be explicitly specified as off64_t.
+
+=head2 BSD::Resource
+
+BSD::Resource versions earlier than 1.09 do not compile on Solaris
+with perl 5.6.0 and higher, for the same reasons as Proc::ProcessTable.
+BSD::Resource versions starting from 1.09 have a workaround for the problem.
+
+=head2 Net::SSLeay
+
+Net::SSLeay requires a /dev/urandom to be present. This device is not
+part of Solaris. You can either get the package SUNWski (packaged with
+several Sun software products, for example the Sun WebServer, which is
+part of the Solaris Server Intranet Extension, or the Sun Directory
+Services, part of Solaris for ISPs) or download the ANDIrand package
+from L<http://www.cosy.sbg.ac.at/~andi/>. If you use SUNWski, make a
+symbolic link /dev/urandom pointing to /dev/random.
+
+It may be possible to use the Entropy Gathering Daemon (written in
+Perl!), available from L<http://www.lothar.com/tech/crypto/>.
+
+=head1 AUTHOR
+
+The original was written by Andy Dougherty F<doughera@lafayette.edu>
+drawing heavily on advice from Alan Burlison, Nick Ing-Simmons, Tim Bunce,
+and many other Solaris users over the years.
+
+Please report any errors, updates, or suggestions to F<perlbug@perl.org>.
+
+=head1 LAST MODIFIED
+
+$Id: README.solaris,v 1.4 2000/11/11 20:29:58 doughera Exp $
index 99abf0d..b44f3cf 100644 (file)
-Perl 5 README file for the Stratus VOS operating system.
-Paul Green (Paul_Green@stratus.com)
-February 3, 2000
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see pod/perlpod.pod) which is
+specially designed to be readable as is.
+
+=head1 NAME
+
+README.vos - Perl for Stratus VOS
+
+=head1 SYNOPSIS
 
+This is a port of Perl version 5, revision 7, to VOS.  Perl is a
+scripting or macro language that is popular on many systems.  See your
+local computer bookstore for a number of good books on Perl.
 
-Introduction
-------------
-This is a port of Perl version 5, revision 005-63, to VOS.  Perl
-is a scripting or macro language that is popular on many
-systems.  See your local computer bookstore for a number of good
-books on Perl.
+=head2 Stratus POSIX Support
 
-Most of the Perl features should work on VOS.  However, any
+Note that there are two different implementations of POSIX.1
+support on VOS.  There is an alpha version of POSIX that is
+available from the Stratus anonymous ftp site
+(ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html).  There
+is a generally-available version of POSIX that comes with the
+VOS Standard C compiler and C runtime in VOS Release 14.3.0 or
+higher.  This port of POSIX will compile and bind with either
+version of POSIX.
+
+Most of the Perl features should work on VOS regardless of which
+version of POSIX that you are using.  However, the alpha version
+of POSIX is missing a number of key functions, and therefore any
 attempt by perl.pm to call the following unimplemented POSIX
 functions will result in an error message and an immediate and
 fatal call to the VOS debugger.  They are "dup", "fork", and
 "waitpid".  The lack of these functions pretty much prevents you
 from starting VOS commands and grabbing their output in perl.
 The workaround is to run the commands outside of perl, then have
-perl process the output file.
+perl process the output file.  These functions are all available
+in the generally-available version of POSIX.
+
+=head1 INSTALLING PERL IN VOS
 
+=head2 Compiling Perl 5 on VOS
 
-Compiling Perl 5 on VOS
------------------------
 Before you can build Perl 5 on VOS, you need to have or acquire the
 following additional items.
 
-1.   The VOS Standard C Compiler and Runtime, or the VOS Standard C
-     Cross-Compiler.  This is a standard Stratus product.
+=over 5
+
+=item 1
+
+The VOS Standard C Compiler and Runtime, or the VOS Standard C
+Cross-Compiler.  This is a standard Stratus product.
 
-2.   The VOS OS TCP/IP product set.  While the necessary header
-     files are included with VOS POSIX.1, you still need the
-     appropriate object files in order to bind perl.pm.  This is
-     a standard Stratus product.
+=item 2
 
-3.   The VOS POSIX.1 environment.  As of this writing, this is
-     available on the VOS FTP site.  Login anonymously to
-     ftp.stratus.com and get the file
-     /pub/vos/alpha/posix.save.evf.gz in binary file-transfer
-     mode.  Or use the Uniform Resource Locator (URL)
-     ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from
-     your web browser.  This is not a standard Stratus product.
+Either the VOS OS TCP/IP or STCP product set.  If you are
+building with the alpha version of POSIX you need the OS
+TCP/IP product set.  If you are building with the
+generally-available version of POSIX you need the STCP
+product set.  These are standard Stratus products.
 
-     Instructions for unbundling this file are at
-     ftp://ftp.stratus.com/pub/vos/utility/utility.html.
+=item 3
 
-4.   You must compile this version of Perl 5 on VOS Release
-     14.1.0 or higher because some of the perl source files
-     contain more than 32,767 source lines.  Due to VOS
-     release-compatibility rules, this port of perl may not
-     execute on VOS Release 12 or earlier.
+Either the alpha or generally-available version of the VOS
+POSIX.1 environment.
+
+The alpha version of POSIX.1 support is available on the
+Stratus FTP site.  Login anonymously to ftp.stratus.com and
+get the file /pub/vos/posix/alpha/posix.save.evf.gz in
+binary file-transfer mode.  Or use the Uniform Resource
+Locator (URL)
+ftp://ftp.stratus.com/pub/vos/alpha/posix.save.evf.gz from
+your web browser.  Instructions for unbundling this file
+are at ftp://ftp.stratus.com/pub/vos/utility/utility.html.
+This is not a standard Stratus product.
+
+The generally-available version of POSIX.1 support is
+bundled with the VOS Standard C compiler and Runtime (or
+Cross-Compiler) in VOS Release 14.3.0 or higher.  This is a
+standard Stratus product.
+
+=item 4
+
+You must compile this version of Perl 5 on VOS Release
+14.1.0 or higher because some of the perl source files
+contain more than 32,767 source lines.  Due to VOS
+release-compatibility rules, this port of perl may not
+execute on VOS Release 12 or earlier.
+
+=back
 
 To build perl 5, change to the "vos" subdirectory and type the
 command "compile_perl -processor X", where X is the processor
 type (mc68020, i80860, pa7100, pa8000) that you wish to use.
+Note that the generally-available version of POSIX.1 support is
+not available for the mc68020 or i80860 processors.
+
+You must have purchased the VOS Standard C Cross Compiler in
+order to compile perl for a processor type that is different
+from the processor type of the module.
+
 Note that code compiled for the pa7100 processor type can
-execute on the PA7100, PA8000, and PA8500 processors, and that
-code compiled for the pa8000 processor type can execute on the
-PA8000 and PA8500 processors.
+execute on the PA7100, PA8000, PA8500 and PA8600 processors, and
+that code compiled for the pa8000 processor type can execute on
+the PA8000, PA8500 and PA8600 processors.
 
+=head2 Installing Perl 5 on VOS
 
-Installing Perl 5 on VOS
-------------------------
-1.   Create the directory >system>ported>command_library.
+=over 4
 
-2.   Copy the appropriate version of the perl program module to
-     this directory.  For example, with your current directory
-     set to the top-level directory of Perl 5, to install the
-     executable program module for the Motorola 68K
-     architecture, enter:
+=item 1
+
+Create the directory >system>ported>command_library.
+
+=item 2
+
+Copy the appropriate version of the perl program module to
+this directory.  For example, with your current directory
+set to the top-level directory of Perl 5, to install the
+executable program module for the Motorola 68K
+architecture, enter:
 
           !copy_file vos>obj>perl.pm >system>ported>command_library>*
 
-     (If you wish to use both Perl version 4 and Perl version 5,
-     you must give them different names; for example, perl.pm
-     and perl5.pm).
+(If you wish to use both Perl version 4 and Perl version 5,
+you must give them different names; for example, perl.pm
+and perl5.pm).
+
+=item 3
+
+Create the directory >system>ported>perl>lib.
+
+=item 4
+
+Copy all of the files and subdirectories from the lib
+subdirectory into this new directory.  For example, with
+the current directory set to the top-level directory of the
+perl distribution, enter:
+
+          !copy_dir lib >system>ported>perl>lib>5.7
 
-3.   Create the directory >system>ported>perl>lib.
+=item 5
 
-4.   Copy all of the files and subdirectories from the lib
-     subdirectory into this new directory.  For example, with
-     the current directory set to the top-level directory of the
-     perl distribution, enter:
+While there are currently no architecture-specific
+extensions or modules distributed with perl, the following
+directories can be used to hold such files:
 
-          !copy_dir lib >system>ported>perl>lib>5.005
+          >system>ported>perl>lib>5.7.68k
+          >system>ported>perl>lib>5.7.860
+          >system>ported>perl>lib>5.7.7100
+          >system>ported>perl>lib>5.7.8000
 
-5.   While there are currently no architecture-specific
-     extensions or modules distributed with perl, the following
-     directories can be used to hold such files:
+=item 6
 
-          >system>ported>perl>lib>5.005.68k
-          >system>ported>perl>lib>5.005.860
-          >system>ported>perl>lib>5.005.7100
-          >system>ported>perl>lib>5.005.8000
+Site-specific perl extensions and modules can be installed in one of
+two places.  Put architecture-independent files into:
 
-6.   Site-specific perl extensions and modules can be installed
-     in one of two places.  Put architecture-independent files
-     into:
+          >system>ported>perl>lib>site>5.7
 
-          >system>ported>perl>lib>site>5.005
+Put architecture-dependent files into one of the following
+directories:
 
-     Put architecture-dependent files into one of the following
-     directories:
+          >system>ported>perl>lib>site>5.7.68k
+          >system>ported>perl>lib>site>5.7.860
+          >system>ported>perl>lib>site>5.7.7100
+          >system>ported>perl>lib>site>5.7.8000
 
-          >system>ported>perl>lib>site>5.005.68k
-          >system>ported>perl>lib>site>5.005.860
-          >system>ported>perl>lib>site>5.005.7100
-          >system>ported>perl>lib>site>5.005.8000
+=item 7
 
-7.   You can examine the @INC variable from within a perl program
-     to see the order in which Perl searches these directories.
+You can examine the @INC variable from within a perl program
+to see the order in which Perl searches these directories.
 
+=back
 
-Unimplemented Features
-----------------------
-If Perl 5 attempts to call an unimplemented VOS POSIX.1 function,
-it will print a fatal error message and enter the VOS debugger.
-This error is not recoverable.  See vos_dummies.c for a list of
-the unimplemented POSIX.1 functions.  To see what functions are
-unimplemented and what the error message looks like, compile and
-execute "test_vos_dummies.c".
+=head1 USING PERL IN VOS
 
+=head2 Unimplemented Features
+
+If perl is built with the alpha version of VOS POSIX.1 support
+and if it attempts to call an unimplemented VOS POSIX.1
+function, it will print a fatal error message and enter the VOS
+debugger.  This error is not recoverable.  See vos_dummies.c for
+a list of the unimplemented POSIX.1 functions.  To see what
+functions are unimplemented and what the error message looks
+like, compile and execute "test_vos_dummies.c".
+
+=head2 Restrictions
 
-Restrictions
-------------
 This port of Perl version 5 to VOS prefers Unix-style,
 slash-separated pathnames over VOS-style greater-than-separated
 pathnames.  VOS-style pathnames should work in most contexts, but
@@ -139,13 +200,19 @@ supported epoch is January 1, 1980 to January 17, 2038.
 See the file pod/perlport.pod for more information about the VOS
 port of Perl.
 
+=head1 SUPPORT STATUS
 
-Support Status
---------------
 I'm offering this port "as is".  You can ask me questions, but I
-can't guarantee I'll be able to answer them; I don't know much
-about Perl itself; I'm still learning that.  There are some
+can't guarantee I'll be able to answer them.  There are some
 excellent books available on the Perl language; consult a book
 seller.
 
-(end)
+=head1 AUTHOR
+
+Paul Green (Paul_Green@stratus.com)
+
+=head1 LAST UPDATE
+
+October 24, 2000
+
+=cut
index 8e29acc..ddc1f84 100644 (file)
@@ -14,7 +14,7 @@ These are instructions for building Perl under Windows (9x, NT and
 =head1 DESCRIPTION
 
 Before you start, you should glance through the README file
-found in the top-level directory where the Perl distribution
+found in the top-level directory to which the Perl distribution
 was extracted.  Make sure you read and understand the terms under
 which this software is being distributed.
 
@@ -28,10 +28,10 @@ particular, you can safely ignore any information that talks about
 
 You may also want to look at two other options for building
 a perl that will work on Windows NT:  the README.cygwin and
-README.os2 files, which each give a different set of rules to build
-a Perl that will work on Win32 platforms.  Those two methods will
-probably enable you to build a more Unix-compatible perl, but you
-will also need to download and use various other build-time and
+README.os2 files, each of which give a different set of rules to
+build a Perl that will work on Win32 platforms.  Those two methods
+will probably enable you to build a more Unix-compatible perl, but
+you will also need to download and use various other build-time and
 run-time support software described in those files.
 
 This set of instructions is meant to describe a so-called "native"
@@ -70,9 +70,9 @@ A port of dmake for Windows is available from:
 
     http://www.cpan.org/authors/id/GSAR/dmake-4.1pl1-win32.zip
 
-(This is a fixed version of original dmake sources obtained from
+(This is a fixed version of the original dmake sources obtained from
 http://www.wticorp.com/dmake/.  As of version 4.1PL1, the original
-sources did not build as shipped, and had various other problems.
+sources did not build as shipped and had various other problems.
 A patch is included in the above fixed version.)
 
 Fetch and install dmake somewhere on your path (follow the instructions
@@ -97,20 +97,20 @@ build usually works in this circumstance, but some tests will fail.
 =item Borland C++
 
 If you are using the Borland compiler, you will need dmake.
-(The make that Borland supplies is seriously crippled, and will not
+(The make that Borland supplies is seriously crippled and will not
 work for MakeMaker builds.)
 
-See L/"Make"> above.
+See L</"Make"> above.
 
 =item Microsoft Visual C++
 
 The nmake that comes with Visual C++ will suffice for building.
-You will need to run the VCVARS32.BAT file usually found somewhere
+You will need to run the VCVARS32.BAT file, usually found somewhere
 like C:\MSDEV4.2\BIN.  This will set your build environment.
 
-You can also use dmake to build using Visual C++, provided:
+You can also use dmake to build using Visual C++; provided, however,
 you set OSRELEASE to "microsft" (or whatever the directory name
-under which the Visual C dmake configuration lives) in your environment,
+under which the Visual C dmake configuration lives) in your environment
 and edit win32/config.vc to change "make=nmake" into "make=dmake".  The
 latter step is only essential if you want to use dmake as your default
 make for building extensions using MakeMaker.
@@ -125,7 +125,7 @@ The GCC-2.95.2 bundle comes with Mingw32 libraries and headers.
 
 Make sure you install the binaries that work with MSVCRT.DLL as indicated
 in the README for the GCC bundle.  You may need to set up a few environment
-variables (usually run from a batch file).
+variables (usually ran from a batch file).
 
 The version of gcc-2.95.2-msvcrt.exe released 7 November 1999 left out
 a fix for certain command line quotes, so be sure to download and install
@@ -149,12 +149,12 @@ makefile are setup to build using the GCC compiler.
 
 =item *
 
-Edit the makefile.mk (or Makefile, if using nmake) and change the values
-of INST_DRV and INST_TOP.   You can also enable various build
-flags.  These are explained in the makefiles.
+Edit the makefile.mk (or Makefile, if you're using nmake) and change 
+the values of INST_DRV and INST_TOP.   You can also enable various
+build flags.  These are explained in the makefiles.
 
-You will have to make sure CCTYPE is set correctly, and CCHOME points
-to wherever you installed your compiler.
+You will have to make sure that CCTYPE is set correctly and that 
+CCHOME points to wherever you installed your compiler.
 
 The default value for CCHOME in the makefiles for Visual C++
 may not be correct for some versions.  Make sure the default exists
@@ -165,7 +165,7 @@ enable the appropriate option in the makefile.  des_fcrypt() is not
 bundled with the distribution due to US Government restrictions
 on the export of cryptographic software.  Nevertheless, this routine
 is part of the "libdes" library (written by Eric Young) which is widely
-available worldwide, usually along with SSLeay (for example:
+available worldwide, usually along with SSLeay (for example, 
 "ftp://fractal.mta.ca/pub/crypto/SSLeay/DES/").  Set CRYPT_SRC to the
 name of the file that implements des_fcrypt().  Alternatively, if
 you have built a library that contains des_fcrypt(), you can set
@@ -212,7 +212,7 @@ If you're using the Borland compiler, you may see a failure in op/taint.t
 arising from the inability to find the Borland Runtime DLLs on the system
 default path.  You will need to copy the DLLs reported by the messages
 from where Borland chose to install it, into the Windows system directory
-(usually somewhere like C:\WINNT\SYSTEM32), and rerun the test.
+(usually somewhere like C:\WINNT\SYSTEM32) and rerun the test.
 
 Please report any other failures as described under L<BUGS AND CAVEATS>.
 
@@ -224,7 +224,7 @@ Makefile.  It will also install the pod documentation under
 C<$INST_TOP\$VERSION\lib\pod> and HTML versions of the same under
 C<$INST_TOP\$VERSION\lib\pod\html>.  To use the Perl you just installed,
 you will need to add two components to your PATH environment variable,
-C<$INST_TOP\$VERSION\bin>, and C<$INST_TOP\$VERSION\bin\$ARCHNAME>.
+C<$INST_TOP\$VERSION\bin> and C<$INST_TOP\$VERSION\bin\$ARCHNAME>.
 For example:
 
     set PATH c:\perl\5.6.0\bin;c:\perl\5.6.0\bin\MSWin32-x86;%PATH%
@@ -301,24 +301,28 @@ runtime do any wildcard expansions of command-line arguments (so
 wildcards need not be quoted).  Also, the quoting behaviours of the
 shell and the C runtime are rudimentary at best (and may, if you are
 using a non-standard shell, be inconsistent).  The only (useful) quote
-character is the double quote (").  It can be used to protect spaces in
-arguments and other special characters.  The Windows NT documentation
-has almost no description of how the quoting rules are implemented, but
-here are some general observations based on experiments:  The C runtime
-breaks arguments at spaces and passes them to programs in argc/argv.
-Doublequotes can be used to prevent arguments with spaces in them from
-being split up.  You can put a double quote in an argument by escaping
-it with a backslash and enclosing the whole argument within double
-quotes.  The backslash and the pair of double quotes surrounding the
-argument will be stripped by the C runtime.
+character is the double quote (").  It can be used to protect spaces
+and other special characters in arguments.
+
+The Windows NT documentation has almost no description of how the
+quoting rules are implemented, but here are some general observations
+based on experiments: The C runtime breaks arguments at spaces and
+passes them to programs in argc/argv.  Double quotes can be used to
+prevent arguments with spaces in them from being split up.  You can
+put a double quote in an argument by escaping it with a backslash and
+enclosing the whole argument within double quotes.  The backslash and
+the pair of double quotes surrounding the argument will be stripped by
+the C runtime.
 
 The file redirection characters "<", ">", and "|" can be quoted by
 double quotes (although there are suggestions that this may not always
-be true).  Single quotes are not treated as quotes by the shell or the C
-runtime.  The caret "^" has also been observed to behave as a quoting
-character, but this appears to be a shell feature, and the caret is not
-stripped from the command line, so Perl still sees it (and the C runtime
-phase does not treat the caret as a quote character).
+be true).  Single quotes are not treated as quotes by the shell or
+the C runtime, they don't get stripped by the shell (just to make
+this type of quoting completely useless).  The caret "^" has also
+been observed to behave as a quoting character, but this appears
+to be a shell feature, and the caret is not stripped from the command
+line, so Perl still sees it (and the C runtime phase does not treat
+the caret as a quote character).
 
 Here are some examples of usage of the "cmd" shell:
 
@@ -386,12 +390,12 @@ be built, tested and installed with the standard mantra:
 
 where $MAKE is whatever 'make' program you have configured perl to
 use.  Use "perl -V:make" to find out what this is.  Some extensions
-may not provide a testsuite (so "$MAKE test" may not do anything, or
+may not provide a testsuite (so "$MAKE test" may not do anything or
 fail), but most serious ones do.
 
 It is important that you use a supported 'make' program, and
 ensure Config.pm knows about it.  If you don't have nmake, you can
-either get dmake from the location mentioned earlier, or get an
+either get dmake from the location mentioned earlier or get an
 old version of nmake reportedly available from:
 
     ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe
@@ -439,11 +443,11 @@ be a source of frustration if you use such a perl binary with an
 alternate shell that *does* expand wildcards.
 
 Instead, the following solution works rather well. The nice things
-about it: 1) you can start using it right away 2) it is more powerful,
-because it will do the right thing with a pattern like */*/*.c
-3) you can decide whether you do/don't want to use it 4) you can
-extend the method to add any customizations (or even entirely
-different kinds of wildcard expansion).
+about it are 1) you can start using it right away; 2) it is more 
+powerful, because it will do the right thing with a pattern like
+*/*/*.c; 3) you can decide whether you do/don't want to use it; and
+4) you can extend the method to add any customizations (or even 
+entirely different kinds of wildcard expansion).
 
        C:\> copy con c:\perl\lib\Wild.pm
        # Wild.pm - emulate shell @ARGV expansion on shells that don't
@@ -485,7 +489,7 @@ from CPAN.  You may find that many of these extensions are meant to
 be used under the Activeware port of Perl, which used to be the only
 native port for the Win32 platform.  Since the Activeware port does not
 have adequate support for Perl's extension building tools, these
-extensions typically do not support those tools either, and therefore
+extensions typically do not support those tools either and, therefore,
 cannot be built using the generic steps shown in the previous section.
 
 To ensure smooth transitioning of existing code that uses the
@@ -541,7 +545,7 @@ If you use the 4DOS/NT or similar command shell, note that
 refer to all the command line arguments, so you may need to make
 sure that construct works in batch files.  As of this writing,
 4DOS/NT users will need a "ParameterChar = *" statement in their
-4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT
+4NT.INI file or will need to execute "setdos /p*" in the 4DOS/NT
 startup file to enable this to work.
 
 =item 3
@@ -591,11 +595,25 @@ find a mailer on your system).
 
 =head1 BUGS AND CAVEATS
 
+Norton AntiVirus interferes with the build process, particularly if 
+set to "AutoProtect, All Files, when Opened". Unlike large applications 
+the perl build process opens and modifies a lot of files. Having the  
+the AntiVirus scan each and every one slows build the process significantly.
+Worse, with PERLIO=stdio the build process fails with peculiar messages
+as the virus checker interacts badly with miniperl.exe writing configure 
+files (it seems to either catch file part written and treat it as suspicious,
+or virus checker may have it "locked" in a way which inhibits miniperl
+updating it). The build does complete with 
+   
+   set PERLIO=perlio
+
+but that may be just luck. Other AntiVirus software may have similar issues.
+
 Some of the built-in functions do not act exactly as documented in
 L<perlfunc>, and a few are not implemented at all.  To avoid
 surprises, particularly if you have had prior exposure to Perl
 in other operating environments or if you intend to write code
-that will be portable to other environments, see L<perlport>
+that will be portable to other environments.  See L<perlport>
 for a reasonably definitive list of these differences.
 
 Not all extensions available from CPAN may build or work properly
@@ -620,11 +638,11 @@ by C<perl -V>.
 
 =over 4
 
-Gary Ng E<lt>71564.1743@CompuServe.COME<gt>
+=item Gary Ng E<lt>71564.1743@CompuServe.COME<gt>
 
-Gurusamy Sarathy E<lt>gsar@activestate.comE<gt>
+=item Gurusamy Sarathy E<lt>gsar@activestate.comE<gt>
 
-Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt>
+=item Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
 
 =back
 
@@ -651,6 +669,6 @@ Support for fork() emulation was added in 5.6 (ActiveState Tool Corp).
 
 Win9x support was added in 5.6 (Benjamin Stuhl).
 
-Last updated: 22 March 2000
+Last updated: 22 November 2000
 
 =cut
diff --git a/av.c b/av.c
index ef2c905..273fed9 100644 (file)
--- a/av.c
+++ b/av.c
@@ -1,6 +1,6 @@
 /*    av.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -34,10 +34,8 @@ Perl_av_reify(pTHX_ AV *av)
     while (key) {
        sv = AvARRAY(av)[--key];
        assert(sv);
-       if (sv != &PL_sv_undef) {
-           dTHR;
+       if (sv != &PL_sv_undef)
            (void)SvREFCNT_inc(sv);
-       }
     }
     key = AvARRAY(av) - AvALLOC(av);
     while (key)
@@ -58,7 +56,6 @@ extended.
 void
 Perl_av_extend(pTHX_ AV *av, I32 key)
 {
-    dTHR;                      /* only necessary if we have to extend stack */
     MAGIC *mg;
     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
        dSP;
@@ -189,7 +186,6 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 
     if (SvRMAGICAL(av)) {
        if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
-           dTHR;
            sv = sv_newmortal();
            mg_copy((SV*)av, sv, 0, key);
            PL_av_fetch_sv = sv;
@@ -272,7 +268,6 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     ary = AvARRAY(av);
     if (AvFILLp(av) < key) {
        if (!AvREAL(av)) {
-           dTHR;
            if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
                PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
            do
@@ -554,6 +549,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
     register I32 i;
     register SV **ary;
     MAGIC* mg;
+    I32 slide;
 
     if (!av || num <= 0)
        return;
@@ -591,6 +587,9 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
     }
     if (num) {
        i = AvFILLp(av);
+       /* Create extra elements */
+       slide = i > 0 ? i : 0;
+       num += slide;
        av_extend(av, i + num);
        AvFILLp(av) += num;
        ary = AvARRAY(av);
@@ -598,6 +597,10 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
        do {
            ary[--num] = &PL_sv_undef;
        } while (num);
+       /* Make extra elements into a buffer */
+       AvMAX(av) -= slide;
+       AvFILLp(av) -= slide;
+       SvPVX(av) = (char*)(AvARRAY(av) + slide);
     }
 }
 
@@ -796,9 +799,14 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
     if (SvRMAGICAL(av)) {
        if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
            SV *sv = sv_newmortal();
+           MAGIC *mg;
+
            mg_copy((SV*)av, sv, 0, key);
-           magic_existspack(sv, mg_find(sv, 'p'));
-           return SvTRUE(sv);
+           mg = mg_find(sv, 'p');
+           if (mg) {
+               magic_existspack(sv, mg);
+               return SvTRUE(sv);
+           }
        }
     }
     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
diff --git a/av.h b/av.h
index 4a18430..8f130d6 100644 (file)
--- a/av.h
+++ b/av.h
@@ -1,6 +1,6 @@
 /*    av.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 9321604..8d77620 100644 (file)
@@ -106,7 +106,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix)
 void
 byterun(pTHXo_ register struct byteloader_state *bstate)
 {
-    dTHR;
     register int insn;
     U32 ix;
     SV *specialsv_list[6];
index a209e6d..596faf9 100644 (file)
@@ -605,12 +605,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_strtol HAS_STRTOL  /**/
 
-/* HAS_STRTOUL:
- *     This symbol, if defined, indicates that the strtoul routine is
- *     available to provide conversion of strings to unsigned long.
- */
-#$d_strtoul HAS_STRTOUL        /**/
-
 /* HAS_STRXFRM:
  *     This symbol, if defined, indicates that the strxfrm() routine is
  *     available to transform strings.
@@ -981,12 +975,6 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #define SH_PATH "$sh"  /**/
 
-/* 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 $stdchar       /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
@@ -1228,6 +1216,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #define CPPRUN "$cpprun"
 #define CPPLAST "$cpplast"
 
+/* HAS__FWALK:
+ *     This symbol, if defined, indicates that the _fwalk system call is
+ *     available to apply a function to all the file handles.
+ */
+#$d__fwalk HAS__FWALK          /**/
+
 /* 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.
@@ -1325,6 +1319,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_endsent HAS_ENDSERVENT             /**/
 
+/* 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.
+ */
+#$d_fcntl_can_lock FCNTL_CAN_LOCK              /**/
+
 /* HAS_FD_SET:
  *     This symbol, when defined, indicates presence of the fd_set typedef
  *     in <sys/types.h>
@@ -1367,6 +1368,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_fstatfs 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.
+ */
+#$d_fsync HAS_FSYNC            /**/
+
 /* HAS_FTELLO:
  *     This symbol, if defined, indicates that the ftello routine is
  *     available to ftell beyond 32 bits (useful for ILP32 hosts).
@@ -1507,12 +1515,30 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_getnetprotos       HAS_GETNET_PROTOS       /**/
 
+/* 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.
+ */
+#$d_getpagsz HAS_GETPAGESIZE           /**/
+
 /* HAS_GETPROTOENT:
  *     This symbol, if defined, indicates that the getprotoent() routine is
  *     available to look up protocols in some data base or another.
  */
 #$d_getpent 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.
+ */
+#$d_getpgrp HAS_GETPGRP                /**/
+#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
+
 /* HAS_GETPROTOBYNAME:
  *     This symbol, if defined, indicates that the getprotobyname()
  *     routine is available to look up protocols by their name.
@@ -1822,6 +1848,15 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_sanemcmp HAS_SANE_MEMCMP   /**/
 
+/* 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));
+ */
+#$d_sbrkproto  HAS_SBRK_PROTO  /**/
+
 /* HAS_SEM:
  *     This symbol, if defined, indicates that the entire sem*(2) library is
  *     supported.
@@ -1859,6 +1894,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_setpent 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.
+ */
+#$d_setpgrp HAS_SETPGRP                /**/
+#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+
 /* HAS_SETPROCTITLE:
  *     This symbol, if defined, indicates that the setproctitle routine is
  *     available to set process title.
@@ -2048,12 +2095,23 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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.
+ */
 #$d_stdstdio USE_STDIO_PTR     /**/
 #ifdef USE_STDIO_PTR
 #define FILE_ptr(fp)   $stdio_ptr
 #$d_stdio_ptr_lval STDIO_PTR_LVALUE            /**/
 #define FILE_cnt(fp)   $stdio_cnt
 #$d_stdio_cnt_lval STDIO_CNT_LVALUE            /**/
+#$d_stdio_ptr_lval_sets_cnt STDIO_PTR_LVAL_SETS_CNT    /**/
+#$d_stdio_ptr_lval_nochange_cnt STDIO_PTR_LVAL_NOCHANGE_CNT    /**/
 #endif
 
 /* USE_STDIO_BASE:
@@ -2113,6 +2171,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #$d_strtoll HAS_STRTOLL                /**/
 
+/* HAS_STRTOQ:
+ *     This symbol, if defined, indicates that the strtoq routine is
+ *     available to convert strings to long longs (quads).
+ */
+#$d_strtoq HAS_STRTOQ          /**/
+
+/* HAS_STRTOUL:
+ *     This symbol, if defined, indicates that the strtoul routine is
+ *     available to provide conversion of strings to unsigned long.
+ */
+#$d_strtoul HAS_STRTOUL        /**/
+
 /* HAS_STRTOULL:
  *     This symbol, if defined, indicates that the strtoull routine is
  *     available to convert strings to unsigned long longs.
@@ -2603,6 +2673,17 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #define RD_NODATA $rd_nodata
 #$d_eofnblk EOF_NONBLOCK
 
+/* 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.
+ */
+#$need_va_copy NEED_VA_COPY            /**/
+
 /* Netdb_host_t:
  *     This symbol holds the type used for the 1st argument
  *     to gethostbyaddr().
@@ -2952,6 +3033,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  */
 #define STARTPERL "$startperl"         /**/
 
+/* 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 $stdchar       /**/
+
 /* HAS_STDIO_STREAM_ARRAY:
  *     This symbol, if defined, tells that there is an array
  *     holding the stdio streams.
@@ -3170,28 +3257,5 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #define PERL_XS_APIVERSION "$xs_apiversion"
 #define PERL_PM_APIVERSION "$pm_apiversion"
 
-/* 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.
- */
-#$d_getpgrp HAS_GETPGRP                /**/
-#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
-
-/* 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.
- */
-#$d_setpgrp HAS_SETPGRP                /**/
-#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
-
 #endif
 !GROK!THIS!
index 28ce5e8..2efd8bd 100644 (file)
@@ -53,10 +53,20 @@ $ use_two_pot_malloc = "N"
 $ use_pack_malloc = "N"
 $ use_debugmalloc = "N"
 $ ccflags = ""
+$ static_ext = ""
 $ vms_default_directory_name = F$ENVIRONMENT("DEFAULT")
 $ max_allowed_dir_depth = 3  ! e.g. [A.B.PERLxxx] not [A.B.C.PERLxxx]
 $! max_allowed_dir_depth = 2 ! e.g. [A.PERLxxx] not [A.B.PERLxxx]
 $!
+$! Sebastian Bazley's request: close the CONFIG handle with /NOLOG
+$! qualifier "just in case" (configure.com is re @ed in a bad state).
+$! This construct was tested to be not a problem as far back as
+$! VMS V5.5-2, hopefully earlier versions are OK as well.
+$!
+$ CLOSE/NOLOG CONFIG
+$!
+$! Now keep track of open files
+$!
 $ vms_filcnt = F$GETJPI ("","FILCNT")
 $!
 $!: compute my invocation name
@@ -2061,6 +2071,10 @@ $   ans = F$EDIT(ans,"TRIM,COMPRESS,LOWERCASE")
 $   IF ans.eqs."decc" then Has_Dec_C_Sockets = "T"
 $   IF ans.eqs."socketshr" then Has_socketshr = "T"
 $ ENDIF
+$ IF Has_Dec_C_Sockets .or. Has_socketshr
+$ THEN
+$   static_ext = f$edit(static_ext+" "+"Socket","trim,compress")
+$ ENDIF
 $!
 $!
 $! Ask if they want to build with VMS_DEBUG perl
@@ -2367,8 +2381,8 @@ $ echo "you might, for example, want to build GDBM_File instead of"
 $ echo "SDBM_File if you have the GDBM library built on your machine."
 $ echo ""
 $ echo "Which modules do you want to build into perl?"
-$! dflt = "Fcntl Errno File::Glob IO Opcode Byteloader Devel::Peek Devel::DProf Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File"
-$ dflt = "re Fcntl Errno File::Glob IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname"
+$! we need to add Byteloader to this list:
+$ dflt = "re Fcntl Encode Errno File::Glob Filter::Util::Call IO Opcode Devel::Peek Devel::DProf Data::Dumper attrs VMS::Stdio VMS::DCLsym B SDBM_File Storable Thread Sys::Hostname"
 $ IF Using_Dec_C .OR. using_cxx
 $ THEN
 $   dflt = dflt + " POSIX"
@@ -2594,6 +2608,39 @@ $     GOTO Clean_up
 $   ENDIF
 $ ENDIF
 $!
+$! PerlIO abstraction
+$!
+$ dflt = "n"
+$ IF F$TYPE(useperlio) .NES. ""
+$ THEN
+$   IF useperlio THEN dflt = "y"
+$   IF useperlio .EQS. "define" THEN dflt = "y"
+$ ENDIF
+$ IF .NOT. silent
+$ THEN
+$   echo "Previous version of ''package' used the standard IO mechanisms as"
+$   TYPE SYS$INPUT:
+$   DECK
+defined in <stdio.h>.  Versions 5.003_02 and later of perl allow
+alternate IO mechanisms via the PerlIO abstraction layer, but the
+stdio mechanism is still the default.  This abstraction layer can
+use AT&T's sfio (if you already have sfio installed) or regular stdio.
+Using PerlIO with sfio may cause problems with some extension modules.
+
+$   EOD
+$   echo "If this does not make any sense to you, just accept the default '" + dflt + "'."
+$ ENDIF
+$ rp = "Use the experimental PerlIO abstraction layer? [''dflt'] "
+$ GOSUB myread
+$ IF ans .EQS. "" THEN ans = dflt
+$ IF ans
+$ THEN
+$   useperlio = "define"
+$ ELSE
+$   echo "Ok, doing things the stdio way."
+$   useperlio = "undef"
+$ ENDIF
+$!
 $ echo ""
 $ echo4 "Checking the C run-time library."
 $!
@@ -2733,7 +2780,8 @@ $ ELSE d_mymalloc="undef"
 $ ENDIF
 $!
 $ usedl="define"
-$ startperl="""$ perl 'f$env(\""procedure\"")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8'  !\n$ exit++ + ++$status != 0 and $exit = $status = undef;"""
+$ startperl="""$ perl 'f$env(\""procedure\"")' \""'"+"'p1'\"" \""'"+"'p2'\"" \""'"+"'p3'\"" \""'"+"'p4'\"" \""'"+"'p5'\"" \""'"+"'p6'\"" \""'"+"'p7'\"" \""'"+"'p8'\""!\n"
+$ startperl=startperl + "$ exit++ + ++$status!=0 and $exit=$status=undef; while($#ARGV != -1 and $ARGV[$#ARGV] eq '"+"'){pop @ARGV;}"""
 $!
 $ IF ((Use_Threads) .AND. (vms_ver .LES. "6.2"))
 $ THEN
@@ -3475,6 +3523,54 @@ $ tmp = "fcntl"
 $ GOSUB inlibc
 $ d_fcntl = tmp
 $!
+$! Check for fcntl locking capability
+$!
+$ echo4 "Checking if fcntl-based file locking works... "
+$ tmp = "undef"
+$ IF d_fcntl .EQS. "define"
+$ THEN
+$   OS
+$   WS "#include <stdio.h>"
+$   WS "#if defined(__DECC) || defined(__DECCXX)"
+$   WS "#include <stdlib.h>"
+$   WS "#endif"
+$   WS "#include <fcntl.h>"
+$   WS "#include <unistd.h>"
+$   WS "int main() {"
+$   WS "#if defined(F_SETLK) && defined(F_SETLKW)"
+$   WS "     struct flock flock;"
+$   WS "     int retval, fd;"
+$   WS "     fd = open(""try.c"", O_RDONLY);"
+$   WS "     flock.l_type = F_RDLCK;"
+$   WS "     flock.l_whence = SEEK_SET;"
+$   WS "     flock.l_start = flock.l_len = 0;"
+$   WS "     retval = fcntl(fd, F_SETLK, &flock);"
+$   WS "     close(fd);"
+$   WS "     (retval < 0 ? printf(""undef\n"") : printf(""define\n""));"
+$   WS "#else"
+$   WS "     printf(""undef\n"");"
+$   WS "#endif"
+$   WS "}"
+$   CS
+$   GOSUB link_ok
+$   IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link
+$   THEN
+$     GOSUB just_mcr_it
+$     IF tmp .EQS. "define"
+$     THEN
+$       echo4 "Yes, it seems to work."
+$     ELSE
+$       echo4 "Nope, it didn't work."
+$     ENDIF
+$   ELSE
+$     echo4 "I'm unable to compile the test program, so I'll assume not."
+$     tmp = "undef"
+$   ENDIF
+$ ELSE
+$   echo4 "Nope, since you don't even have fcntl()."
+$ ENDIF
+$ d_fcntl_can_lock = tmp
+$!
 $! Check for memchr
 $!
 $ OS
@@ -3547,6 +3643,42 @@ $ tmp = "strtoll"
 $ GOSUB inlibc
 $ d_strtoll = tmp
 $!
+$! Check for strtoq
+$!
+$ OS
+$ WS "#if defined(__DECC) || defined(__DECCXX)"
+$ WS "#include <stdlib.h>"
+$ WS "#endif"
+$ WS "#include <string.h>"
+$ WS "int main()"
+$ WS "{"
+$ WS "__int64 result;"
+$ WS "result = strtoq(""123123"", NULL, 10);"
+$ WS "exit(0);"
+$ WS "}"
+$ CS
+$ tmp = "strtoq"
+$ GOSUB inlibc
+$ d_strtoq = tmp
+$!
+$! Check for strtoq
+$!
+$ OS
+$ WS "#if defined(__DECC) || defined(__DECCXX)"
+$ WS "#include <stdlib.h>"
+$ WS "#endif"
+$ WS "#include <string.h>"
+$ WS "int main()"
+$ WS "{"
+$ WS "__int64 result;"
+$ WS "result = strtoq(""123123"", NULL, 10);"
+$ WS "exit(0);"
+$ WS "}"
+$ CS
+$ tmp = "strtoq"
+$ GOSUB inlibc
+$ d_strtoq = tmp
+$!
 $! Check for strtold
 $!
 $ OS
@@ -3764,6 +3896,43 @@ $ tmp = "setvbuf"
 $ GOSUB inlibc
 $ d_setvbuf = tmp
 $!
+$! see if sfio.h is available
+$! see if sfio library is available
+$! Ok, but do we want to use it.
+$! IF F$TYPE(usesfio) .EQS. "" THEN usesfio = "undef"
+$! IF val .EQS. "define"
+$! THEN
+$!   IF usesfio .EQS. "define"
+$!   THEN dflt = "y"
+$!   ELSE dflt = "n"
+$!   ENDIF
+$!   echo "''package' can use the sfio library, but it is experimental."
+$!   IF useperlio .EQS. "undef"
+$!   THEN
+$!     echo "For sfio also the PerlIO abstraction layer is needed."
+$!     echo "Earlier you said you would not want that."
+$!   ENDIF
+$!   rp="You seem to have sfio available, do you want to try using it? [''dflt'] "
+$!   GOSUB myread
+$!   IF ans .EQS. "" THEN ans = dflt
+$!   IF ans
+$!   THEN
+$!     echo "Ok, turning on both sfio and PerlIO, then."
+$!     useperlio="define"
+$!     val="define"
+$!   ELSE
+$!     echo "Ok, avoiding sfio this time.  I'll use stdio instead."
+$!     val="undef"
+$!   ENDIF
+$! ELSE
+$!   IF usesfio .EQS. "define"
+$!   THEN
+$!     echo4 "Sorry, cannot find sfio on this machine."
+$!     echo4 "Ignoring your setting of usesfio=''usesfio'."
+$!     val="undef"
+$!   ENDIF
+$! ENDIF
+$!
 $! Check for setenv
 $!
 $ OS
@@ -4401,6 +4570,8 @@ $   i_locale="undef"
 $   d_locconv="undef"
 $   d_setlocale="undef"
 $ ENDIF
+$ d_stdio_ptr_lval_sets_cnt="undef"
+$ d_stdio_ptr_lval_nochange_cnt="undef"
 $!
 $! Sockets?
 $ if Has_Socketshr .OR. Has_Dec_C_Sockets
@@ -4691,6 +4862,7 @@ $ WC "cppminus='" + cppminus + "'"
 $ WC "cpprun='" + cpprun + "'"
 $ WC "cppstdin='" + cppstdin + "'"
 $ WC "crosscompile='undef'"
+$ WC "d__fwalk='undef'"
 $ WC "d_Gconvert='my_gconvert(x,n,t,b)'"
 $ WC "d_PRId64='" + d_PRId64 + "'"
 $ WC "d_PRIEldbl='" + d_PRIEUldbl + "'"
@@ -4750,6 +4922,7 @@ $ WC "d_eunice='undef'"
 $ WC "d_fchmod='undef'"
 $ WC "d_fchown='undef'"
 $ WC "d_fcntl='" + d_fcntl + "'"
+$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'"
 $ WC "d_fd_set='" + d_fd_set + "'"
 $ WC "d_fgetpos='define'"
 $ WC "d_flexfnam='define'"
@@ -4763,6 +4936,7 @@ $ WC "d_fseeko='undef'"
 $ WC "d_fsetpos='define'"
 $ WC "d_fstatfs='undef'"
 $ WC "d_fstatvfs='undef'"
+$ WC "d_fsync='undef'"
 $ WC "d_ftello='undef'"
 $ WC "d_getcwd='undef'"
 $ WC "d_getespwnam='undef'"
@@ -4781,6 +4955,7 @@ $ WC "d_getnbyaddr='" + d_getnbyaddr + "'"
 $ WC "d_getnbyname='" + d_getnbyname + "'"
 $ WC "d_getnent='" + d_getnent + "'"
 $ WC "d_getnetprotos='" + d_getnetprotos + "'"
+$ WC "d_getpagsz='undef'"
 $ WC "d_getpbyname='" + d_getpbyname + "'"
 $ WC "d_getpbynumber='" + d_getpbynumber + "'"
 $ WC "d_getpent='" + d_getpent + "'"
@@ -4885,6 +5060,7 @@ $ WC "d_rmdir='define'"
 $ WC "d_safebcpy='undef'"
 $ WC "d_safemcpy='define'"
 $ WC "d_sanemcmp='define'"
+$ WC "d_sbrkproto='undef'"
 $ WC "d_sched_yield='" + d_sched_yield + "'"
 $ WC "d_scm_rights='undef'"
 $ WC "d_seekdir='define'"
@@ -4934,6 +5110,8 @@ $ WC "d_statfs_s='undef'"
 $ WC "d_statfsflags='undef'"
 $ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'"
 $ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'"
+$ WC "d_stdio_ptr_lval_sets_cnt='" + d_stdio_ptr_lval_sets_cnt + "'"
+$ WC "d_stdio_ptr_lval_nochange_cnt='" + d_stdio_ptr_lval_nochange_cnt + "'"
 $ WC "d_stdio_stream_array='undef'"
 $ WC "d_stdiobase='" + d_stdiobase + "'"
 $ WC "d_stdstdio='" + d_stdstdio + "'"
@@ -4946,6 +5124,7 @@ $ WC "d_strtod='define'"
 $ WC "d_strtol='define'"
 $ WC "d_strtold='" + d_strtold + "'"
 $ WC "d_strtoll='" + d_strtoll + "'"
+$ WC "d_strtoq='define'"
 $ WC "d_strtoul='define'"
 $ WC "d_strtoull='" + d_strtoull + "'"
 $ WC "d_strtouq='" + d_strtouq + "'"
@@ -4995,6 +5174,7 @@ $ WC "drand01='" + drand01 + "'"
 $ WC "dynamic_ext='" + extensions + "'"
 $ WC "eagain=' '"
 $ WC "ebcdic='undef'"
+$ WC "embedmymalloc='" + mymalloc + "'"
 $ WC "eunicefix=':'"
 $ WC "exe_ext='" + exe_ext + "'"
 $ WC "extensions='" + extensions + "'"
@@ -5131,6 +5311,7 @@ $ WC "multiarch='undef'"
 $ WC "mydomain='" + mydomain + "'"
 $ WC "myhostname='" + myhostname + "'"
 $ WC "myuname='" + myuname + "'"
+$ WC "need_va_copy='undef'"
 $ WC "netdb_hlen_type='" + netdb_hlen_type + "'"
 $ WC "netdb_host_type='" + netdb_host_type + "'"
 $ WC "netdb_name_type='" + netdb_name_type + "'"
@@ -5213,7 +5394,7 @@ $ WC "spitshell='write sys$output '"
 $ WC "src='" + src + "'"
 $ WC "ssizetype='int'"
 $ WC "startperl=" + startperl ! This one's special--no enclosing single quotes
-$ WC "static_ext='" + "'"
+$ WC "static_ext='" + static_ext + "'"
 $ WC "stdchar='" + stdchar + "'"
 $ WC "stdio_base='((*fp)->_base)'"
 $ WC "stdio_bufsiz='((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)'"
@@ -5238,6 +5419,7 @@ $ WC "uquadtype='" + uquadtype + "'"
 $ WC "use5005threads='" + use5005threads + "'"
 $ WC "use64bitall='" + use64bitall + "'"
 $ WC "use64bitint='" + use64bitint + "'"
+$ WC "usedebugging_perl='" + use_debugging_perl + "'"
 $ WC "usedl='" + usedl + "'"
 $ WC "useithreads='" + useithreads + "'"
 $ WC "uselargefiles='" + uselargefiles + "'"
@@ -5245,7 +5427,7 @@ $ WC "uselongdouble='" + uselongdouble + "'"
 $ WC "usemorebits='" + usemorebits + "'"
 $ WC "usemultiplicity='" + usemultiplicity + "'"
 $ WC "usemymalloc='" + usemymalloc + "'"
-$ WC "useperlio='undef'"
+$ WC "useperlio='" + useperlio + "'"
 $ WC "useposix='false'"
 $ WC "usesocks='undef'"
 $ WC "usethreads='" + usethreads + "'"
diff --git a/cop.h b/cop.h
index 6e8bd91..5c3bafa 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -1,6 +1,6 @@
 /*    cop.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -21,6 +21,7 @@ struct cop {
     I32                cop_arybase;    /* array base this line was compiled with */
     line_t      cop_line;       /* line # of this command */
     SV *       cop_warnings;   /* lexical warnings bitmask */
+    SV *       cop_io;         /* lexical IO defaults */
 };
 
 #define Nullcop Null(COP*)
diff --git a/cv.h b/cv.h
index adb424e..4ade508 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -1,6 +1,6 @@
 /*    cv.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -75,6 +75,7 @@ Returns the stash of the CV.
 #define CVf_METHOD     0x0040  /* CV is explicitly marked as a method */
 #define CVf_LOCKED     0x0080  /* CV locks itself or first arg on entry */
 #define CVf_LVALUE     0x0100  /* CV return value can be used as lvalue */
+#define CVf_CONST      0x0200  /* inlinable sub */
 
 #define CvCLONE(cv)            (CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)         (CvFLAGS(cv) |= CVf_CLONE)
@@ -122,3 +123,7 @@ Returns the stash of the CV.
 #define CvSPECIAL(cv)          (CvUNIQUE(cv) && SvFAKE(cv))
 #define CvSPECIAL_on(cv)       (CvUNIQUE_on(cv),SvFAKE_on(cv))
 #define CvSPECIAL_off(cv)      (CvUNIQUE_off(cv),SvFAKE_off(cv))
+
+#define CvCONST(cv)            (CvFLAGS(cv) & CVf_CONST)
+#define CvCONST_on(cv)         (CvFLAGS(cv) |= CVf_CONST)
+#define CvCONST_off(cv)                (CvFLAGS(cv) &= ~CVf_CONST)
index db1c426..962a60a 100644 (file)
@@ -27,11 +27,9 @@ do_spawnvp (const char *path, const char * const *argv)
     childpid = spawnvp(_P_NOWAIT,path,argv);
     if (childpid < 0) {
        status = -1;
-       if(ckWARN(WARN_EXEC)) {
-           dTHR;
+       if(ckWARN(WARN_EXEC))
            Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
                    path,Strerror (errno));
-       }
     } else {
        do {
            result = wait4pid(childpid, &status, 0);
@@ -146,7 +144,7 @@ XS(Cygwin_cwd)
 
     if(items != 0)
        Perl_croak(aTHX_ "Usage: Cwd::cwd()");
-    if((cwd = getcwd(NULL, 0))) {
+    if((cwd = getcwd(NULL, -1))) {
        ST(0) = sv_2mortal(newSVpv(cwd, 0));
        safesysfree(cwd);
        XSRETURN(1);
diff --git a/deb.c b/deb.c
index 441487f..dec5c06 100644 (file)
--- a/deb.c
+++ b/deb.c
@@ -1,6 +1,6 @@
 /*    deb.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -45,7 +45,6 @@ void
 Perl_vdeb(pTHX_ const char *pat, va_list *args)
 {
 #ifdef DEBUGGING
-    dTHR;
     char* file = CopFILE(PL_curcop);
 
 #ifdef USE_THREADS
@@ -65,7 +64,6 @@ I32
 Perl_debstackptrs(pTHX)
 {
 #ifdef DEBUGGING
-    dTHR;
     PerlIO_printf(Perl_debug_log,
                  "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
                  PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
@@ -84,7 +82,6 @@ I32
 Perl_debstack(pTHX)
 {
 #ifdef DEBUGGING
-    dTHR;
     I32 top = PL_stack_sp - PL_stack_base;
     register I32 i = top - 30;
     I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
index b48774f..1bdd8ca 100644 (file)
@@ -1,5 +1,5 @@
 ln='cp'
-pager='less'
+pager='${DJDIR}/bin/less.exe'
 
 # fix extension names under DOS 
 repair()
@@ -35,7 +35,9 @@ repair()
      -e 's=File/=='\
      -e 's=glob=='\
      -e 's=Glob=='\
-     -e 's/storable/Storable/'
+     -e 's/storable/Storable/'\
+     -e 's/encode/Encode/'\
+     -e 's=filter/util/call=Filter/Util/Call='
 }
 static_ext=$(repair "$static_ext")
 extensions=$(repair "$extensions")
index 80a627e..4e390cf 100644 (file)
@@ -130,7 +130,6 @@ convretcode (pTHX_ int rc,char *prog,int fl)
 int
 do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
 {
-    dTHR;
     int  rc;
     char **a,*tmps,**argv; 
     STRLEN n_a;
diff --git a/doio.c b/doio.c
index eba2f8c..2bccc73 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1,6 +1,6 @@
 /*    doio.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #include <signal.h>
 #endif
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-#  include <unistd.h>
-#endif
-
-#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
-# include <sys/socket.h>
-# if defined(USE_SOCKS) && defined(I_SOCKS)
-#   include <socks.h>
-# endif 
-# ifdef I_NETBSD
-#  include <netdb.h>
-# endif
-# ifndef ENOTSOCK
-#  ifdef I_NET_ERRNO
-#   include <net/errno.h>
-#  endif
-# endif
-#endif
-
 bool
 Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
             int rawmode, int rawperm, PerlIO *supplied_fp)
@@ -94,9 +74,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     int result;
     bool was_fdopen = FALSE;
     bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
+    char *type  = NULL;
+    char *deftype = NULL;
+    char mode[4];              /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
 
+    Zero(mode,sizeof(mode),char);
     PL_forkprocess = 1;                /* assume true if no fork */
 
+    /* Collect default raw/crlf info from the op */
     if (PL_op && PL_op->op_type == OP_OPEN) {
        /* set up disciplines */
        U8 flags = PL_op->op_private;
@@ -106,6 +91,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        out_crlf = (flags & OPpOPEN_OUT_CRLF);
     }
 
+    /* If currently open - close before we re-open */
     if (IoIFP(io)) {
        fd = PerlIO_fileno(IoIFP(io));
        if (IoTYPE(io) == IoTYPE_STD)
@@ -136,6 +122,8 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     }
 
     if (as_raw) {
+        /* sysopen style args, i.e. integer mode and permissions */
+
 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
        rawmode |= O_LARGEFILE;
 #endif
@@ -163,78 +151,81 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        if (fd == -1)
            fp = NULL;
        else {
-           char fpmode[4];
            STRLEN ix = 0;
-           if (result == O_RDONLY)
-               fpmode[ix++] = 'r';
+           if (result == O_RDONLY) {
+               mode[ix++] = 'r';
+           }
 #ifdef O_APPEND
            else if (rawmode & O_APPEND) {
-               fpmode[ix++] = 'a';
+               mode[ix++] = 'a';
                if (result != O_WRONLY)
-                   fpmode[ix++] = '+';
+                   mode[ix++] = '+';
            }
 #endif
            else {
                if (result == O_WRONLY)
-                   fpmode[ix++] = 'w';
+                   mode[ix++] = 'w';
                else {
-                   fpmode[ix++] = 'r';
-                   fpmode[ix++] = '+';
+                   mode[ix++] = 'r';
+                   mode[ix++] = '+';
                }
            }
            if (rawmode & O_BINARY)
-               fpmode[ix++] = 'b';
-           fpmode[ix] = '\0';
-           fp = PerlIO_fdopen(fd, fpmode);
+               mode[ix++] = 'b';
+           mode[ix] = '\0';
+           fp = PerlIO_fdopen(fd, mode);
            if (!fp)
                PerlLIO_close(fd);
        }
     }
     else {
-       char *type;
+       /* Regular (non-sys) open */
        char *oname = name;
-       STRLEN tlen;
        STRLEN olen = len;
-       char mode[4];           /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
-       int dodup;
+       char *tend;
+       int dodup = 0;
 
        type = savepvn(name, len);
-       tlen = len;
+       tend = type+len;
        SAVEFREEPV(type);
+       /* Loose trailing white space */
+       while (tend > type && isSPACE(tend[-1]))
+           *tend-- = '\0';
        if (num_svs) {
+           /* New style explict name, type is just mode and discipline/layer info */
            STRLEN l;
            name = SvPV(svs, l) ;
            len = (I32)l;
            name = savepvn(name, len);
            SAVEFREEPV(name);
+           /*SUPPRESS 530*/
+           for (; isSPACE(*type); type++) ;
        }
        else {
-           while (tlen && isSPACE(type[tlen-1]))
-               type[--tlen] = '\0';
            name = type;
-           len = tlen;
+           len  = tend-type;
        }
-       mode[0] = mode[1] = mode[2] = mode[3] = '\0';
        IoTYPE(io) = *type;
-       if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */
+       if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */
            mode[1] = *type++;
-           --tlen;
            writing = 1;
        }
 
        if (*type == IoTYPE_PIPE) {
-           if (num_svs && (tlen != 2 || type[1] != IoTYPE_STD)) {
-             unknown_desr:
-               Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
+           if (num_svs) {
+               if (type[1] != IoTYPE_STD) {
+                 unknown_desr:
+                   Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
+               }
+               type++;
            }
            /*SUPPRESS 530*/
-           for (type++, tlen--; isSPACE(*type); type++, tlen--) ;
+           for (type++; isSPACE(*type); type++) ;
            if (!num_svs) {
                name = type;
-               len = tlen;
+               len = tend-type;
            }
            if (*name == '\0') { /* command is missing 19990114 */
-               dTHR;
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
                errno = EPIPE;
@@ -243,23 +234,18 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (strNE(name,"-") || num_svs)
                TAINT_ENV();
            TAINT_PROPER("piped open");
-           if (name[len-1] == '|') {
-               dTHR;
+           if (!num_svs && name[len-1] == '|') {
                name[--len] = '\0' ;
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
            }
-           {
-               char *mode;
-               if (out_raw)
-                   mode = "wb";
-               else if (out_crlf)
-                   mode = "wt";
-               else
-                   mode = "w";
-               fp = PerlProc_popen(name,mode);
-           }
+           mode[0] = 'w';
            writing = 1;
+           if (out_raw)
+               strcat(mode, "b");
+           else if (out_crlf)
+               strcat(mode, "t");
+           fp = PerlProc_popen(name,mode);
        }
        else if (*type == IoTYPE_WRONLY) {
            TAINT_PROPER("open");
@@ -268,7 +254,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
                mode[0] = IoTYPE(io) = IoTYPE_APPEND;
                type++;
-               tlen--;
            }
            else
                mode[0] = 'w';
@@ -279,11 +264,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            else if (out_crlf)
                strcat(mode, "t");
 
-           if (num_svs && tlen != 1)
-               goto unknown_desr;
            if (*type == '&') {
                name = type;
              duplicity:
+               if (num_svs)
+                   goto unknown_desr;
                dodup = 1;
                name++;
                if (*name == '=') {
@@ -355,7 +340,9 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            else {
                /*SUPPRESS 530*/
                for (; isSPACE(*type); type++) ;
-               if (*type == IoTYPE_STD && !type[1]) {
+               if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
+                   /*SUPPRESS 530*/
+                   type++;
                    fp = PerlIO_stdout();
                    IoTYPE(io) = IoTYPE_STD;
                }
@@ -365,8 +352,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
        }
        else if (*type == IoTYPE_RDONLY) {
-           if (num_svs && tlen != 1)
-               goto unknown_desr;
            /*SUPPRESS 530*/
            for (type++; isSPACE(*type); type++) ;
            mode[0] = 'r';
@@ -379,28 +364,30 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                name = type;
                goto duplicity;
            }
-           if (*type == IoTYPE_STD && !type[1]) {
+           if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
+               /*SUPPRESS 530*/
+               type++;
                fp = PerlIO_stdin();
                IoTYPE(io) = IoTYPE_STD;
            }
            else
                fp = PerlIO_open((num_svs ? name : type), mode);
        }
-       else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) {
+       else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
+                (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
            if (num_svs) {
-               if (tlen != 2 || type[0] != IoTYPE_STD)
-                   goto unknown_desr;
+               type += 2;   /* skip over '-|' */
            }
            else {
-               type[--tlen] = '\0';
-               while (tlen && isSPACE(type[tlen-1]))
-                   type[--tlen] = '\0';
+               *--tend = '\0';
+               while (tend > type && isSPACE(tend[-1]))
+                   *--tend = '\0';
                /*SUPPRESS 530*/
                for (; isSPACE(*type); type++) ;
                name = type;
+               len  = tend-type;
            }
            if (*name == '\0') { /* command is missing 19990114 */
-               dTHR;
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
                errno = EPIPE;
@@ -409,16 +396,12 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (strNE(name,"-") || num_svs)
                TAINT_ENV();
            TAINT_PROPER("piped open");
-           {
-               char *mode;
-               if (in_raw)
-                   mode = "rb";
-               else if (in_crlf)
-                   mode = "rt";
-               else
-                   mode = "r";
-               fp = PerlProc_popen(name,mode);
-           }
+           mode[0] = 'r';
+           if (in_raw)
+               strcat(mode, "b");
+           else if (in_crlf)
+               strcat(mode, "t");
+           fp = PerlProc_popen(name,mode);
            IoTYPE(io) = IoTYPE_PIPE;
        }
        else {
@@ -428,31 +411,26 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            IoTYPE(io) = IoTYPE_RDONLY;
            /*SUPPRESS 530*/
            for (; isSPACE(*name); name++) ;
+           mode[0] = 'r';
+           if (in_raw)
+               strcat(mode, "b");
+           else if (in_crlf)
+               strcat(mode, "t");
            if (strEQ(name,"-")) {
                fp = PerlIO_stdin();
                IoTYPE(io) = IoTYPE_STD;
            }
            else {
-               char *mode;
-               if (in_raw)
-                   mode = "rb";
-               else if (in_crlf)
-                   mode = "rt";
-               else
-                   mode = "r";
                fp = PerlIO_open(name,mode);
            }
        }
     }
     if (!fp) {
-       dTHR;
        if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
            Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
        goto say_false;
     }
-    if (IoTYPE(io) &&
-      IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
-       dTHR;
+    if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
        if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
            (void)PerlIO_close(fp);
            goto say_false;
@@ -480,13 +458,17 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 #endif
     }
     if (saveifp) {             /* must use old fp? */
+        /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
+           then dup the new fileno down
+         */
        fd = PerlIO_fileno(saveifp);
        if (saveofp) {
-           PerlIO_flush(saveofp);              /* emulate PerlIO_close() */
+           PerlIO_flush(saveofp);      /* emulate PerlIO_close() */
            if (saveofp != saveifp) {   /* was a socket? */
                PerlIO_close(saveofp);
+                /* This looks very suspect - NI-S 24 Nov 2000 */
                if (fd > 2)
-                   Safefree(saveofp);
+                   Safefree(saveofp);  /* ??? */
            }
        }
        if (fd != PerlIO_fileno(fp)) {
@@ -494,6 +476,15 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            SV *sv;
 
            PerlLIO_dup2(PerlIO_fileno(fp), fd);
+#ifdef VMS
+           if (fd != PerlIO_fileno(PerlIO_stdin())) {
+             char newname[FILENAME_MAX+1];
+             if (fgetname(fp, newname)) {
+               if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname);
+               if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR",  newname);
+             }
+           }
+#endif
            LOCK_FDPID_MUTEX;
            sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
            (void)SvUPGRADE(sv, SVt_IV);
@@ -519,25 +510,51 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     }
 #endif
     IoIFP(io) = fp;
+    if (!num_svs) {
+       /* Need to supply default type info from open.pm */
+       SV *layers = PL_curcop->cop_io;
+       type = NULL;
+       if (layers) {
+           STRLEN len;
+           type = SvPV(layers,len);
+           if (type && mode[0] != 'r') {
+               /* Skip to write part */
+               char *s = strchr(type,0);
+               if (s && (s-type) < len) {
+                   type = s+1;
+               }
+           }
+       }
+    }
+    if (type) {
+       while (isSPACE(*type)) type++;
+       if (*type) {
+          if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) {
+               goto say_false;
+          }
+       }
+    }
+
     IoFLAGS(io) &= ~IOf_NOLINE;
     if (writing) {
-       dTHR;
        if (IoTYPE(io) == IoTYPE_SOCKET
            || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
        {
-           char *mode;
-           if (out_raw)
-               mode = "wb";
-           else if (out_crlf)
-               mode = "wt";
-           else
-               mode = "w";
-
+           mode[0] = 'w';
            if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) {
                PerlIO_close(fp);
                IoIFP(io) = Nullfp;
                goto say_false;
            }
+           if (type && *type) {
+               if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) {
+                   PerlIO_close(IoOFP(io));
+                   PerlIO_close(fp);
+                   IoIFP(io) = Nullfp;
+                   IoOFP(io) = Nullfp;
+                   goto say_false;
+               }
+           }
        }
        else
            IoOFP(io) = fp;
@@ -583,7 +600,6 @@ Perl_nextargv(pTHX_ register GV *gv)
     }
     PL_filemode = 0;
     while (av_len(GvAV(gv)) >= 0) {
-       dTHR;
        STRLEN oldlen;
        sv = av_shift(GvAV(gv));
        SAVEFREESV(sv);
@@ -649,7 +665,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 #if !defined(DOSISH) && !defined(__CYGWIN__)
                    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
                        if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ WARN_INPLACE, 
+                           Perl_warner(aTHX_ WARN_INPLACE,
                              "Can't rename %s to %s: %s, skipping file",
                              PL_oldname, SvPVX(sv), Strerror(errno) );
                        do_close(gv,FALSE);
@@ -732,7 +748,6 @@ Perl_nextargv(pTHX_ register GV *gv)
            return IoIFP(GvIOp(gv));
        }
        else {
-           dTHR;
            if (ckWARN_d(WARN_INPLACE)) {
                int eno = errno;
                if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
@@ -827,7 +842,6 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
     io = GvIO(gv);
     if (!io) {         /* never opened */
        if (not_implicit) {
-           dTHR;
            if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
                report_evil_fh(gv, io, PL_op->op_type);
            SETERRNO(EBADF,SS$_IVCHAN);
@@ -883,7 +897,6 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
 bool
 Perl_do_eof(pTHX_ GV *gv)
 {
-    dTHR;
     register IO *io;
     int ch;
 
@@ -896,7 +909,7 @@ Perl_do_eof(pTHX_ GV *gv)
                 || IoIFP(io) == PerlIO_stderr()))
     {
        /* integrate to report_evil_fh()? */
-        char *name = NULL; 
+        char *name = NULL;
        if (isGV(gv)) {
            SV* sv = sv_newmortal();
            gv_efullname4(sv, gv, Nullch, FALSE);
@@ -922,6 +935,7 @@ Perl_do_eof(pTHX_ GV *gv)
            (void)PerlIO_ungetc(IoIFP(io),ch);
            return FALSE;
        }
+
         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
            if (PerlIO_get_cnt(IoIFP(io)) < -1)
                PerlIO_set_cnt(IoIFP(io),-1);
@@ -949,11 +963,8 @@ Perl_do_tell(pTHX_ GV *gv)
 #endif
        return PerlIO_tell(fp);
     }
-    {
-       dTHR;
-       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-           report_evil_fh(gv, io, PL_op->op_type);
-    }
+    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,RMS$_IFI);
     return (Off_t)-1;
 }
@@ -971,11 +982,8 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
 #endif
        return PerlIO_seek(fp, pos, whence) >= 0;
     }
-    {
-       dTHR;
-       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-           report_evil_fh(gv, io, PL_op->op_type);
-    }
+    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,RMS$_IFI);
     return FALSE;
 }
@@ -988,11 +996,8 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
        return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
-    {
-       dTHR;
-       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
-           report_evil_fh(gv, io, PL_op->op_type);
-    }
+    if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+       report_evil_fh(gv, io, PL_op->op_type);
     SETERRNO(EBADF,RMS$_IFI);
     return (Off_t)-1;
 }
@@ -1041,7 +1046,11 @@ fail_discipline:
                end = strchr(s+1, ':');
                if (!end)
                    end = s+len;
+#ifndef PERLIO_LAYERS
                Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
+#else
+               s = end;
+#endif
            }
        }
     }
@@ -1051,46 +1060,11 @@ fail_discipline:
 int
 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 {
-#ifdef DOSISH
-#  if defined(atarist) || defined(__MINT__)
-    if (!PerlIO_flush(fp)) {
-       if (mode & O_BINARY)
-           ((FILE*)fp)->_flag |= _IOBIN;
-       else
-           ((FILE*)fp)->_flag &= ~ _IOBIN;
-       return 1;
-    }
-    return 0;
-#  else
-    if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
-#    if defined(WIN32) && defined(__BORLANDC__)
-       /* The translation mode of the stream is maintained independent
-        * of the translation mode of the fd in the Borland RTL (heavy
-        * digging through their runtime sources reveal).  User has to
-        * set the mode explicitly for the stream (though they don't
-        * document this anywhere). GSAR 97-5-24
-        */
-       PerlIO_seek(fp,0L,0);
-       if (mode & O_BINARY)
-           ((FILE*)fp)->flags |= _F_BIN;
-       else
-           ((FILE*)fp)->flags &= ~ _F_BIN;
-#    endif
-       return 1;
-    }
-    else
-       return 0;
-#  endif
-#else
-#  if defined(USEMYBINMODE)
-    if (my_binmode(fp, iotype, mode) != FALSE)
-       return 1;
-    else
-       return 0;
-#  else
-    return 1;
-#  endif
-#endif
+ /* The old body of this is now in non-LAYER part of perlio.c
+  * This is a stub for any XS code which might have been calling it.
+  */
+ char *name = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw";
+ return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 }
 
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
@@ -1168,11 +1142,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
     }
     switch (SvTYPE(sv)) {
     case SVt_NULL:
-       {
-           dTHR;
-           if (ckWARN(WARN_UNINITIALIZED))
-               report_uninit();
-       }
+       if (ckWARN(WARN_UNINITIALIZED))
+           report_uninit();
        return TRUE;
     case SVt_IV:
        if (SvIOK(sv)) {
@@ -1186,12 +1157,14 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        }
        /* FALL THROUGH */
     default:
-#if 0
-       /* XXX Fix this when the I/O disciplines arrive. XXX */
-       if (DO_UTF8(sv))
-           sv_utf8_downgrade(sv, FALSE);
-#endif
-       tmps = SvPV(sv, len);
+       if (PerlIO_isutf8(fp)) {
+           tmps = SvPVutf8(sv, len);
+       }
+       else {
+           if (DO_UTF8(sv))
+               sv_utf8_downgrade(sv, FALSE);
+           tmps = SvPV(sv, len);
+       }
        break;
     }
     /* To detect whether the process is about to overstep its
@@ -1303,7 +1276,6 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
     STRLEN n_a;
 
     if (sp > mark) {
-       dTHR;
        New(401,PL_Argv, sp - mark + 1, char*);
        a = PL_Argv;
        while (++mark <= sp) {
@@ -1316,11 +1288,11 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
        if (*PL_Argv[0] != '/') /* will execvp use PATH? */
            TAINT_ENV();                /* testing IFS here is overkill, probably */
        if (really && *(tmps = SvPV(really, n_a)))
-           PerlProc_execvp(tmps,PL_Argv);
+           PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
        else
-           PerlProc_execvp(PL_Argv[0],PL_Argv);
+           PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
        if (ckWARN(WARN_EXEC))
-           Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
+           Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
                PL_Argv[0], Strerror(errno));
        if (do_report) {
            int e = errno;
@@ -1451,11 +1423,10 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
            goto doshell;
        }
        {
-           dTHR;
            int e = errno;
 
            if (ckWARN(WARN_EXEC))
-               Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
+               Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
                    PL_Argv[0], Strerror(errno));
            if (do_report) {
                PerlLIO_write(fd, (void*)&e, sizeof(int));
@@ -1472,7 +1443,6 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
 I32
 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
 {
-    dTHR;
     register I32 val;
     register I32 val2;
     register I32 tot = 0;
@@ -1530,7 +1500,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
        }
        break;
 #endif
-/* 
+/*
 XXX Should we make lchown() directly available from perl?
 For now, we'll let Configure test for HAS_LCHOWN, but do
 nothing in the core.
@@ -1757,7 +1727,6 @@ Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
 I32
 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
 {
-    dTHR;
     key_t key;
     I32 n, flags;
 
@@ -1790,7 +1759,6 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
 I32
 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
 {
-    dTHR;
     SV *astr;
     char *a;
     I32 id, n, cmd, infosize, getinfo;
@@ -1915,7 +1883,6 @@ I32
 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
 {
 #ifdef HAS_MSG
-    dTHR;
     SV *mstr;
     char *mbuf;
     I32 id, msize, flags;
@@ -1938,7 +1905,6 @@ I32
 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
 {
 #ifdef HAS_MSG
-    dTHR;
     SV *mstr;
     char *mbuf;
     long mtype;
@@ -1955,7 +1921,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
     flags = SvIVx(*++mark);
     SvPV_force(mstr, len);
     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
-    
+
     SETERRNO(0,0);
     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
     if (ret >= 0) {
@@ -1976,7 +1942,6 @@ I32
 Perl_do_semop(pTHX_ SV **mark, SV **sp)
 {
 #ifdef HAS_SEM
-    dTHR;
     SV *opstr;
     char *opbuf;
     I32 id;
@@ -2001,7 +1966,6 @@ I32
 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 {
 #ifdef HAS_SHM
-    dTHR;
     SV *mstr;
     char *mbuf, *shm;
     I32 id, mpos, msize;
@@ -2056,3 +2020,149 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 
 #endif /* SYSV IPC */
 
+/*
+=for apidoc start_glob
+
+Function called by C<do_readline> to spawn a glob (or do the glob inside
+perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
+this glob starter is only used by miniperl during the build proccess.
+Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
+
+=cut
+*/
+
+PerlIO *
+Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
+{
+    SV *tmpcmd = NEWSV(55, 0);
+    PerlIO *fp;
+    ENTER;
+    SAVEFREESV(tmpcmd);
+#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
+           /* since spawning off a process is a real performance hit */
+    {
+#include <descrip.h>
+#include <lib$routines.h>
+#include <nam.h>
+#include <rmsdef.h>
+       char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
+       char vmsspec[NAM$C_MAXRSS+1];
+       char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
+       char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
+       $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
+       PerlIO *tmpfp;
+       STRLEN i;
+       struct dsc$descriptor_s wilddsc
+           = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+       struct dsc$descriptor_vs rsdsc
+           = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
+       unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
+
+       /* We could find out if there's an explicit dev/dir or version
+          by peeking into lib$find_file's internal context at
+          ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
+          but that's unsupported, so I don't want to do it now and
+          have it bite someone in the future. */
+       strcat(tmpfnam,PerlLIO_tmpnam(NULL));
+       cp = SvPV(tmpglob,i);
+       for (; i; i--) {
+           if (cp[i] == ';') hasver = 1;
+           if (cp[i] == '.') {
+               if (sts) hasver = 1;
+               else sts = 1;
+           }
+           if (cp[i] == '/') {
+               hasdir = isunix = 1;
+               break;
+           }
+           if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
+               hasdir = 1;
+               break;
+           }
+       }
+       if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
+           Stat_t st;
+           if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
+               ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
+           else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
+           if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
+           while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
+                                              &dfltdsc,NULL,NULL,NULL))&1)) {
+               end = rstr + (unsigned long int) *rslt;
+               if (!hasver) while (*end != ';') end--;
+               *(end++) = '\n';  *end = '\0';
+               for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
+               if (hasdir) {
+                   if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
+                   begin = rstr;
+               }
+               else {
+                   begin = end;
+                   while (*(--begin) != ']' && *begin != '>') ;
+                   ++begin;
+               }
+               ok = (PerlIO_puts(tmpfp,begin) != EOF);
+           }
+           if (cxt) (void)lib$find_file_end(&cxt);
+           if (ok && sts != RMS$_NMF &&
+               sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
+           if (!ok) {
+               if (!(sts & 1)) {
+                   SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
+               }
+               PerlIO_close(tmpfp);
+               fp = NULL;
+           }
+           else {
+               PerlIO_rewind(tmpfp);
+               IoTYPE(io) = IoTYPE_RDONLY;
+               IoIFP(io) = fp = tmpfp;
+               IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
+           }
+       }
+    }
+#else /* !VMS */
+#ifdef MACOS_TRADITIONAL
+    sv_setpv(tmpcmd, "glob ");
+    sv_catsv(tmpcmd, tmpglob);
+    sv_catpv(tmpcmd, " |");
+#else
+#ifdef DOSISH
+#ifdef OS2
+    sv_setpv(tmpcmd, "for a in ");
+    sv_catsv(tmpcmd, tmpglob);
+    sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
+#else
+#ifdef DJGPP
+    sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
+    sv_catsv(tmpcmd, tmpglob);
+#else
+    sv_setpv(tmpcmd, "perlglob ");
+    sv_catsv(tmpcmd, tmpglob);
+    sv_catpv(tmpcmd, " |");
+#endif /* !DJGPP */
+#endif /* !OS2 */
+#else /* !DOSISH */
+#if defined(CSH)
+    sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
+    sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
+    sv_catsv(tmpcmd, tmpglob);
+    sv_catpv(tmpcmd, "' 2>/dev/null |");
+#else
+    sv_setpv(tmpcmd, "echo ");
+    sv_catsv(tmpcmd, tmpglob);
+#if 'z' - 'a' == 25
+    sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
+#else
+    sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
+#endif
+#endif /* !CSH */
+#endif /* !DOSISH */
+#endif /* MACOS_TRADITIONAL */
+    (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
+                 FALSE, O_RDONLY, 0, Nullfp);
+    fp = IoIFP(io);
+#endif /* !VMS */
+    LEAVE;
+    return fp;
+}
diff --git a/doop.c b/doop.c
index b75ffaa..3b0ddc1 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1,6 +1,6 @@
 /*    doop.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #endif
 #endif
 
-#define HALF_UTF8_UPGRADE(start,end) \
-    STMT_START {                               \
-      if ((start)<(end)) {                     \
-       U8* NeWsTr;                             \
-       STRLEN LeN = (end) - (start);           \
-       NeWsTr = bytes_to_utf8(start, &LeN);    \
-       Safefree(start);                        \
-       (start) = NeWsTr;                       \
-       (end) = (start) + LeN;                  \
-      }                                                \
-    } STMT_END
-
 STATIC I32
 S_do_trans_simple(pTHX_ SV *sv)
 {
-    dTHR;
     U8 *s;
     U8 *d;
     U8 *send;
     U8 *dstart;
     I32 matches = 0;
-    I32 sutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
     I32 ch;
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_simple");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
 
     /* First, take care of non-UTF8 input strings, because they're easy */
-    if (!sutf) {
+    if (!SvUTF8(sv)) {
        while (s < send) {
            if ((ch = tbl[*s]) >= 0) {
                matches++;
@@ -72,18 +58,15 @@ S_do_trans_simple(pTHX_ SV *sv)
     Newz(0, d, len*2+1, U8);
     dstart = d;
     while (s < send) {
-        I32 ulen;
+        STRLEN ulen;
         short c;
 
         ulen = 1;
         /* Need to check this, otherwise 128..255 won't match */
-       c = utf8_to_uv_chk(s, &ulen, 0);
+       c = utf8_to_uv(s, send - s, &ulen, 0);
         if (c < 0x100 && (ch = tbl[(short)c]) >= 0) {
             matches++;
-            if (ch < 0x80)
-                *d++ = ch;
-            else
-                d = uv_to_utf8(d,ch);
+           d = uv_to_utf8(d, ch);
             s += ulen;
         }
        else { /* No match -> copy */
@@ -92,8 +75,7 @@ S_do_trans_simple(pTHX_ SV *sv)
         }
     }
     *d = '\0';
-    sv_setpvn(sv, (const char*)dstart, d - dstart);
-    Safefree(dstart);
+    sv_setpvn(sv, (char*)dstart, d - dstart);
     SvUTF8_on(sv);
     SvSETMAGIC(sv);
     return matches;
@@ -102,37 +84,33 @@ S_do_trans_simple(pTHX_ SV *sv)
 STATIC I32
 S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
 {
-    dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
-    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_count");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
 
-    while (s < send) {
-        if (hasutf && *s & 0x80)
-            s += UTF8SKIP(s);
-        else {
-            UV c;
-            I32 ulen;
-            ulen = 1;
-            if (hasutf)
-                c = utf8_to_uv_chk(s,&ulen, 0);
-            else
-                c = *s;
-            if (c < 0x100 && tbl[c] >= 0)
+    if (!SvUTF8(sv))
+       while (s < send) {
+            if (tbl[*s++] >= 0)
                 matches++;
-            s += ulen;
-        }
-    }
+       }
+    else
+       while (s < send) {
+           UV c;
+           STRLEN ulen;
+           c = utf8_to_uv(s, send - s, &ulen, 0);
+           if (c < 0x100 && tbl[c] >= 0)
+               matches++;
+           s += ulen;
+       }
 
     return matches;
 }
@@ -140,11 +118,11 @@ S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
 STATIC I32
 S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
 {
-    dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
-    I32 hasutf = SvUTF8(sv);
+    U8 *dstart;
+    I32 isutf8;
     I32 matches = 0;
     STRLEN len;
     short *tbl;
@@ -152,66 +130,109 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       Perl_croak(aTHX_ "panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans_complex");
 
     s = (U8*)SvPV(sv, len);
+    isutf8 = SvUTF8(sv);
     send = s + len;
 
-    d = s;
-    if (PL_op->op_private & OPpTRANS_SQUASH) {
-       U8* p = send;
-
-       while (s < send) {
-            if (hasutf && *s & 0x80)
-                s += UTF8SKIP(s);
-            else {
-               if ((ch = tbl[*s]) >= 0) {
+    if (!isutf8) {
+       dstart = d = s;
+       if (PL_op->op_private & OPpTRANS_SQUASH) {
+           U8* p = send;
+           while (s < send) {
+               if ((ch = tbl[*s]) >= 0) {
                    *d = ch;
                    matches++;
-                   if (p == d - 1 && *p == *d)
-                       matches--;
-                   else
-                       p = d++;
-               }
-               else if (ch == -1)      /* -1 is unmapped character */
-                   *d++ = *s;          /* -2 is delete character */
-               s++;
-            }
+                   if (p != d - 1 || *p != *d)
+                       p = d++;
+               }
+               else if (ch == -1)      /* -1 is unmapped character */
+                   *d++ = *s;  
+               else if (ch == -2)      /* -2 is delete character */
+                   matches++;
+               s++;
+           }
        }
-    }
-    else {
-       while (s < send) {
-            if (hasutf && *s & 0x80)
-                s += UTF8SKIP(s);
-            else {
+       else {
+           while (s < send) {
                if ((ch = tbl[*s]) >= 0) {
-                   *d = ch;
                    matches++;
-                   d++;
-               }
-               else if (ch == -1)      /* -1 is unmapped character */
-                   *d++ = *s;          /* -2 is delete character */
-               s++;
-            }
+                   *d++ = ch;
+               }
+               else if (ch == -1)      /* -1 is unmapped character */
+                   *d++ = *s;
+               else if (ch == -2)      /* -2 is delete character */
+                   matches++;
+               s++;
+           }
        }
+       SvCUR_set(sv, d - dstart);
+    }
+    else { /* isutf8 */
+       Newz(0, d, len*2+1, U8);
+       dstart = d;
+
+       if (PL_op->op_private & OPpTRANS_SQUASH) {
+           U8* p = send;
+           UV pch = 0xfeedface;
+           while (s < send) {
+               STRLEN len;
+               UV comp = utf8_to_uv_simple(s, &len);
+
+               if (comp > 0xff)
+                   d = uv_to_utf8(d, comp);    /* always unmapped */
+               else if ((ch = tbl[comp]) >= 0) {
+                   matches++;
+                   if (ch != pch) {
+                       d = uv_to_utf8(d, ch);
+                       pch = ch;
+                   }
+                   s += len;
+                   continue;
+               }
+               else if (ch == -1)      /* -1 is unmapped character */
+                   d = uv_to_utf8(d, comp);
+               else if (ch == -2)      /* -2 is delete character */
+                   matches++;
+               s += len;
+               pch = 0xfeedface;
+           }
+       }
+       else {
+           while (s < send) {
+               STRLEN len;
+               UV comp = utf8_to_uv_simple(s, &len);
+               if (comp > 0xff)
+                   d = uv_to_utf8(d, comp);    /* always unmapped */
+               else if ((ch = tbl[comp]) >= 0) {
+                   d = uv_to_utf8(d, ch);
+                   matches++;
+               }
+               else if (ch == -1) {    /* -1 is unmapped character */
+                   d = uv_to_utf8(d, comp);
+               }
+               else if (ch == -2)      /* -2 is delete character */
+                   matches++;
+               s += len;
+           }
+       }
+       *d = '\0';
+       sv_setpvn(sv, (char*)dstart, d - dstart);
+       SvUTF8_on(sv);
     }
-    matches += send - d;               /* account for disappeared chars */
-    *d = '\0';
-    SvCUR_set(sv, d - (U8*)SvPVX(sv));
     SvSETMAGIC(sv);
-
     return matches;
 }
 
 STATIC I32
 S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
-    dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
     U8 *start;
-    U8 *dstart;
+    U8 *dstart, *dend;
     I32 matches = 0;
     STRLEN len;
 
@@ -222,11 +243,19 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
     UV extra = none + 1;
     UV final;
     UV uv;
-    I32 isutf;
-    I32 howmany;
+    I32 isutf8;
+    U8 hibit = 0;
 
-    isutf = SvUTF8(sv);
     s = (U8*)SvPV(sv, len);
+    isutf8 = SvUTF8(sv);
+    if (!isutf8) {
+       U8 *t = s, *e = s + len;
+       while (t < e)
+           if ((hibit = UTF8_IS_CONTINUED(*t++)))
+               break;
+       if (hibit)
+           s = bytes_to_utf8(s, &len);
+    }
     send = s + len;
     start = s;
 
@@ -235,41 +264,46 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
        final = SvUV(*svp);
 
     /* d needs to be bigger than s, in case e.g. upgrading is required */
-    Newz(0, d, len*2+1, U8);
+    New(0, d, len*3+UTF8_MAXLEN, U8);
+    dend = d + len * 3;
     dstart = d;
+
     while (s < send) {
        if ((uv = swash_fetch(rv, s)) < none) {
            s += UTF8SKIP(s);
            matches++;
-            if ((uv & 0x80) && !isutf++)
-                HALF_UTF8_UPGRADE(dstart,d);
            d = uv_to_utf8(d, uv);
        }
        else if (uv == none) {
-           int i;
-           i = UTF8SKIP(s);
-            if (i > 1 && !isutf++)
-                HALF_UTF8_UPGRADE(dstart,d);
+           int i = UTF8SKIP(s);
            while(i--)
                *d++ = *s++;
        }
        else if (uv == extra) {
-           int i;
-           i = UTF8SKIP(s);
+           int i = UTF8SKIP(s);
            s += i;
            matches++;
-            if (i > 1 && !isutf++)
-                HALF_UTF8_UPGRADE(dstart,d);
            d = uv_to_utf8(d, final);
        }
        else
            s += UTF8SKIP(s);
+
+       if (d >= dend) {
+           STRLEN clen = d - dstart;
+           STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+           Renew(dstart, nlen+UTF8_MAXLEN, U8);
+           d = dstart + clen;
+           dend = dstart + nlen;
+       }
     }
     *d = '\0';
-    sv_setpvn(sv, (const char*)dstart, d - dstart);
+    sv_setpvn(sv, (char*)dstart, d - dstart);
     SvSETMAGIC(sv);
-    if (isutf)
-        SvUTF8_on(sv);
+    SvUTF8_on(sv);
+    if (hibit)
+       Safefree(start);
+    if (!isutf8 && !(PL_hints & HINT_UTF8))
+       sv_utf8_downgrade(sv, TRUE);
 
     return matches;
 }
@@ -277,9 +311,8 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
 STATIC I32
 S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
-    dTHR;
     U8 *s;
-    U8 *send;
+    U8 *start, *send;
     I32 matches = 0;
     STRLEN len;
 
@@ -288,10 +321,17 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
     UV none = svp ? SvUV(*svp) : 0x7fffffff;
     UV uv;
+    U8 hibit = 0;
 
     s = (U8*)SvPV(sv, len);
-    if (!SvUTF8(sv))
-        s = bytes_to_utf8(s, &len);
+    if (!SvUTF8(sv)) {
+       U8 *t = s, *e = s + len;
+       while (t < e)
+           if ((hibit = !UTF8_IS_ASCII(*t++)))
+               break;
+       if (hibit)
+           start = s = bytes_to_utf8(s, &len);
+    }
     send = s + len;
 
     while (s < send) {
@@ -299,6 +339,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
            matches++;
        s += UTF8SKIP(s);
     }
+    if (hibit)
+        Safefree(start);
 
     return matches;
 }
@@ -306,9 +348,8 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
 STATIC I32
 S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 {
-    dTHR;
     U8 *s;
-    U8 *send;
+    U8 *start, *send;
     U8 *d;
     I32 matches = 0;
     I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
@@ -321,41 +362,45 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     UV final;
     UV uv;
     STRLEN len;
-    U8 *dst;
-    I32 isutf = SvUTF8(sv);
+    U8 *dstart, *dend;
+    I32 isutf8;
+    U8 hibit = 0;
 
     s = (U8*)SvPV(sv, len);
+    isutf8 = SvUTF8(sv);
+    if (!isutf8) {
+       U8 *t = s, *e = s + len;
+       while (t < e)
+           if ((hibit = !UTF8_IS_ASCII(*t++)))
+               break;
+       if (hibit)
+           s = bytes_to_utf8(s, &len);
+    }
     send = s + len;
+    start = s;
 
     svp = hv_fetch(hv, "FINAL", 5, FALSE);
     if (svp)
        final = SvUV(*svp);
 
-    Newz(0, d, len*2+1, U8);
-       dst = d;
+    New(0, d, len*3+UTF8_MAXLEN, U8);
+    dend = d + len * 3;
+    dstart = d;
 
     if (squash) {
        UV puv = 0xfeedface;
        while (s < send) {
-            if (SvUTF8(sv))
-               uv = swash_fetch(rv, s);
-           else {
-               U8 tmpbuf[2];
-               uv = *s++;
-               if (uv < 0x80)
-                   tmpbuf[0] = uv;
-               else {
-                   tmpbuf[0] = (( uv >>  6)         | 0xc0);
-                   tmpbuf[1] = (( uv        & 0x3f) | 0x80);
-               }
-               uv = swash_fetch(rv, tmpbuf);
+           uv = swash_fetch(rv, s);
+           
+           if (d >= dend) {
+               STRLEN clen = d - dstart, nlen = dend - dstart + len;
+               Renew(dstart, nlen+UTF8_MAXLEN, U8);
+               d = dstart + clen;
+               dend = dstart + nlen;
            }
-
            if (uv < none) {
                matches++;
                if (uv != puv) {
-                    if ((uv & 0x80) && !isutf++)
-                        HALF_UTF8_UPGRADE(dst,d);
                    d = uv_to_utf8(d, uv);
                    puv = uv;
                }
@@ -363,9 +408,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
                continue;
            }
            else if (uv == none) {      /* "none" is unmapped character */
-               I32 ulen;
-               *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0);
-               s += ulen;
+               int i = UTF8SKIP(s);
+               while(i--)
+                   *d++ = *s++;
                puv = 0xfeedface;
                continue;
            }
@@ -384,18 +429,12 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     }
     else {
        while (s < send) {
-            if (SvUTF8(sv))
-               uv = swash_fetch(rv, s);
-           else {
-               U8 tmpbuf[2];
-               uv = *s++;
-               if (uv < 0x80)
-                   tmpbuf[0] = uv;
-               else {
-                   tmpbuf[0] = (( uv >>  6)         | 0xc0);
-                   tmpbuf[1] = (( uv        & 0x3f) | 0x80);
-               }
-               uv = swash_fetch(rv, tmpbuf);
+           uv = swash_fetch(rv, s);
+           if (d >= dend) {
+               STRLEN clen = d - dstart, nlen = dend - dstart + len;
+               Renew(dstart, nlen+UTF8_MAXLEN, U8);
+               d = dstart + clen;
+               dend = dstart + nlen;
            }
            if (uv < none) {
                matches++;
@@ -404,9 +443,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
                continue;
            }
            else if (uv == none) {      /* "none" is unmapped character */
-               I32 ulen;
-               *d++ = (U8)utf8_to_uv_chk(s, &ulen, 0);
-               s += ulen;
+               int i = UTF8SKIP(s);
+               while(i--)
+                   *d++ = *s++;
                continue;
            }
            else if (uv == extra && !del) {
@@ -419,12 +458,13 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
            s += UTF8SKIP(s);
        }
     }
-    if (dst)
-       sv_usepvn(sv, (char*)dst, d - dst);
-    else {
-       *d = '\0';
-       SvCUR_set(sv, d - (U8*)SvPVX(sv));
-    }
+    *d = '\0';
+    sv_setpvn(sv, (char*)dstart, d - dstart);
+    SvUTF8_on(sv);
+    if (hibit)
+       Safefree(start);
+    if (!isutf8 && !(PL_hints & HINT_UTF8))
+       sv_utf8_downgrade(sv, TRUE);
     SvSETMAGIC(sv);
 
     return matches;
@@ -433,7 +473,6 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 I32
 Perl_do_trans(pTHX_ SV *sv)
 {
-    dTHR;
     STRLEN len;
     I32 hasutf = (PL_op->op_private &
                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
@@ -501,8 +540,6 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s
     }
 
     if (items-- > 0) {
-       char *s;
-
        sv_setpv(sv, "");
        if (*mark)
            sv_catsv(sv, *mark);
@@ -510,10 +547,9 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s
     }
     else
        sv_setpv(sv,"");
-    len = delimlen;
-    if (len) {
+    if (delimlen) {
        for (; items > 0; items--,mark++) {
-           sv_catpvn(sv,delim,len);
+           sv_catsv(sv,del);
            sv_catsv(sv,*mark);
        }
     }
@@ -550,9 +586,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
        Perl_croak(aTHX_ "Illegal number of bits in vec");
 
-    if (SvUTF8(sv)) {
+    if (SvUTF8(sv))
        (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
-    }
 
     offset *= size;    /* turn into bit offset */
     len = (offset + size + 7) / 8;     /* required number of bytes */
@@ -585,7 +620,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
            }
 #ifdef UV_IS_QUAD
            else if (size == 64) {
-               dTHR;
                if (ckWARN(WARN_PORTABLE))
                    Perl_warner(aTHX_ WARN_PORTABLE,
                                "Bit vector size > 32 non-portable");
@@ -655,7 +689,6 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
                      s[offset + 3];
 #ifdef UV_IS_QUAD
        else if (size == 64) {
-           dTHR;
            if (ckWARN(WARN_PORTABLE))
                Perl_warner(aTHX_ WARN_PORTABLE,
                            "Bit vector size > 32 non-portable");
@@ -743,7 +776,6 @@ Perl_do_vecset(pTHX_ SV *sv)
        }
 #ifdef UV_IS_QUAD
        else if (size == 64) {
-           dTHR;
            if (ckWARN(WARN_PORTABLE))
                Perl_warner(aTHX_ WARN_PORTABLE,
                            "Bit vector size > 32 non-portable");
@@ -766,7 +798,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 {
     STRLEN len;
     char *s;
-    dTHR;
 
     if (SvTYPE(sv) == SVt_PVAV) {
        register I32 i;
@@ -799,15 +830,15 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
            char *send = s + len;
            char *start = s;
            s = send - 1;
-           while ((*s & 0xc0) == 0x80)
-               --s;
-           if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
-               Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
-           sv_setpvn(astr, s, send - s);
-           *s = '\0';
-           SvCUR_set(sv, s - start);
-           SvNIOK_off(sv);
-           SvUTF8_on(astr);
+           while (s > start && UTF8_IS_CONTINUATION(*s))
+               s--;
+           if (utf8_to_uv_simple((U8*)s, 0)) {
+               sv_setpvn(astr, s, send - s);
+               *s = '\0';
+               SvCUR_set(sv, s - start);
+               SvNIOK_off(sv);
+               SvUTF8_on(astr);
+           }
        }
        else
            sv_setpvn(astr, "", 0);
@@ -828,7 +859,6 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 I32
 Perl_do_chomp(pTHX_ register SV *sv)
 {
-    dTHR;
     register I32 count;
     STRLEN len;
     char *s;
@@ -906,7 +936,6 @@ Perl_do_chomp(pTHX_ register SV *sv)
 void
 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 {
-    dTHR;      /* just for taint */
 #ifdef LIBERAL
     register long *dl;
     register long *ll;
@@ -927,7 +956,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 
     if (left_utf && !right_utf)
        sv_utf8_upgrade(right);
-    if (!left_utf && right_utf)
+    else if (!left_utf && right_utf)
        sv_utf8_upgrade(left);
 
     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
@@ -964,15 +993,15 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
        char *dcsave = dc;
        STRLEN lulen = leftlen;
        STRLEN rulen = rightlen;
-       I32 ulen;
+       STRLEN ulen;
 
        switch (optype) {
        case OP_BIT_AND:
            while (lulen && rulen) {
-               luc = utf8_to_uv_chk((U8*)lc, &ulen, 0);
+               luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
                lc += ulen;
                lulen -= ulen;
-               ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0);
+               ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
                rc += ulen;
                rulen -= ulen;
                duc = luc & ruc;
@@ -984,10 +1013,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
            break;
        case OP_BIT_XOR:
            while (lulen && rulen) {
-               luc = utf8_to_uv_chk((U8*)lc, &ulen, 0);
+               luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
                lc += ulen;
                lulen -= ulen;
-               ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0);
+               ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
                rc += ulen;
                rulen -= ulen;
                duc = luc ^ ruc;
@@ -996,10 +1025,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
            goto mop_up_utf;
        case OP_BIT_OR:
            while (lulen && rulen) {
-               luc = utf8_to_uv_chk((U8*)lc, &ulen, 0);
+               luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
                lc += ulen;
                lulen -= ulen;
-               ruc = utf8_to_uv_chk((U8*)rc, &ulen, 0);
+               ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
                rc += ulen;
                rulen -= ulen;
                duc = luc | ruc;
diff --git a/dump.c b/dump.c
index ad0a21f..5bc7349 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1,6 +1,6 @@
 /*    dump.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -29,7 +29,6 @@ Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
 void
 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 {
-    dTHR;
     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
     PerlIO_vprintf(file, pat, *args);
 }
@@ -37,7 +36,6 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 void
 Perl_dump_all(pTHX)
 {
-    dTHR;
     PerlIO_setlinebuf(Perl_debug_log);
     if (PL_main_root)
        op_dump(PL_main_root);
@@ -47,7 +45,6 @@ Perl_dump_all(pTHX)
 void
 Perl_dump_packsubs(pTHX_ HV *stash)
 {
-    dTHR;
     I32        i;
     HE *entry;
 
@@ -275,6 +272,8 @@ Perl_sv_peek(pTHX_ SV *sv)
            if (SvOOK(sv))
                Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
            Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX(sv), SvCUR(sv), SvLEN(sv), 127));
+           if (SvUTF8(sv))
+               Perl_sv_catpvf(aTHX_ t, " [UTF8]"); 
            SvREFCNT_dec(tmp);
        }
     }
@@ -369,7 +368,6 @@ Perl_pmop_dump(pTHX_ PMOP *pm)
 void
 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 {
-    dTHR;
     Perl_dump_indent(aTHX_ level, file, "{\n");
     level++;
     if (o->op_seq)
@@ -457,6 +455,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        }
        else if (o->op_type == OP_ENTERSUB ||
                 o->op_type == OP_RV2SV ||
+                o->op_type == OP_GVSV ||
                 o->op_type == OP_RV2AV ||
                 o->op_type == OP_RV2HV ||
                 o->op_type == OP_RV2GV ||
@@ -768,7 +767,6 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
 void
 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
 {
-    dTHR;
     SV *d;
     char *s;
     U32 flags;
@@ -822,6 +820,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
        if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
        if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
+       if (CvCONST(sv))        sv_catpv(d, "CONST,");
        if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
        if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
        break;
index 383d164..ff16b03 100644 (file)
@@ -7083,7 +7083,6 @@ Currently it is tuned to C and Perl syntax."
              found-bad found)))
     (not not-found)))
 
-\ 6
 ;;; Getting help
 (defvar cperl-have-help-regexp 
   ;;(concat "\\("
index 54770a0..1054ac1 100755 (executable)
@@ -21,7 +21,7 @@ if test ! -z "$OS2_SHELL"; then alias find=gnufind; fi
 # Move autogenerated less-informative files to the end:
 # Hard to do embed.h and embedvar.h in one sweep:
 
-topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ /  /g' | sed 's/ embedvar\.h\|embed\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`"
+topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ /  /g' | sed 's/ embedvar\.h\|embed\.h\|perlapi\.h\|obj\(pp\|XSUB\)\.h\|\(globals\|perlapi\)\.c / /g'`"
 subdirs="`find ./* -maxdepth 0 -type d`"
 subdirfiles="`find $subdirs -name '*.[cy]' -print | sort`"
 subdirfiles1="`find $subdirs -name '*.[hH]' -print | sort`"
@@ -99,7 +99,7 @@ perl -w014pe 'if (s/^(S_              # 1:   First group
              }' TAGS.tmp > TAGS.tm1 && mv TAGS.tm1 TAGS.tmp
 
 etags -o TAGS.tmp -a -D -l none -r '/#define.*\t\(Perl_.*\)/\1/' embed.h
-etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c
+etags -o TAGS.tmp -a globals.c embedvar.h objXSUB.h perlapi.c perlapi.h
 
 # The above processes created a lot of descriptions with an
 # an explicitly specified tag.  Such descriptions have higher
diff --git a/embed.h b/embed.h
index 50a9d9e..414a642 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -68,6 +68,7 @@
 #endif
 #define amagic_call            Perl_amagic_call
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#define gv_handler             Perl_gv_handler
 #define append_elem            Perl_append_elem
 #define append_list            Perl_append_list
 #define apply                  Perl_apply
 #define ref                    Perl_ref
 #define refkids                        Perl_refkids
 #define regdump                        Perl_regdump
+#define regclass_swash         Perl_regclass_swash
 #define pregexec               Perl_pregexec
 #define pregfree               Perl_pregfree
 #define pregcomp               Perl_pregcomp
 #define save_pptr              Perl_save_pptr
 #define save_vptr              Perl_save_vptr
 #define save_re_context                Perl_save_re_context
+#define save_padsv             Perl_save_padsv
 #define save_sptr              Perl_save_sptr
 #define save_svref             Perl_save_svref
 #define save_threadsv          Perl_save_threadsv
 #define sv_tainted             Perl_sv_tainted
 #define sv_unmagic             Perl_sv_unmagic
 #define sv_unref               Perl_sv_unref
+#define sv_unref_flags         Perl_sv_unref_flags
 #define sv_untaint             Perl_sv_untaint
 #define sv_upgrade             Perl_sv_upgrade
 #define sv_usepvn              Perl_sv_usepvn
 #define utilize                        Perl_utilize
 #define utf16_to_utf8          Perl_utf16_to_utf8
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define utf8_length            Perl_utf8_length
 #define utf8_distance          Perl_utf8_distance
 #define utf8_hop               Perl_utf8_hop
 #define utf8_to_bytes          Perl_utf8_to_bytes
 #define bytes_to_utf8          Perl_bytes_to_utf8
+#define utf8_to_uv_simple      Perl_utf8_to_uv_simple
 #define utf8_to_uv             Perl_utf8_to_uv
-#define utf8_to_uv_chk         Perl_utf8_to_uv_chk
 #define uv_to_utf8             Perl_uv_to_utf8
 #define vivify_defelem         Perl_vivify_defelem
 #define vivify_ref             Perl_vivify_ref
 #define watch                  Perl_watch
 #define whichsig               Perl_whichsig
 #define yyerror                        Perl_yyerror
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
+#define yylex_r                        Perl_yylex_r
 #define yylex                  Perl_yylex
 #else
 #define yylex                  Perl_yylex
 #define sv_utf8_encode         Perl_sv_utf8_encode
 #define sv_utf8_decode         Perl_sv_utf8_decode
 #define sv_force_normal                Perl_sv_force_normal
+#define sv_force_normal_flags  Perl_sv_force_normal_flags
 #define tmps_grow              Perl_tmps_grow
 #define sv_rvweaken            Perl_sv_rvweaken
 #define magic_killbackrefs     Perl_magic_killbackrefs
 #define regbranch              S_regbranch
 #define reguni                 S_reguni
 #define regclass               S_regclass
-#define regclassutf8           S_regclassutf8
 #define regcurly               S_regcurly
 #define reg_node               S_reg_node
 #define regpiece               S_regpiece
 #define regrepeat_hard         S_regrepeat_hard
 #define regtry                 S_regtry
 #define reginclass             S_reginclass
-#define reginclassutf8         S_reginclassutf8
 #define regcppush              S_regcppush
 #define regcppop               S_regcppop
 #define regcp_set_to           S_regcp_set_to
 #define cache_re               S_cache_re
 #define reghop                 S_reghop
+#define reghop3                        S_reghop3
 #define reghopmaybe            S_reghopmaybe
+#define reghopmaybe3           S_reghopmaybe3
 #define find_byclass           S_find_byclass
 #endif
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
 #  if defined(DEBUGGING)
 #define del_sv                 S_del_sv
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+#define sv_2inuv_non_preserve  S_sv_2inuv_non_preserve
+#define sv_2iuv_non_preserve   S_sv_2iuv_non_preserve
+#  endif
 #endif
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
 #define check_uni              S_check_uni
 #define isa_lookup             S_isa_lookup
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define stdize_locale          S_stdize_locale
 #define mess_alloc             S_mess_alloc
 #  if defined(LEAKTEST)
 #define xstat                  S_xstat
 #endif
 #define amagic_call(a,b,c,d)   Perl_amagic_call(aTHX_ a,b,c,d)
 #define Gv_AMupdate(a)         Perl_Gv_AMupdate(aTHX_ a)
+#define gv_handler(a,b)                Perl_gv_handler(aTHX_ a,b)
 #define append_elem(a,b,c)     Perl_append_elem(aTHX_ a,b,c)
 #define append_list(a,b,c)     Perl_append_list(aTHX_ a,b,c)
 #define apply(a,b,c)           Perl_apply(aTHX_ a,b,c)
 #define ref(a,b)               Perl_ref(aTHX_ a,b)
 #define refkids(a,b)           Perl_refkids(aTHX_ a,b)
 #define regdump(a)             Perl_regdump(aTHX_ a)
+#define regclass_swash(a,b,c)  Perl_regclass_swash(aTHX_ a,b,c)
 #define pregexec(a,b,c,d,e,f,g)        Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
 #define pregfree(a)            Perl_pregfree(aTHX_ a)
 #define pregcomp(a,b,c)                Perl_pregcomp(aTHX_ a,b,c)
 #define save_pptr(a)           Perl_save_pptr(aTHX_ a)
 #define save_vptr(a)           Perl_save_vptr(aTHX_ a)
 #define save_re_context()      Perl_save_re_context(aTHX)
+#define save_padsv(a)          Perl_save_padsv(aTHX_ a)
 #define save_sptr(a)           Perl_save_sptr(aTHX_ a)
 #define save_svref(a)          Perl_save_svref(aTHX_ a)
 #define save_threadsv(a)       Perl_save_threadsv(aTHX_ a)
 #define scalarvoid(a)          Perl_scalarvoid(aTHX_ a)
 #define scan_bin(a,b,c)                Perl_scan_bin(aTHX_ a,b,c)
 #define scan_hex(a,b,c)                Perl_scan_hex(aTHX_ a,b,c)
-#define scan_num(a)            Perl_scan_num(aTHX_ a)
+#define scan_num(a,b)          Perl_scan_num(aTHX_ a,b)
 #define scan_oct(a,b,c)                Perl_scan_oct(aTHX_ a,b,c)
 #define scope(a)               Perl_scope(aTHX_ a)
 #define screaminstr(a,b,c,d,e,f)       Perl_screaminstr(aTHX_ a,b,c,d,e,f)
 #define sv_tainted(a)          Perl_sv_tainted(aTHX_ a)
 #define sv_unmagic(a,b)                Perl_sv_unmagic(aTHX_ a,b)
 #define sv_unref(a)            Perl_sv_unref(aTHX_ a)
+#define sv_unref_flags(a,b)    Perl_sv_unref_flags(aTHX_ a,b)
 #define sv_untaint(a)          Perl_sv_untaint(aTHX_ a)
 #define sv_upgrade(a,b)                Perl_sv_upgrade(aTHX_ a,b)
 #define sv_usepvn(a,b,c)       Perl_sv_usepvn(aTHX_ a,b,c)
 #define utilize(a,b,c,d,e)     Perl_utilize(aTHX_ a,b,c,d,e)
 #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d)
 #define utf16_to_utf8_reversed(a,b,c,d)        Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d)
+#define utf8_length(a,b)       Perl_utf8_length(aTHX_ a,b)
 #define utf8_distance(a,b)     Perl_utf8_distance(aTHX_ a,b)
 #define utf8_hop(a,b)          Perl_utf8_hop(aTHX_ a,b)
 #define utf8_to_bytes(a,b)     Perl_utf8_to_bytes(aTHX_ a,b)
 #define bytes_to_utf8(a,b)     Perl_bytes_to_utf8(aTHX_ a,b)
-#define utf8_to_uv(a,b)                Perl_utf8_to_uv(aTHX_ a,b)
-#define utf8_to_uv_chk(a,b,c)  Perl_utf8_to_uv_chk(aTHX_ a,b,c)
+#define utf8_to_uv_simple(a,b) Perl_utf8_to_uv_simple(aTHX_ a,b)
+#define utf8_to_uv(a,b,c,d)    Perl_utf8_to_uv(aTHX_ a,b,c,d)
 #define uv_to_utf8(a,b)                Perl_uv_to_utf8(aTHX_ a,b)
 #define vivify_defelem(a)      Perl_vivify_defelem(aTHX_ a)
 #define vivify_ref(a,b)                Perl_vivify_ref(aTHX_ a,b)
 #define watch(a)               Perl_watch(aTHX_ a)
 #define whichsig(a)            Perl_whichsig(aTHX_ a)
 #define yyerror(a)             Perl_yyerror(aTHX_ a)
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
+#define yylex_r(a,b)           Perl_yylex_r(aTHX_ a,b)
 #define yylex(a,b)             Perl_yylex(aTHX_ a,b)
 #else
 #define yylex()                        Perl_yylex(aTHX)
 #define sv_utf8_encode(a)      Perl_sv_utf8_encode(aTHX_ a)
 #define sv_utf8_decode(a)      Perl_sv_utf8_decode(aTHX_ a)
 #define sv_force_normal(a)     Perl_sv_force_normal(aTHX_ a)
+#define sv_force_normal_flags(a,b)     Perl_sv_force_normal_flags(aTHX_ a,b)
 #define tmps_grow(a)           Perl_tmps_grow(aTHX_ a)
 #define sv_rvweaken(a)         Perl_sv_rvweaken(aTHX_ a)
 #define magic_killbackrefs(a,b)        Perl_magic_killbackrefs(aTHX_ a,b)
 #  endif
 #endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
-#define reg(a,b)               S_reg(aTHX_ a,b)
-#define reganode(a,b)          S_reganode(aTHX_ a,b)
-#define regatom(a)             S_regatom(aTHX_ a)
-#define regbranch(a,b)         S_regbranch(aTHX_ a,b)
-#define reguni(a,b,c)          S_reguni(aTHX_ a,b,c)
-#define regclass()             S_regclass(aTHX)
-#define regclassutf8()         S_regclassutf8(aTHX)
+#define reg(a,b,c)             S_reg(aTHX_ a,b,c)
+#define reganode(a,b,c)                S_reganode(aTHX_ a,b,c)
+#define regatom(a,b)           S_regatom(aTHX_ a,b)
+#define regbranch(a,b,c)       S_regbranch(aTHX_ a,b,c)
+#define reguni(a,b,c,d)                S_reguni(aTHX_ a,b,c,d)
+#define regclass(a)            S_regclass(aTHX_ a)
 #define regcurly(a)            S_regcurly(aTHX_ a)
-#define reg_node(a)            S_reg_node(aTHX_ a)
-#define regpiece(a)            S_regpiece(aTHX_ a)
-#define reginsert(a,b)         S_reginsert(aTHX_ a,b)
-#define regoptail(a,b)         S_regoptail(aTHX_ a,b)
-#define regtail(a,b)           S_regtail(aTHX_ a,b)
+#define reg_node(a,b)          S_reg_node(aTHX_ a,b)
+#define regpiece(a,b)          S_regpiece(aTHX_ a,b)
+#define reginsert(a,b,c)       S_reginsert(aTHX_ a,b,c)
+#define regoptail(a,b,c)       S_regoptail(aTHX_ a,b,c)
+#define regtail(a,b,c)         S_regtail(aTHX_ a,b,c)
 #define regwhite(a,b)          S_regwhite(aTHX_ a,b)
-#define nextchar()             S_nextchar(aTHX)
+#define nextchar(a)            S_nextchar(aTHX_ a)
 #define dumpuntil(a,b,c,d,e)   S_dumpuntil(aTHX_ a,b,c,d,e)
 #define put_byte(a,b)          S_put_byte(aTHX_ a,b)
-#define scan_commit(a)         S_scan_commit(aTHX_ a)
-#define cl_anything(a)         S_cl_anything(aTHX_ a)
+#define scan_commit(a,b)       S_scan_commit(aTHX_ a,b)
+#define cl_anything(a,b)       S_cl_anything(aTHX_ a,b)
 #define cl_is_anything(a)      S_cl_is_anything(aTHX_ a)
-#define cl_init(a)             S_cl_init(aTHX_ a)
-#define cl_init_zero(a)                S_cl_init_zero(aTHX_ a)
+#define cl_init(a,b)           S_cl_init(aTHX_ a,b)
+#define cl_init_zero(a,b)      S_cl_init_zero(aTHX_ a,b)
 #define cl_and(a,b)            S_cl_and(aTHX_ a,b)
-#define cl_or(a,b)             S_cl_or(aTHX_ a,b)
-#define study_chunk(a,b,c,d,e) S_study_chunk(aTHX_ a,b,c,d,e)
-#define add_data(a,b)          S_add_data(aTHX_ a,b)
-#define regpposixcc(a)         S_regpposixcc(aTHX_ a)
-#define checkposixcc()         S_checkposixcc(aTHX)
+#define cl_or(a,b,c)           S_cl_or(aTHX_ a,b,c)
+#define study_chunk(a,b,c,d,e,f)       S_study_chunk(aTHX_ a,b,c,d,e,f)
+#define add_data(a,b,c)                S_add_data(aTHX_ a,b,c)
+#define regpposixcc(a,b)       S_regpposixcc(aTHX_ a,b)
+#define checkposixcc(a)                S_checkposixcc(aTHX_ a)
 #endif
 #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
 #define regmatch(a)            S_regmatch(aTHX_ a)
 #define regrepeat(a,b)         S_regrepeat(aTHX_ a,b)
 #define regrepeat_hard(a,b,c)  S_regrepeat_hard(aTHX_ a,b,c)
 #define regtry(a,b)            S_regtry(aTHX_ a,b)
-#define reginclass(a,b)                S_reginclass(aTHX_ a,b)
-#define reginclassutf8(a,b)    S_reginclassutf8(aTHX_ a,b)
+#define reginclass(a,b,c)      S_reginclass(aTHX_ a,b,c)
 #define regcppush(a)           S_regcppush(aTHX_ a)
 #define regcppop()             S_regcppop(aTHX)
 #define regcp_set_to(a)                S_regcp_set_to(aTHX_ a)
 #define cache_re(a)            S_cache_re(aTHX_ a)
 #define reghop(a,b)            S_reghop(aTHX_ a,b)
+#define reghop3(a,b,c)         S_reghop3(aTHX_ a,b,c)
 #define reghopmaybe(a,b)       S_reghopmaybe(aTHX_ a,b)
+#define reghopmaybe3(a,b,c)    S_reghopmaybe3(aTHX_ a,b,c)
 #define find_byclass(a,b,c,d,e,f)      S_find_byclass(aTHX_ a,b,c,d,e,f)
 #endif
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
 #  if defined(DEBUGGING)
 #define del_sv(a)              S_del_sv(aTHX_ a)
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+#define sv_2inuv_non_preserve(a,b)     S_sv_2inuv_non_preserve(aTHX_ a,b)
+#define sv_2iuv_non_preserve(a,b)      S_sv_2iuv_non_preserve(aTHX_ a,b)
+#  endif
 #endif
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
 #define check_uni()            S_check_uni(aTHX)
 #define isa_lookup(a,b,c,d)    S_isa_lookup(aTHX_ a,b,c,d)
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define stdize_locale(a)       S_stdize_locale(aTHX_ a)
 #define mess_alloc()           S_mess_alloc(aTHX)
 #  if defined(LEAKTEST)
 #define xstat(a)               S_xstat(aTHX_ a)
 #define amagic_call            Perl_amagic_call
 #define Perl_Gv_AMupdate       CPerlObj::Perl_Gv_AMupdate
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#define Perl_gv_handler                CPerlObj::Perl_gv_handler
+#define gv_handler             Perl_gv_handler
 #define Perl_append_elem       CPerlObj::Perl_append_elem
 #define append_elem            Perl_append_elem
 #define Perl_append_list       CPerlObj::Perl_append_list
 #define pad_swipe              Perl_pad_swipe
 #define Perl_peep              CPerlObj::Perl_peep
 #define peep                   Perl_peep
+#define Perl_start_glob                CPerlObj::Perl_start_glob
+#define start_glob             Perl_start_glob
 #if defined(PERL_OBJECT)
 #define Perl_construct         CPerlObj::Perl_construct
 #define Perl_destruct          CPerlObj::Perl_destruct
 #define refkids                        Perl_refkids
 #define Perl_regdump           CPerlObj::Perl_regdump
 #define regdump                        Perl_regdump
+#define Perl_regclass_swash    CPerlObj::Perl_regclass_swash
+#define regclass_swash         Perl_regclass_swash
 #define Perl_pregexec          CPerlObj::Perl_pregexec
 #define pregexec               Perl_pregexec
 #define Perl_pregfree          CPerlObj::Perl_pregfree
 #define save_vptr              Perl_save_vptr
 #define Perl_save_re_context   CPerlObj::Perl_save_re_context
 #define save_re_context                Perl_save_re_context
+#define Perl_save_padsv                CPerlObj::Perl_save_padsv
+#define save_padsv             Perl_save_padsv
 #define Perl_save_sptr         CPerlObj::Perl_save_sptr
 #define save_sptr              Perl_save_sptr
 #define Perl_save_svref                CPerlObj::Perl_save_svref
 #define sv_unmagic             Perl_sv_unmagic
 #define Perl_sv_unref          CPerlObj::Perl_sv_unref
 #define sv_unref               Perl_sv_unref
+#define Perl_sv_unref_flags    CPerlObj::Perl_sv_unref_flags
+#define sv_unref_flags         Perl_sv_unref_flags
 #define Perl_sv_untaint                CPerlObj::Perl_sv_untaint
 #define sv_untaint             Perl_sv_untaint
 #define Perl_sv_upgrade                CPerlObj::Perl_sv_upgrade
 #define utf16_to_utf8          Perl_utf16_to_utf8
 #define Perl_utf16_to_utf8_reversed    CPerlObj::Perl_utf16_to_utf8_reversed
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#define Perl_utf8_length       CPerlObj::Perl_utf8_length
+#define utf8_length            Perl_utf8_length
 #define Perl_utf8_distance     CPerlObj::Perl_utf8_distance
 #define utf8_distance          Perl_utf8_distance
 #define Perl_utf8_hop          CPerlObj::Perl_utf8_hop
 #define utf8_to_bytes          Perl_utf8_to_bytes
 #define Perl_bytes_to_utf8     CPerlObj::Perl_bytes_to_utf8
 #define bytes_to_utf8          Perl_bytes_to_utf8
+#define Perl_utf8_to_uv_simple CPerlObj::Perl_utf8_to_uv_simple
+#define utf8_to_uv_simple      Perl_utf8_to_uv_simple
 #define Perl_utf8_to_uv                CPerlObj::Perl_utf8_to_uv
 #define utf8_to_uv             Perl_utf8_to_uv
-#define Perl_utf8_to_uv_chk    CPerlObj::Perl_utf8_to_uv_chk
-#define utf8_to_uv_chk         Perl_utf8_to_uv_chk
 #define Perl_uv_to_utf8                CPerlObj::Perl_uv_to_utf8
 #define uv_to_utf8             Perl_uv_to_utf8
 #define Perl_vivify_defelem    CPerlObj::Perl_vivify_defelem
 #define whichsig               Perl_whichsig
 #define Perl_yyerror           CPerlObj::Perl_yyerror
 #define yyerror                        Perl_yyerror
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
+#define Perl_yylex_r           CPerlObj::Perl_yylex_r
+#define yylex_r                        Perl_yylex_r
 #define Perl_yylex             CPerlObj::Perl_yylex
 #define yylex                  Perl_yylex
 #else
 #define sv_utf8_decode         Perl_sv_utf8_decode
 #define Perl_sv_force_normal   CPerlObj::Perl_sv_force_normal
 #define sv_force_normal                Perl_sv_force_normal
+#define Perl_sv_force_normal_flags     CPerlObj::Perl_sv_force_normal_flags
+#define sv_force_normal_flags  Perl_sv_force_normal_flags
 #define Perl_tmps_grow         CPerlObj::Perl_tmps_grow
 #define tmps_grow              Perl_tmps_grow
 #define Perl_sv_rvweaken       CPerlObj::Perl_sv_rvweaken
 #define reguni                 S_reguni
 #define S_regclass             CPerlObj::S_regclass
 #define regclass               S_regclass
-#define S_regclassutf8         CPerlObj::S_regclassutf8
-#define regclassutf8           S_regclassutf8
 #define S_regcurly             CPerlObj::S_regcurly
 #define regcurly               S_regcurly
 #define S_reg_node             CPerlObj::S_reg_node
 #define regtry                 S_regtry
 #define S_reginclass           CPerlObj::S_reginclass
 #define reginclass             S_reginclass
-#define S_reginclassutf8       CPerlObj::S_reginclassutf8
-#define reginclassutf8         S_reginclassutf8
 #define S_regcppush            CPerlObj::S_regcppush
 #define regcppush              S_regcppush
 #define S_regcppop             CPerlObj::S_regcppop
 #define cache_re               S_cache_re
 #define S_reghop               CPerlObj::S_reghop
 #define reghop                 S_reghop
+#define S_reghop3              CPerlObj::S_reghop3
+#define reghop3                        S_reghop3
 #define S_reghopmaybe          CPerlObj::S_reghopmaybe
 #define reghopmaybe            S_reghopmaybe
+#define S_reghopmaybe3         CPerlObj::S_reghopmaybe3
+#define reghopmaybe3           S_reghopmaybe3
 #define S_find_byclass         CPerlObj::S_find_byclass
 #define find_byclass           S_find_byclass
 #endif
 #define S_del_sv               CPerlObj::S_del_sv
 #define del_sv                 S_del_sv
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+#define S_sv_2inuv_non_preserve        CPerlObj::S_sv_2inuv_non_preserve
+#define sv_2inuv_non_preserve  S_sv_2inuv_non_preserve
+#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve
+#define sv_2iuv_non_preserve   S_sv_2iuv_non_preserve
+#  endif
 #endif
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
 #define S_check_uni            CPerlObj::S_check_uni
 #define isa_lookup             S_isa_lookup
 #endif
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+#define S_stdize_locale                CPerlObj::S_stdize_locale
+#define stdize_locale          S_stdize_locale
 #define S_mess_alloc           CPerlObj::S_mess_alloc
 #define mess_alloc             S_mess_alloc
 #  if defined(LEAKTEST)
index 9e05b1b..7b83635 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1376,6 +1376,7 @@ START_EXTERN_C
 #  include "pp_proto.h"
 Ap     |SV*    |amagic_call    |SV* left|SV* right|int method|int dir
 Ap     |bool   |Gv_AMupdate    |HV* stash
+Ap     |CV*    |gv_handler     |HV* stash|I32 id
 p      |OP*    |append_elem    |I32 optype|OP* head|OP* tail
 p      |OP*    |append_list    |I32 optype|LISTOP* first|LISTOP* last
 p      |I32    |apply          |I32 type|SV** mark|SV** sp
@@ -1441,7 +1442,7 @@ Afnp      |int    |fprintf_nocontext|PerlIO* stream|const char* fmt|...
 #endif
 p      |void   |cv_ckproto     |CV* cv|GV* gv|char* p
 p      |CV*    |cv_clone       |CV* proto
-Ap     |SV*    |cv_const_sv    |CV* cv
+Apd    |SV*    |cv_const_sv    |CV* cv
 p      |SV*    |op_const_sv    |OP* o|CV* cv
 Ap     |void   |cv_undef       |CV* cv
 Ap     |void   |cx_dump        |PERL_CONTEXT* cs
@@ -1563,11 +1564,11 @@ Ap      |HV*    |gv_stashpvn    |const char* name|U32 namelen|I32 create
 Apd    |HV*    |gv_stashsv     |SV* sv|I32 create
 Apd    |void   |hv_clear       |HV* tb
 Ap     |void   |hv_delayfree_ent|HV* hv|HE* entry
-Apd    |SV*    |hv_delete      |HV* tb|const char* key|U32 klen|I32 flags
+Apd    |SV*    |hv_delete      |HV* tb|const char* key|I32 klen|I32 flags
 Apd    |SV*    |hv_delete_ent  |HV* tb|SV* key|I32 flags|U32 hash
-Apd    |bool   |hv_exists      |HV* tb|const char* key|U32 klen
+Apd    |bool   |hv_exists      |HV* tb|const char* key|I32 klen
 Apd    |bool   |hv_exists_ent  |HV* tb|SV* key|U32 hash
-Apd    |SV**   |hv_fetch       |HV* tb|const char* key|U32 klen|I32 lval
+Apd    |SV**   |hv_fetch       |HV* tb|const char* key|I32 klen|I32 lval
 Apd    |HE*    |hv_fetch_ent   |HV* tb|SV* key|I32 lval|U32 hash
 Ap     |void   |hv_free_ent    |HV* hv|HE* entry
 Apd    |I32    |hv_iterinit    |HV* tb
@@ -1578,7 +1579,7 @@ Apd       |SV*    |hv_iternextsv  |HV* hv|char** key|I32* retlen
 Apd    |SV*    |hv_iterval     |HV* tb|HE* entry
 Ap     |void   |hv_ksplit      |HV* hv|IV newmax
 Apd    |void   |hv_magic       |HV* hv|GV* gv|int how
-Apd    |SV**   |hv_store       |HV* tb|const char* key|U32 klen|SV* val \
+Apd    |SV**   |hv_store       |HV* tb|const char* key|I32 klen|SV* val \
                                |U32 hash
 Apd    |HE*    |hv_store_ent   |HV* tb|SV* key|SV* val|U32 hash
 Apd    |void   |hv_undef       |HV* tb
@@ -1626,7 +1627,7 @@ Ap        |bool   |is_uni_xdigit_lc|U32 c
 Ap     |U32    |to_uni_upper_lc|U32 c
 Ap     |U32    |to_uni_title_lc|U32 c
 Ap     |U32    |to_uni_lower_lc|U32 c
-Ap     |int    |is_utf8_char   |U8 *p
+Ap     |STRLEN |is_utf8_char   |U8 *p
 Ap     |bool   |is_utf8_string |U8 *s|STRLEN len
 Ap     |bool   |is_utf8_alnum  |U8 *p
 Ap     |bool   |is_utf8_alnumc |U8 *p
@@ -1761,7 +1762,7 @@ Ap        |OP*    |newANONHASH    |OP* o
 Ap     |OP*    |newANONSUB     |I32 floor|OP* proto|OP* block
 Ap     |OP*    |newASSIGNOP    |I32 flags|OP* left|I32 optype|OP* right
 Ap     |OP*    |newCONDOP      |I32 flags|OP* expr|OP* trueop|OP* falseop
-Apd    |void   |newCONSTSUB    |HV* stash|char* name|SV* sv
+Apd    |CV*    |newCONSTSUB    |HV* stash|char* name|SV* sv
 Ap     |void   |newFORM        |I32 floor|OP* o|OP* block
 Ap     |OP*    |newFOROP       |I32 flags|char* label|line_t forline \
                                |OP* sclr|OP* expr|OP*block|OP*cont
@@ -1801,7 +1802,7 @@ Apd       |SV*    |newSVuv        |UV u
 Apd    |SV*    |newSVnv        |NV n
 Apd    |SV*    |newSVpv        |const char* s|STRLEN len
 Apd    |SV*    |newSVpvn       |const char* s|STRLEN len
-Apd    |SV*    |newSVpvn_share |const char* s|STRLEN len|U32 hash
+Apd    |SV*    |newSVpvn_share |const char* s|I32 len|U32 hash
 Afpd   |SV*    |newSVpvf       |const char* pat|...
 Ap     |SV*    |vnewSVpvf      |const char* pat|va_list* args
 Apd    |SV*    |newSVrv        |SV* rv|const char* classname
@@ -1828,6 +1829,7 @@ p |void   |pad_free       |PADOFFSET po
 p      |void   |pad_reset
 p      |void   |pad_swipe      |PADOFFSET po
 p      |void   |peep           |OP* o
+dopM   |PerlIO*|start_glob     |SV* pattern|IO *io
 #if defined(PERL_OBJECT)
 Aox    |void   |Perl_construct
 Aox    |void   |Perl_destruct
@@ -1852,9 +1854,9 @@ Apd       |HV*    |get_hv         |const char* name|I32 create
 Apd    |CV*    |get_cv         |const char* name|I32 create
 Ap     |int    |init_i18nl10n  |int printwarn
 Ap     |int    |init_i18nl14n  |int printwarn
-Ap     |void   |new_collate    |const char* newcoll
-Ap     |void   |new_ctype      |const char* newctype
-Ap     |void   |new_numeric    |const char* newcoll
+Ap     |void   |new_collate    |char* newcoll
+Ap     |void   |new_ctype      |char* newctype
+Ap     |void   |new_numeric    |char* newcoll
 Ap     |void   |set_numeric_local
 Ap     |void   |set_numeric_radix
 Ap     |void   |set_numeric_standard
@@ -1871,6 +1873,7 @@ Ap        |void   |push_scope
 p      |OP*    |ref            |OP* o|I32 type
 p      |OP*    |refkids        |OP* o|I32 type
 Ap     |void   |regdump        |regexp* r
+Ap     |SV*    |regclass_swash |struct regnode *n|bool doinit|SV **initsvp
 Ap     |I32    |pregexec       |regexp* prog|char* stringarg \
                                |char* strend|char* strbeg|I32 minend \
                                |SV* screamer|U32 nosave
@@ -1933,6 +1936,7 @@ Ap        |SV*    |save_scalar    |GV* gv
 Ap     |void   |save_pptr      |char** pptr
 Ap     |void   |save_vptr      |void* pptr
 Ap     |void   |save_re_context
+Ap     |void   |save_padsv     |PADOFFSET off
 Ap     |void   |save_sptr      |SV** sptr
 Ap     |SV*    |save_svref     |SV** sptr
 Ap     |SV**   |save_threadsv  |PADOFFSET i
@@ -1941,10 +1945,10 @@ p       |OP*    |scalar         |OP* o
 p      |OP*    |scalarkids     |OP* o
 p      |OP*    |scalarseq      |OP* o
 p      |OP*    |scalarvoid     |OP* o
-Ap     |NV     |scan_bin       |char* start|I32 len|I32* retlen
-Ap     |NV     |scan_hex       |char* start|I32 len|I32* retlen
-Ap     |char*  |scan_num       |char* s
-Ap     |NV     |scan_oct       |char* start|I32 len|I32* retlen
+Ap     |NV     |scan_bin       |char* start|STRLEN len|STRLEN* retlen
+Ap     |NV     |scan_hex       |char* start|STRLEN len|STRLEN* retlen
+Ap     |char*  |scan_num       |char* s|YYSTYPE *lvalp
+Ap     |NV     |scan_oct       |char* start|STRLEN len|STRLEN* retlen
 p      |OP*    |scope          |OP* o
 Ap     |char*  |screaminstr    |SV* bigsv|SV* littlesv|I32 start_shift \
                                |I32 end_shift|I32 *state|I32 last
@@ -2041,6 +2045,7 @@ Ap        |void   |sv_taint       |SV* sv
 Ap     |bool   |sv_tainted     |SV* sv
 Apd    |int    |sv_unmagic     |SV* sv|int type
 Apd    |void   |sv_unref       |SV* sv
+Apd    |void   |sv_unref_flags |SV* sv|U32 flags
 Ap     |void   |sv_untaint     |SV* sv
 Apd    |bool   |sv_upgrade     |SV* sv|U32 mt
 Apd    |void   |sv_usepvn      |SV* sv|char* ptr|STRLEN len
@@ -2070,12 +2075,13 @@ p       |void   |unshare_hek    |HEK* hek
 p      |void   |utilize        |int aver|I32 floor|OP* version|OP* id|OP* arg
 Ap     |U8*    |utf16_to_utf8  |U8* p|U8 *d|I32 bytelen|I32 *newlen
 Ap     |U8*    |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen
-Ap     |I32    |utf8_distance  |U8 *a|U8 *b
+Ap     |STRLEN |utf8_length    |U8* s|U8 *e
+Ap     |IV     |utf8_distance  |U8 *a|U8 *b
 Ap     |U8*    |utf8_hop       |U8 *s|I32 off
 ApM    |U8*    |utf8_to_bytes  |U8 *s|STRLEN *len
 ApM    |U8*    |bytes_to_utf8  |U8 *s|STRLEN *len
-Ap     |UV     |utf8_to_uv     |U8 *s|I32* retlen
-Ap     |UV     |utf8_to_uv_chk |U8 *s|I32* retlen|bool checking
+Ap     |UV     |utf8_to_uv_simple|U8 *s|STRLEN* retlen
+Ap     |UV     |utf8_to_uv     |U8 *s|STRLEN curlen|STRLEN* retlen|U32 flags
 Ap     |U8*    |uv_to_utf8     |U8 *d|UV uv
 p      |void   |vivify_defelem |SV* sv
 p      |void   |vivify_ref     |SV* sv|U32 to_what
@@ -2089,7 +2095,8 @@ Ap        |void   |vwarner        |U32 err|const char* pat|va_list* args
 p      |void   |watch          |char** addr
 Ap     |I32    |whichsig       |char* sig
 p      |int    |yyerror        |char* s
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
+p      |int    |yylex_r        |YYSTYPE *lvalp|int *lcharp
 p      |int    |yylex          |YYSTYPE *lvalp|int *lcharp
 #else
 p      |int    |yylex
@@ -2167,6 +2174,7 @@ ApdM      |bool   |sv_utf8_downgrade|SV *sv|bool fail_ok
 ApdM      |void   |sv_utf8_encode |SV *sv
 Ap      |bool   |sv_utf8_decode |SV *sv
 Ap     |void   |sv_force_normal|SV *sv
+Ap     |void   |sv_force_normal_flags|SV *sv|U32 flags
 Ap     |void   |tmps_grow      |I32 n
 Apd    |SV*    |sv_rvweaken    |SV *sv
 p      |int    |magic_killbackrefs|SV *sv|MAGIC *mg
@@ -2353,40 +2361,39 @@ s       |int    |dooneliner     |char *cmd|char *filename
 #endif
 
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
-s      |regnode*|reg           |I32|I32 *
-s      |regnode*|reganode      |U8|U32
-s      |regnode*|regatom       |I32 *
-s      |regnode*|regbranch     |I32 *|I32
-s      |void   |reguni         |UV|char *|I32*
-s      |regnode*|regclass
-s      |regnode*|regclassutf8
+s      |regnode*|reg           |struct RExC_state_t*|I32|I32 *
+s      |regnode*|reganode      |struct RExC_state_t*|U8|U32
+s      |regnode*|regatom       |struct RExC_state_t*|I32 *
+s      |regnode*|regbranch     |struct RExC_state_t*|I32 *|I32
+s      |void   |reguni         |struct RExC_state_t*|UV|char *|STRLEN*
+s      |regnode*|regclass      |struct RExC_state_t*
 s      |I32    |regcurly       |char *
-s      |regnode*|reg_node      |U8
-s      |regnode*|regpiece      |I32 *
-s      |void   |reginsert      |U8|regnode *
-s      |void   |regoptail      |regnode *|regnode *
-s      |void   |regtail        |regnode *|regnode *
+s      |regnode*|reg_node      |struct RExC_state_t*|U8
+s      |regnode*|regpiece      |struct RExC_state_t*|I32 *
+s      |void   |reginsert      |struct RExC_state_t*|U8|regnode *
+s      |void   |regoptail      |struct RExC_state_t*|regnode *|regnode *
+s      |void   |regtail        |struct RExC_state_t*|regnode *|regnode *
 s      |char*|regwhite |char *|char *
-s      |char*|nextchar
+s      |char*|nextchar |struct RExC_state_t*
 s      |regnode*|dumpuntil     |regnode *start|regnode *node \
                                |regnode *last|SV* sv|I32 l
 s      |void   |put_byte       |SV* sv|int c
-s      |void   |scan_commit    |struct scan_data_t *data
-s      |void   |cl_anything    |struct regnode_charclass_class *cl
+s      |void   |scan_commit    |struct RExC_state_t*|struct scan_data_t *data
+s      |void   |cl_anything    |struct RExC_state_t*|struct regnode_charclass_class *cl
 s      |int    |cl_is_anything |struct regnode_charclass_class *cl
-s      |void   |cl_init        |struct regnode_charclass_class *cl
-s      |void   |cl_init_zero   |struct regnode_charclass_class *cl
+s      |void   |cl_init        |struct RExC_state_t*|struct regnode_charclass_class *cl
+s      |void   |cl_init_zero   |struct RExC_state_t*|struct regnode_charclass_class *cl
 s      |void   |cl_and         |struct regnode_charclass_class *cl \
                                |struct regnode_charclass_class *and_with
-s      |void   |cl_or          |struct regnode_charclass_class *cl \
+s      |void   |cl_or          |struct RExC_state_t*|struct regnode_charclass_class *cl \
                                |struct regnode_charclass_class *or_with
-s      |I32    |study_chunk    |regnode **scanp|I32 *deltap \
+s      |I32    |study_chunk    |struct RExC_state_t*|regnode **scanp|I32 *deltap \
                                |regnode *last|struct scan_data_t *data \
                                |U32 flags
-s      |I32    |add_data       |I32 n|char *s
+s      |I32    |add_data       |struct RExC_state_t*|I32 n|char *s
 rs     |void|re_croak2 |const char* pat1|const char* pat2|...
-s      |I32    |regpposixcc    |I32 value
-s      |void   |checkposixcc
+s      |I32    |regpposixcc    |struct RExC_state_t*|I32 value
+s      |void   |checkposixcc   |struct RExC_state_t*
 #endif
 
 #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
@@ -2394,14 +2401,15 @@ s       |I32    |regmatch       |regnode *prog
 s      |I32    |regrepeat      |regnode *p|I32 max
 s      |I32    |regrepeat_hard |regnode *p|I32 max|I32 *lp
 s      |I32    |regtry         |regexp *prog|char *startpos
-s      |bool   |reginclass     |regnode *p|I32 c
-s      |bool   |reginclassutf8 |regnode *f|U8* p
+s      |bool   |reginclass     |regnode *n|U8 *p|bool do_utf8sv_is_utf8
 s      |CHECKPOINT|regcppush   |I32 parenfloor
 s      |char*|regcppop
 s      |char*|regcp_set_to     |I32 ss
 s      |void   |cache_re       |regexp *prog
 s      |U8*    |reghop         |U8 *pos|I32 off
+s      |U8*    |reghop3        |U8 *pos|I32 off|U8 *lim
 s      |U8*    |reghopmaybe    |U8 *pos|I32 off
+s      |U8*    |reghopmaybe3   |U8 *pos|I32 off|U8 *lim
 s      |char*  |find_byclass   |regexp * prog|regnode *c|char *s|char *strend|char *startpos|I32 norun
 #endif
 
@@ -2461,6 +2469,10 @@ s        |void   |sv_del_backref |SV *sv
 #  if defined(DEBUGGING)
 s      |void   |del_sv |SV *p
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+s      |int    |sv_2inuv_non_preserve  |SV *sv|I32 numtype
+s      |int    |sv_2iuv_non_preserve   |SV *sv|I32 numtype
+#  endif
 #endif
 
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
@@ -2520,6 +2532,7 @@ s |SV*|isa_lookup |HV *stash|const char *name|int len|int level
 #endif
 
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+s      |char*  |stdize_locale  |char* locs
 s      |SV*    |mess_alloc
 #  if defined(LEAKTEST)
 s      |void   |xstat          |int
index 729389c..fddcd12 100644 (file)
@@ -70,8 +70,7 @@
 #define PL_modcount            (vTHX->Tmodcount)
 #define PL_na                  (vTHX->Tna)
 #define PL_nrs                 (vTHX->Tnrs)
-#define PL_ofs                 (vTHX->Tofs)
-#define PL_ofslen              (vTHX->Tofslen)
+#define PL_ofs_sv              (vTHX->Tofs_sv)
 #define PL_op                  (vTHX->Top)
 #define PL_opsave              (vTHX->Topsave)
 #define PL_protect             (vTHX->Tprotect)
 #define PL_origargv            (PERL_GET_INTERP->Iorigargv)
 #define PL_origenviron         (PERL_GET_INTERP->Iorigenviron)
 #define PL_origfilename                (PERL_GET_INTERP->Iorigfilename)
-#define PL_ors                 (PERL_GET_INTERP->Iors)
-#define PL_orslen              (PERL_GET_INTERP->Iorslen)
+#define PL_ors_sv              (PERL_GET_INTERP->Iors_sv)
 #define PL_osname              (PERL_GET_INTERP->Iosname)
 #define PL_pad_reset_pending   (PERL_GET_INTERP->Ipad_reset_pending)
 #define PL_padix               (PERL_GET_INTERP->Ipadix)
 #define PL_origargv            (vTHX->Iorigargv)
 #define PL_origenviron         (vTHX->Iorigenviron)
 #define PL_origfilename                (vTHX->Iorigfilename)
-#define PL_ors                 (vTHX->Iors)
-#define PL_orslen              (vTHX->Iorslen)
+#define PL_ors_sv              (vTHX->Iors_sv)
 #define PL_osname              (vTHX->Iosname)
 #define PL_pad_reset_pending   (vTHX->Ipad_reset_pending)
 #define PL_padix               (vTHX->Ipadix)
 #define PL_modcount            (aTHXo->interp.Tmodcount)
 #define PL_na                  (aTHXo->interp.Tna)
 #define PL_nrs                 (aTHXo->interp.Tnrs)
-#define PL_ofs                 (aTHXo->interp.Tofs)
-#define PL_ofslen              (aTHXo->interp.Tofslen)
+#define PL_ofs_sv              (aTHXo->interp.Tofs_sv)
 #define PL_op                  (aTHXo->interp.Top)
 #define PL_opsave              (aTHXo->interp.Topsave)
 #define PL_protect             (aTHXo->interp.Tprotect)
 #define PL_origargv            (aTHXo->interp.Iorigargv)
 #define PL_origenviron         (aTHXo->interp.Iorigenviron)
 #define PL_origfilename                (aTHXo->interp.Iorigfilename)
-#define PL_ors                 (aTHXo->interp.Iors)
-#define PL_orslen              (aTHXo->interp.Iorslen)
+#define PL_ors_sv              (aTHXo->interp.Iors_sv)
 #define PL_osname              (aTHXo->interp.Iosname)
 #define PL_pad_reset_pending   (aTHXo->interp.Ipad_reset_pending)
 #define PL_padix               (aTHXo->interp.Ipadix)
 #define PL_Iorigargv           PL_origargv
 #define PL_Iorigenviron                PL_origenviron
 #define PL_Iorigfilename       PL_origfilename
-#define PL_Iors                        PL_ors
-#define PL_Iorslen             PL_orslen
+#define PL_Iors_sv             PL_ors_sv
 #define PL_Iosname             PL_osname
 #define PL_Ipad_reset_pending  PL_pad_reset_pending
 #define PL_Ipadix              PL_padix
 #define PL_modcount            (aTHX->Tmodcount)
 #define PL_na                  (aTHX->Tna)
 #define PL_nrs                 (aTHX->Tnrs)
-#define PL_ofs                 (aTHX->Tofs)
-#define PL_ofslen              (aTHX->Tofslen)
+#define PL_ofs_sv              (aTHX->Tofs_sv)
 #define PL_op                  (aTHX->Top)
 #define PL_opsave              (aTHX->Topsave)
 #define PL_protect             (aTHX->Tprotect)
 #define PL_Tmodcount           PL_modcount
 #define PL_Tna                 PL_na
 #define PL_Tnrs                        PL_nrs
-#define PL_Tofs                        PL_ofs
-#define PL_Tofslen             PL_ofslen
+#define PL_Tofs_sv             PL_ofs_sv
 #define PL_Top                 PL_op
 #define PL_Topsave             PL_opsave
 #define PL_Tprotect            PL_protect
index ee65ee3..c155ce4 100644 (file)
@@ -78,6 +78,7 @@ cppsymbols=''
 crosscompile='define'
 cryptlib=''
 csh='csh'
+d__fwalk='undef'
 d_Gconvert='epoc_gcvt((x),(n),(b))'
 d_PRIEUldbl='undef'
 d_PRIFUldbl='undef'
@@ -138,6 +139,7 @@ d_eunice='undef'
 d_fchmod='undef'
 d_fchown='undef'
 d_fcntl='undef'
+d_fcntl_can_lock='undef'
 d_fd_macros='undef'
 d_fd_set='define'
 d_fds_bits='undef'
@@ -152,6 +154,7 @@ d_fseeko='undef'
 d_fsetpos='define'
 d_fstatfs='define'
 d_fstatvfs='undef'
+d_fsync='undef'
 d_ftello='undef'
 d_ftime='undef'
 d_getespwnam='undef'
@@ -169,6 +172,7 @@ d_getnbyaddr='undef'
 d_getnbyname='undef'
 d_getnent='undef'
 d_getnetprotos='define'
+d_getpagsz='undef'
 d_getpbyname='define'
 d_getpbynumber='define'
 d_getpent='undef'
@@ -271,6 +275,7 @@ d_rmdir='define'
 d_safebcpy='undef'
 d_safemcpy='undef'
 d_sanemcmp='define'
+d_sbrkproto='undef'
 d_sched_yield='undef'
 d_scm_rights='undef'
 d_seekdir='define'
@@ -324,6 +329,8 @@ d_statfsflags='define'
 d_statvfs='undef'
 d_stdio_cnt_lval='define'
 d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_ptr_lval_nochange_cnt='undef'
 d_stdio_stream_array='undef'
 d_stdiobase='undef'
 d_stdstdio='undef'
@@ -334,7 +341,9 @@ d_strerrm='strerror(e)'
 d_strerror='define'
 d_strtod='define'
 d_strtol='define'
+d_strtoq='undef'
 d_strtoul='define'
+d_strtouq='undef'
 d_strtoull='undef'
 d_strxfrm='define'
 d_suidsafe='undef'
@@ -566,6 +575,7 @@ mydomain='.gmx.de'
 myhostname='dragon'
 myuname=''
 n='-n'
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='const char *'
 netdb_name_type='const char *'
@@ -973,3 +983,6 @@ i_prot='undef'
 d_SCNfldbl='undef'
 d_perl_otherlibdirs='undef'
 nvsize='16'
+issymlink=''
+
+
index a2691f3..b9bc652 100644 (file)
@@ -101,7 +101,6 @@ do_aspawn( pTHX_ SV *really,SV **mark,SV **sp) {
 int
 do_spawn (pTHX_ SV *really,SV **mark,SV **sp)
 {
-    dTHR;
     int  rc;
     char **a,*cmd,**ptr, *cmdline, **argv, *p2; 
     STRLEN n_a;
index 4963a2e..a0557cc 100644 (file)
@@ -33,8 +33,12 @@ epoc_spawn( char *cmd, char *cmdline) {
 
 
   /* Workaround for defect atof(), see java defect list for epoc */
-  double epoc_atof( const char* str) {
+  double epoc_atof( char* str) {
     TReal64 aRes;
+    
+    while (TChar( *str).IsSpace()) {
+      str++;
+    }
 
     TLex lex( _L( str));
     TInt err = lex.Val( aRes, TChar( '.'));
index 50364fa..591b581 100644 (file)
@@ -9,12 +9,17 @@ package B;
 use XSLoader ();
 require Exporter;
 @ISA = qw(Exporter);
+
+# walkoptree_slow comes from B.pm (you are there),
+# walkoptree comes from B.xs
 @EXPORT_OK = qw(minus_c ppname save_BEGINs
                class peekop cast_I32 cstring cchar hash threadsv_names
-               main_root main_start main_cv svref_2object opnumber amagic_generation
-               walkoptree walkoptree_slow walkoptree_exec walksymtable
+               main_root main_start main_cv svref_2object opnumber
+               amagic_generation
+               walkoptree_slow walkoptree walkoptree_exec walksymtable
                parents comppadlist sv_undef compile_stats timing_info
                begin_av init_av end_av);
+
 sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';
@@ -185,7 +190,7 @@ sub walksymtable {
        *glob = "*main::".$prefix.$sym;
        if ($sym =~ /::$/) {
            $sym = $prefix . $sym;
-           if ($sym ne "main::" && &$recurse($sym)) {
+           if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
                walksymtable(\%glob, $method, $recurse, $sym);
            }
        } else {
@@ -531,6 +536,8 @@ This method returns TRUE if the GP field of the GV is NULL.
 
 =item CvFLAGS
 
+=item const_sv
+
 =back
 
 =head2 B::HV METHODS
index f1f0e65..ec9e578 100644 (file)
@@ -1229,6 +1229,12 @@ U16
 CvFLAGS(cv)
       B::CV   cv
 
+MODULE = B     PACKAGE = B::CV         PREFIX = cv_
+
+B::SV
+cv_const_sv(cv)
+       B::CV   cv
+
 
 MODULE = B     PACKAGE = B::HV         PREFIX = Hv
 
index d0c8159..dac9417 100644 (file)
@@ -1020,7 +1020,6 @@ sub output_all {
     print <<"EOT";
 static int $init_name()
 {
-       dTHR;
        dTARG;
        djSP;
 EOT
@@ -1338,7 +1337,7 @@ sub should_save
  # Now see if current package looks like an OO class this is probably too strong.
  foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) 
   {
-   if ($package->can($m)) 
+   if (UNIVERSAL::can($package, $m))
     {
      warn "$package has method $m: saving package\n";#debug
      return mark_package($package);
@@ -1368,7 +1367,7 @@ sub walkpackages
    if ($sym =~ /::$/) 
     {
      $sym = $prefix . $sym;
-     if ($sym ne "main::" && &$recurse($sym)) 
+     if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) 
       {
        walkpackages(\%glob, $recurse, $sym);
       }
index 5c5c5eb..b0a5eae 100644 (file)
@@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber
          CVf_METHOD CVf_LOCKED CVf_LVALUE
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.591;
+$VERSION = 0.60;
 use strict;
 
 # Changes between 0.50 and 0.51:
@@ -83,6 +83,12 @@ use strict;
 # - added support for Chip's OP_METHOD_NAMED
 # - added support for Ilya's OPpTARGET_MY optimization
 # - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
 
 # Todo:
 # - finish tr/// changes
@@ -93,8 +99,8 @@ use strict;
 # - left/right context
 # - recognize `use utf8', `use integer', etc
 # - treat top-level block specially for incremental output
-# - interpret in high bit chars in string as utf8 \x{...} (when?)
-# - copy comments (look at real text with $^P?) 
+# - interpret high bit chars in string as utf8 \x{...} (when?)
+# - copy comments (look at real text with $^P?)
 # - avoid semis in one-statement blocks
 # - associativity of &&=, ||=, ?:
 # - ',' => '=>' (auto-unquote?)
@@ -108,7 +114,6 @@ use strict;
 # - version using op_next instead of op_first/sibling?
 # - avoid string copies (pass arrays, one big join?)
 # - auto-apply `-u'?
-# - while{} with one-statement continue => for(; XXX; XXX) {}?
 # - -uPackage:: descend recursively?
 # - here-docs?
 # - <DATA>?
@@ -357,6 +362,8 @@ sub new {
            $self->{'unquote'} = 1;
        } elsif (substr($arg, 0, 2) eq "-s") {
            $self->style_opts(substr $arg, 2);
+       } elsif ($arg =~ /^-x(\d)$/) {
+           $self->{'expand'} = $1;
        }
     }
     return $self;
@@ -393,6 +400,7 @@ sub deparse {
     my $self = shift;
     my($op, $cx) = @_;
 #    cluck if class($op) eq "NULL";
+#    cluck unless $op;
 #    return $self->$ {\("pp_" . $op->name)}($op, $cx);
     my $meth = "pp_" . $op->name;
     return $self->$meth($op, $cx);
@@ -446,6 +454,11 @@ sub deparse_sub {
        # skip leavesub
        return $proto . "{\n\t" . 
            $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; 
+    }
+    my $sv = $cv->const_sv;
+    if ($$sv) {
+       # uh-oh. inlinable sub... format it differently
+       return $proto . "{ " . const($sv) . " }\n";
     } else { # XSUB?
        return $proto  . "{}\n";
     }
@@ -679,70 +692,69 @@ sub pp_entertry { # see also leavetry
     return "XXX";
 }
 
-# leave and scope/lineseq should probably share code
-sub pp_leave {
+sub lineseq {
     my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    local($self->{'curstash'}) = $self->{'curstash'};
-    $kid = $op->first->sibling; # skip enter
-    if (is_miniwhile($kid)) {
-       my $top = $kid->first;
-       my $name = $top->name;
-       if ($name eq "and") {
-           $name = "while";
-       } elsif ($name eq "or") {
-           $name = "until";
-       } else { # no conditional -> while 1 or until 0
-           return $self->deparse($top->first, 1) . " while 1";
-       }
-       my $cond = $top->first;
-       my $body = $cond->sibling->first; # skip lineseq
-       $cond = $self->deparse($cond, 1);
-       $body = $self->deparse($body, 1);
-       return "$body $name $cond";
-    }
-    for (; !null($kid); $kid = $kid->sibling) {
+    my(@ops) = @_;
+    my($expr, @exprs);
+    for (my $i = 0; $i < @ops; $i++) {
        $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+       if (is_state $ops[$i]) {
+           $expr = $self->deparse($ops[$i], 0);
+           $i++;
+           last if $i > $#ops;
        }
-       $expr .= $self->deparse($kid, 0);
+       if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
+           $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
+       {
+           push @exprs, $expr . $self->for_loop($ops[$i], 0);
+           $i++;
+           next;
+       }
+       $expr .= $self->deparse($ops[$i], 0);
        push @exprs, $expr if length $expr;
     }
-    if ($cx > 0) { # inside an expression
-       return "do { " . join(";\n", @exprs) . " }";
-    } else {
-       return join(";\n", @exprs) . ";";
-    }
+    return join(";\n", @exprs);
 }
 
-sub pp_scope {
-    my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
-       $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+sub scopeop {
+    my($real_block, $self, $op, $cx) = @_;
+    my $kid;
+    my @kids;
+    local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
+    if ($real_block) {
+       $kid = $op->first->sibling; # skip enter
+       if (is_miniwhile($kid)) {
+           my $top = $kid->first;
+           my $name = $top->name;
+           if ($name eq "and") {
+               $name = "while";
+           } elsif ($name eq "or") {
+               $name = "until";
+           } else { # no conditional -> while 1 or until 0
+               return $self->deparse($top->first, 1) . " while 1";
+           }
+           my $cond = $top->first;
+           my $body = $cond->sibling->first; # skip lineseq
+           $cond = $self->deparse($cond, 1);
+           $body = $self->deparse($body, 1);
+           return "$body $name $cond";
        }
-       $expr .= $self->deparse($kid, 0);
-       push @exprs, $expr if length $expr;
+    } else {
+       $kid = $op->first;
+    }
+    for (; !null($kid); $kid = $kid->sibling) {
+       push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-       return "do { " . join(";\n", @exprs) . " }";
+       return "do { " . $self->lineseq(@kids) . " }";
     } else {
-       return join(";\n", @exprs) . ";";
+       return $self->lineseq(@kids) . ";";
     }
 }
 
-sub pp_lineseq { pp_scope(@_) }
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
 
 # The BEGIN {} is used here because otherwise this code isn't executed
 # when you run B::Deparse on itself.
@@ -1380,11 +1392,14 @@ sub logop {
     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
     my $left = $op->first;
     my $right = $op->first->sibling;
-    if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
+    if ($cx == 0 and is_scope($right) and $blockname
+       and $self->{'expand'} < 7)
+    { # if ($a) {$b}
        $left = $self->deparse($left, 1);
        $right = $self->deparse($right, 0);
        return "$blockname ($left) {\n\t$right\n\b}\cK";
-    } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
+    } elsif ($cx == 0 and $blockname and not $self->{'parens'}
+            and $self->{'expand'} < 7) { # $b if $a
        $right = $self->deparse($right, 1);
        $left = $self->deparse($left, 1);
        return "$right $blockname $left";
@@ -1675,7 +1690,8 @@ sub pp_cond_expr {
     my $false = $true->sibling;
     my $cuddle = $self->{'cuddle'};
     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
-           (is_scope($false) || is_ifelse_cont($false))) {
+           (is_scope($false) || is_ifelse_cont($false))
+           and $self->{'expand'} < 7) {
        $cond = $self->deparse($cond, 8);
        $true = $self->deparse($true, 8);
        $false = $self->deparse($false, 8);
@@ -1704,20 +1720,24 @@ sub pp_cond_expr {
     return $head . join($cuddle, "", @elsifs) . $false; 
 }
 
-sub pp_leaveloop {
+sub loop_common {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $init) = @_;
     my $enter = $op->first;
     my $kid = $enter->sibling;
     local($self->{'curstash'}) = $self->{'curstash'};
     my $head = "";
     my $bare = 0;
+    my $body;
+    my $cond = undef;
     if ($kid->name eq "lineseq") { # bare or infinite loop 
        if (is_state $kid->last) { # infinite
            $head = "for (;;) "; # shorter than while (1)
+           $cond = "";
        } else {
            $bare = 1;
        }
+       $body = $kid;
     } elsif ($enter->name eq "enteriter") { # foreach
        my $ary = $enter->first->sibling; # first was pushmark
        my $var = $ary->sibling;
@@ -1749,62 +1769,60 @@ sub pp_leaveloop {
            $var = "\$" . $self->deparse($var, 1);
        }
        $head = "foreach $var ($ary) ";
-       $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+       $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
     } elsif ($kid->name eq "null") { # while/until
        $kid = $kid->first;
-       my $name = {"and" => "while", "or" => "until"}
-                   ->{$kid->name};
-       $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
-       $kid = $kid->first->sibling;
+       my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+       $cond = $self->deparse($kid->first, 1);
+       $head = "$name ($cond) ";
+       $body = $kid->first->sibling;
     } elsif ($kid->name eq "stub") { # bare and empty
        return "{;}"; # {} could be a hashref
     }
-    # The third-to-last kid is the continue block if the pointer used
-    # by `next BLOCK' points to its first OP, which happens to be the
-    # the op_next of the head of the _previous_ statement. 
-    # Unless it's a bare loop, in which case it's last, since there's
-    # no unstack or extra nextstate.
-    # Except if the previous head isn't null but the first kid is
-    # (because it's a nulled out nextstate in a scope), in which
-    # case the head's next is advanced past the null but the nextop's
-    # isn't, so we need to try nextop->next.
-    my $precont;
-    my $cont = $kid->first;
-    if ($bare) {
-       while (!null($cont->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
-       }       
-    } else {
-       while (!null($cont->sibling->sibling->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
+    # If there isn't a continue block, then the next pointer for the loop
+    # will point to the unstack, which is kid's penultimate child, except
+    # in a bare loop, when it will point to the leaveloop. When neither of
+    # these conditions hold, then the third-to-last child in the continue
+    # block (or the last in a bare loop).
+    my $cont_start = $enter->nextop;
+    my $cont;
+    if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
+       if ($bare) {
+           $cont = $body->last;
+       } else {
+           $cont = $body->first;
+           while (!null($cont->sibling->sibling->sibling)) {
+               $cont = $cont->sibling;
+           }
+       }
+       my $state = $body->first;
+       my $cuddle = $self->{'cuddle'};
+       my @states;
+       for (; $$state != $$cont; $state = $state->sibling) {
+           push @states, $state;
+       }
+       $body = $self->lineseq(@states);
+       if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+           $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+           $cont = "\cK";
+       } else {
+           $cont = $cuddle . "continue {\n\t" .
+             $self->deparse($cont, 0) . "\n\b}\cK";
        }
-    }
-    if ($precont and $ {$precont->next} == $ {$enter->nextop}
-       || $ {$precont->next} == $ {$enter->nextop->next} )
-    {
-       my $state = $kid->first;
-       my $cuddle = $self->{'cuddle'};
-       my($expr, @exprs);
-       for (; $$state != $$cont; $state = $state->sibling) {
-          $expr = "";
-          if (is_state $state) {
-              $expr = $self->deparse($state, 0);
-              $state = $state->sibling;
-              last if null $state;
-          }
-          $expr .= $self->deparse($state, 0);
-          push @exprs, $expr if $expr;
-       }
-       $kid = join(";\n", @exprs);
-       $cont = $cuddle . "continue {\n\t" .
-        $self->deparse($cont, 0) . "\n\b}\cK";
     } else {
        $cont = "\cK";
-       $kid = $self->deparse($kid, 0);
+       $body = $self->deparse($body, 0);
     }
-    return $head . "{\n\t" . $kid . "\n\b}" . $cont;
+    return $head . "{\n\t" . $body . "\n\b}" . $cont;
+}
+
+sub pp_leaveloop { loop_common(@_, "") }
+
+sub for_loop {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my $init = $self->deparse($op, 1);
+    return $self->loop_common($op->sibling, $cx, $init);
 }
 
 sub pp_leavetry {
@@ -2851,8 +2869,8 @@ B::Deparse - Perl compiler backend to produce perl code
 
 =head1 SYNOPSIS
 
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
-     I<prog.pl>
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
+        [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
 
 =head1 DESCRIPTION
 
@@ -2997,6 +3015,55 @@ file is compiled as a main program.
 
 =back
 
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, for loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+    for ($i = 0; $i < 10; ++$i) {
+        print $i;
+    }
+
+turns into
+
+    $i = 0;
+    while ($i < 10) {
+        print $i;
+    } continue {
+        ++$i
+    }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 7, if statements will be translated into equivalent
+expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+    print 'hi' if $nice;
+    if ($nice) {
+        print 'hi';
+    }
+    if ($nice) {
+        print 'hi';
+    } else {
+        print 'bye';
+    }
+
+turns into
+
+    $nice and print 'hi';
+    $nice and do { print 'hi' };
+    $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
 =back
 
 =head1 USING B::Deparse AS A MODULE
@@ -3043,7 +3110,7 @@ See the 'to do' list at the beginning of the module file.
 
 =head1 AUTHOR
 
-Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
index ed0d07d..094b3cf 100644 (file)
@@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents
+use B qw(walkoptree main_root walksymtable svref_2object parents
          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
         );
 
@@ -277,12 +277,12 @@ sub B::GV::lintcv {
     return if !$$cv || $done_cv{$$cv}++;
     my $root = $cv->ROOT;
     #warn "    root = $root (0x$$root)\n";#debug
-    walkoptree_slow($root, "lint") if $$root;
+    walkoptree($root, "lint") if $$root;
 }
 
 sub do_lint {
     my %search_pack;
-    walkoptree_slow(main_root, "lint") if ${main_root()};
+    walkoptree(main_root, "lint") if ${main_root()};
     
     # Now do subs in main
     no strict qw(vars refs);
index 66b5cfc..a7a071e 100644 (file)
@@ -1,6 +1,6 @@
 package B::Terse;
 use strict;
-use B qw(peekop class walkoptree_slow walkoptree_exec
+use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
         main_start main_root cstring svref_2object);
 use B::Asmdata qw(@specialsv_name);
 
index d3b4351..05b795c 100644 (file)
@@ -77,7 +77,6 @@ bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n)
 static I32
 byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
 {
-    dTHR;
     OP *saveroot = PL_main_root;
     OP *savestart = PL_main_start;
     struct byteloader_state bstate;
index 19f1f6b..3e12790 100644 (file)
@@ -54,7 +54,6 @@ bset_obj_store(pTHXo_ struct byteloader_state *bstate, void *obj, I32 ix)
 void
 byterun(pTHXo_ register struct byteloader_state *bstate)
 {
-    dTHR;
     register int insn;
     U32 ix;
     SV *specialsv_list[6];
index ad54382..eda270d 100644 (file)
      the updates to the documentation and writing DB_File::Lock (available
      on CPAN).
 
-1.73 27th April 2000
+1.73 31st May 2000
 
    * Added support in version.c for building with threaded Perl.
 
+   * Berkeley DB 3.1 has reenabled support for null keys. The test
+     harness has been updated to reflect this.
+
+1.74 10th December 2000
+
+   * A "close" call in DB_File.xs needed parenthesised to stop win32 from
+     thinking it was one of its macros.
+
+   * Updated dbinfo to support Berkeley DB 3.1 file format changes.
+
+   * DB_File.pm & the test hasness now use the warnings pragma (when
+     available).
+
+   * Included Perl core patch 7703 -- size argument for hash_cb is different
+     for Berkeley DB 3.x
+
+   * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C
+     treatment.
+
+   * @a = () produced the warning 'Argument "" isn't numeric in entersub'
+     This has been fixed. Thanks to Edward Avis for spotting this bug.
+
+   * Added note about building under Linux. Included patches.
+
+   * Included Perl core patch 8068 -- fix for bug 20001013.009 
+     When run with warnings enabled "$hash{XX} = undef " produced an
+     "Uninitialized value" warning. This has been fixed.
+
+1.75 17th December 2000
+
+   * Fixed perl core patch 7703
+
+   * Added suppport to allow DB_File to be built with Berkeley DB 3.2 --
+     btree_compare, btree_prefix and hash_cb needed to be changed.
+
+   * Updated dbinfo to support Berkeley DB 3.2 file format changes.
+
+
index a1ec0e6..c830216 100644 (file)
@@ -1,8 +1,8 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 26th April 2000
-# version 1.73
+# last modified 17th December 2000
+# version 1.75
 #
 #     Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -13,6 +13,7 @@ package DB_File::HASHINFO ;
 
 require 5.003 ;
 
+use warnings;
 use strict;
 use Carp;
 require Tie::Hash;
@@ -104,6 +105,7 @@ sub CLEAR    { my $self = shift ; $self->NotHere("CLEAR") }
 
 package DB_File::RECNOINFO ;
 
+use warnings;
 use strict ;
 
 @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
@@ -121,6 +123,7 @@ sub TIEHASH
 
 package DB_File::BTREEINFO ;
 
+use warnings;
 use strict ;
 
 @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
@@ -140,6 +143,7 @@ sub TIEHASH
 
 package DB_File ;
 
+use warnings;
 use strict;
 use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
             $db_version $use_XSLoader
@@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO
 use Carp;
 
 
-$VERSION = "1.73" ;
+$VERSION = "1.75" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -271,7 +275,7 @@ sub TIEARRAY
 sub CLEAR 
 {
     my $self = shift;
-    my $key = "" ;
+    my $key = 0 ;
     my $value = "" ;
     my $status = $self->seq($key, $value, R_FIRST());
     my @keys;
@@ -665,6 +669,7 @@ This example shows how to create a database, add key/value pairs to the
 database, delete keys/value pairs and finally how to enumerate the
 contents of the database.
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use vars qw( %h $k $v ) ;
@@ -715,6 +720,7 @@ This script shows how to override the default sorting algorithm that
 BTREE uses. Instead of using the normal lexical ordering, a case
 insensitive compare function will be used.
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -783,6 +789,7 @@ There are some difficulties in using the tied hash interface if you
 want to manipulate a BTREE database with duplicate keys. Consider this
 code:
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -837,6 +844,7 @@ and the API in general.
 
 Here is the script above rewritten using the C<seq> API method.
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -908,6 +916,7 @@ particular value occurred in the BTREE.
 So assuming the database created above, we can use C<get_dup> like
 this:
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -957,6 +966,7 @@ returns 0. Otherwise the method returns a non-zero value.
 
 Assuming the database from the previous example:
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -995,6 +1005,7 @@ Otherwise the method returns a non-zero value.
 
 Again assuming the existence of the C<tree> database
 
+    use warnings ;
     use strict ;
     use DB_File ;
  
@@ -1039,6 +1050,7 @@ the use of the R_CURSOR flag with seq:
 In the example script below, the C<match> sub uses this feature to find
 and print the first matching key/value pair given a partial key.
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use Fcntl ;
@@ -1143,6 +1155,7 @@ Here is a simple example that uses RECNO (if you are using a version
 of Perl earlier than 5.004_57 this example won't work -- see 
 L<Extra RECNO Methods> for a workaround).
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -1232,6 +1245,7 @@ Here is a more complete example that makes use of some of the methods
 described above. It also makes use of the API interface directly (see 
 L<THE API INTERFACE>).
 
+    use warnings ;
     use strict ;
     use vars qw(@h $H $file $i) ;
     use DB_File ;
@@ -1583,6 +1597,7 @@ the database and have them removed when you read from the database. As I'm
 sure you have already guessed, this is a problem that DBM Filters can
 fix very easily.
 
+    use warnings ;
     use strict ;
     use DB_File ;
 
@@ -1625,6 +1640,7 @@ when reading.
 
 Here is a DBM Filter that does it:
 
+    use warnings ;
     use strict ;
     use DB_File ;
     my %hash ;
@@ -1791,6 +1807,7 @@ Here is a snippet of code that is loosely based on Tom Christiansen's
 I<ggh> script (available from your nearest CPAN archive in
 F<authors/id/TOMC/scripts/nshist.gz>).
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use Fcntl ;
@@ -1947,6 +1964,7 @@ You will encounter this particular error message when you have the
 C<strict 'subs'> pragma (or the full strict pragma) in your script.
 Consider this script:
 
+    use warnings ;
     use strict ;
     use DB_File ;
     use vars qw(%x) ;
index cb8fd80..fa3bb33 100644 (file)
@@ -3,8 +3,8 @@
  DB_File.xs -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 27th April 2000
- version 1.73
+ last modified 17 December 2000
+ version 1.75
 
  All comments/suggestions/problems are welcome
 
                Rewrote push
         1.72 -  No change to DB_File.xs
         1.73 -  No change to DB_File.xs
+        1.74 -  A call to open needed parenthesised to stop it clashing
+                with a win32 macro.
+               Added Perl core patches 7703 & 7801.
+        1.75 -  Fixed Perl core patch 7703.
+               Added suppport to allow DB_File to be built with 
+               Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb
+               needed to be changed.
 
 */
 
 #    include <db.h>
 #endif
 
+#ifdef CAN_PROTOTYPE
+extern void __getBerkeleyDBInfo(void);
+#endif
+
 #ifndef pTHX
 #    define pTHX
 #    define pTHX_
 #    define BERKELEY_DB_1_OR_2
 #endif
 
+#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2)
+#    define AT_LEAST_DB_3_2
+#endif
+
 /* map version 2 features & constants onto their version 1 equivalent */
 
 #ifdef DB_Prefix_t
@@ -244,6 +259,7 @@ typedef db_recno_t  recno_t;
 
 #else /* db version 1.x */
 
+#define BERKELEY_DB_1
 #define BERKELEY_DB_1_OR_2
 
 typedef union INFO {
@@ -473,6 +489,19 @@ u_int              flags ;
 
 
 static int
+#ifdef AT_LEAST_DB_3_2
+
+#ifdef CAN_PROTOTYPE
+btree_compare(DB * db, const DBT *key1, const DBT *key2)
+#else
+btree_compare(db, key1, key2)
+DB * db ;
+const DBT * key1 ;
+const DBT * key2 ;
+#endif /* CAN_PROTOTYPE */
+
+#else /* Berkeley DB < 3.2 */
+
 #ifdef CAN_PROTOTYPE
 btree_compare(const DBT *key1, const DBT *key2)
 #else
@@ -480,6 +509,9 @@ btree_compare(key1, key2)
 const DBT * key1 ;
 const DBT * key2 ;
 #endif
+
+#endif
+
 {
 #ifdef dTHX
     dTHX;
@@ -529,6 +561,19 @@ const DBT * key2 ;
 }
 
 static DB_Prefix_t
+#ifdef AT_LEAST_DB_3_2
+
+#ifdef CAN_PROTOTYPE
+btree_prefix(DB * db, const DBT *key1, const DBT *key2)
+#else
+btree_prefix(db, key1, key2)
+Db * db ;
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
+
+#else /* Berkeley DB < 3.2 */
+
 #ifdef CAN_PROTOTYPE
 btree_prefix(const DBT *key1, const DBT *key2)
 #else
@@ -536,6 +581,8 @@ btree_prefix(key1, key2)
 const DBT * key1 ;
 const DBT * key2 ;
 #endif
+
+#endif
 {
 #ifdef dTHX
     dTHX;
@@ -584,13 +631,35 @@ const DBT * key2 ;
     return (retval) ;
 }
 
+
+#ifdef BERKELEY_DB_1
+#    define HASH_CB_SIZE_TYPE size_t
+#else
+#    define HASH_CB_SIZE_TYPE u_int32_t
+#endif
+
 static DB_Hash_t
+#ifdef AT_LEAST_DB_3_2
+
 #ifdef CAN_PROTOTYPE
-hash_cb(const void *data, size_t size)
+hash_cb(DB * db, const void *data, u_int32_t size)
+#else
+hash_cb(db, data, size)
+DB * db ;
+const void * data ;
+HASH_CB_SIZE_TYPE size ;
+#endif
+
+#else /* Berkeley DB < 3.2 */
+
+#ifdef CAN_PROTOTYPE
+hash_cb(const void *data, HASH_CB_SIZE_TYPE size)
 #else
 hash_cb(data, size)
 const void * data ;
-size_t size ;
+HASH_CB_SIZE_TYPE size ;
+#endif
+
 #endif
 {
 #ifdef dTHX
@@ -1266,7 +1335,7 @@ SV *   sv ;
             Flags |= DB_TRUNCATE ;
 #endif
 
-        status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, 
+        status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, 
                                Flags, mode) ; 
        /* printf("open returned %d %s\n", status, db_strerror(status)) ; */
 
index 701ac61..5a4df15 100644 (file)
@@ -4,10 +4,10 @@
 #                        a database file
 #
 # Author:      Paul Marquess  <Paul.Marquess@btinternet.com>
-# Version:     1.02 
-# Date         20th August 1999
+# Version:     1.03 
+# Date         17th September 2000
 #
-#     Copyright (c) 1998 Paul Marquess. All rights reserved.
+#     Copyright (c) 1998-2000 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
 #     modify it under the same terms as Perl itself.
 
@@ -28,7 +28,8 @@ my %Data =
                                  4     => "Unknown",
                                  5     => "2.0.0 -> 2.3.0",
                                  6     => "2.3.1 -> 2.7.7",
-                                 7     => "3.0.0 or greater",
+                                 7     => "3.0.x",
+                                 8     => "3.1.x or greater",
                                }
                        },
        0x061561 =>     {
@@ -40,14 +41,17 @@ my %Data =
                                  3     => "1.86",
                                  4     => "2.0.0 -> 2.1.0",
                                  5     => "2.2.6 -> 2.7.7",
-                                 6     => "3.0.0 or greater",
+                                 6     => "3.0.x",
+                                 7     => "3.1.x or greater",
                                }
                        },
        0x042253 =>     {
                          Type     => "Queue",
                          Versions =>
                                {
-                                 1     => "3.0.0 or greater",
+                                 1     => "3.0.x",
+                                 2     => "3.1.x",
+                                 3     => "3.2.x or greater",
                                }
                        },
        ) ;
@@ -86,7 +90,7 @@ else
   { die "not a Berkeley DB database file.\n" }
 
 my $type = $Data{$magic} ;
-my $magic = sprintf "%06X", $magic ;
+$magic = sprintf "%06X", $magic ;
 
 my $ver_string = "Unknown" ;
 $ver_string = $type->{Versions}{$version}
index 41a24f4..55439ee 100644 (file)
@@ -1,8 +1,8 @@
 # typemap for Perl 5 interface to Berkeley 
 #
 # written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 7th September 1999
-# version 1.71
+# last modified 10th December 2000
+# version 1.74
 #
 #################################### DB SECTION
 #
@@ -29,9 +29,10 @@ T_dbtkeydatum
 T_dbtdatum
        ckFilter($arg, filter_store_value, \"filter_store_value\");
        DBT_clear($var) ;
-       $var.data = SvPV($arg, PL_na);
-       $var.size = (int)PL_na;
-
+       if (SvOK($arg)) {
+           $var.data = SvPV($arg, PL_na);
+           $var.size = (int)PL_na;
+       }
 
 OUTPUT
 
index f3e2c94..6e55b2e 100644 (file)
@@ -17,6 +17,8 @@
                Support for Berkeley DB 2/3's backward compatability mode.
         1.72 -  No change.
         1.73 -  Added support for threading
+        1.74 -  Added Perl core patch 7801.
+
 
 */
 
 #include <db.h>
 
 void
+#ifdef CAN_PROTOTYPE
+__getBerkeleyDBInfo(void)
+#else
 __getBerkeleyDBInfo()
+#endif
 {
 #ifdef dTHX    
     dTHX;
index 7167a00..8f28c6e 100644 (file)
@@ -3,11 +3,6 @@
 #include "perl.h"
 #include "XSUB.h"
 
-/* For older Perls */
-#ifndef dTHR
-#  define dTHR int dummy_thr
-#endif /* dTHR */ 
-
 /*#define DBG_SUB 1      */
 /*#define DBG_TIMER 1    */
 
@@ -388,7 +383,6 @@ prof_mark(pTHX_ opcode ptype)
 static void
 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
 {
-    dTHR;
     CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
     int i, j, k = 0;
     HV *oldstash = PL_curstash;
index e5fc8ae..312f5f8 100644 (file)
@@ -140,6 +140,7 @@ struct mstats_buffer
 void
 _fill_mstats(struct mstats_buffer *b, int level)
 {
+    dTHX;
     b->buffer.nfree  = b->buf;
     b->buffer.ntotal = b->buf + _NBUCKETS;
     b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS;
@@ -151,6 +152,7 @@ _fill_mstats(struct mstats_buffer *b, int level)
 void
 fill_mstats(SV *sv, int level)
 {
+    dTHX;
     int nbuckets;
     struct mstats_buffer buf;
 
@@ -166,6 +168,7 @@ fill_mstats(SV *sv, int level)
 void
 _mstats_to_hv(HV *hv, struct mstats_buffer *b, int level)
 {
+    dTHX;
     SV **svp;
     int type;
 
index b7b45d8..266c9d0 100644 (file)
@@ -1,4 +1,3 @@
-
 use Config;
 
 sub to_string {
@@ -12,7 +11,7 @@ unlink "DynaLoader.pm" if -f "DynaLoader.pm";
 open OUT, ">DynaLoader.pm" or die $!;
 print OUT <<'EOT';
 
-# Generated from DynaLoader.pm.PL (resolved %Config::Config values)
+# Generated from DynaLoader.pm.PL
 
 package DynaLoader;
 
@@ -28,11 +27,15 @@ package DynaLoader;
 #
 # Tim.Bunce@ig.co.uk, August 1994
 
-$VERSION = "1.04";     # avoid typo warning
+use vars qw($VERSION *AUTOLOAD);
+
+$VERSION = 1.04;       # avoid typo warning
 
 require AutoLoader;
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;
 
+use Config;
+
 # The following require can't be removed during maintenance
 # releases, sadly, because of the risk of buggy code that does 
 # require Carp; Carp::croak "..."; without brackets dying 
@@ -40,7 +43,6 @@ require AutoLoader;
 # We'll let those bugs get found on the development track.
 require Carp if $] < 5.00450; 
 
-
 # enable debug/trace messages from DynaLoader perl code
 $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
 
@@ -71,48 +73,112 @@ print OUT <<'EOT';
 # (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
 # See dl_expandspec() for more details. Should be harmless but
 # inefficient to define on systems that don't need it.
-$do_expand = $Is_VMS = $^O eq 'VMS';
+$Is_VMS    = $^O eq 'VMS';
+$do_expand = $Is_VMS;
 $Is_MacOS  = $^O eq 'MacOS';
 
 @dl_require_symbols = ();       # names of symbols we need
 @dl_resolve_using   = ();       # names of files to link with
 @dl_library_path    = ();       # path to look for files
-#@dl_librefs         = ();       # things we have loaded
-#@dl_modules         = ();       # Modules we have loaded
+@dl_librefs         = ();       # things we have loaded
+@dl_modules         = ();       # Modules we have loaded
 
 # This is a fix to support DLD's unfortunate desire to relink -lc
 @dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
 
-# Initialise @dl_library_path with the 'standard' library path
-# for this platform as determined by Configure
+EOT
 
-# push(@dl_library_path, split(' ', $Config::Config{'libpth'});
+my $cfg_dl_library_path = <<'EOT';
+push(@dl_library_path, split(' ', $Config::Config{libpth}));
 EOT
 
-print OUT "push(\@dl_library_path, split(' ', ",
-          to_string($Config::Config{'libpth'}), "));\n";
+sub dquoted_comma_list {
+    join(", ", map {qq("$_")} @_);
+}
 
-print OUT <<'EOT';
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
+    eval $cfg_dl_library_path;
+    if (!$ENV{PERL_BUILD_EXPAND_ENV_VARS}) {
+        my $dl_library_path = dquoted_comma_list(@dl_library_path);
+        print OUT <<EOT;
+# The below \@dl_library_path has been expanded (%Config) in Perl build time.
+
+\@dl_library_path = ($dl_library_path);
+
+EOT
+    }
+}
+else {
+    print OUT <<EOT;
+# Initialise \@dl_library_path with the 'standard' library path
+# for this platform as determined by Configure.
+
+$cfg_dl_library_path
+
+EOT
+}
+
+my $ldlibpthname;
+my $ldlibpthname_defined;
+my $pthsep;
+
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
+    $ldlibpthname         = $Config::Config{ldlibpthname};
+    $ldlibpthname_defined = defined $Config::Config{ldlibpthname} ? 1 : 0;
+    $pthsep               = $Config::Config{path_sep};
+}
+else {
+    $ldlibpthname         = q($Config::Config{ldlibpthname});
+    $ldlibpthname_defined = q(defined $Config::Config{ldlibpthname});
+    $pthsep               = q($Config::Config{path_sep});
+    print OUT <<EOT;
+my \$ldlibpthname         = $ldlibpthname;
+my \$ldlibpthname_defined = $ldlibpthname_defined;
+my \$pthsep               = $pthsep;
+
+EOT
+}
+
+my $env_dl_library_path = <<'EOT';
+if ($ldlibpthname_defined &&
+    exists $ENV{$ldlibpthname}) {
+    push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
+}
 
-# Add to @dl_library_path any extra directories we can gather
-# from environment variables.
-if ($Is_MacOS) {
-    push(@dl_library_path, split(/,/, $ENV{LD_LIBRARY_PATH}))
-       if exists $ENV{LD_LIBRARY_PATH};
-} else {
-    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
-       if exists      $Config::Config{ldlibpthname}        &&
-                       $Config::Config{ldlibpthname}  ne '' &&
-                exists $ENV{$Config::Config{ldlibpthname}}       ;;
-    push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}}))
-       if exists      $Config::Config{ldlibpthname}        &&
-                       $Config::Config{ldlibpthname}  ne '' &&
-                exists $ENV{$Config::Config{ldlibpthname}}       ;;
 # E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
-push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH}))
-    if exists $ENV{LD_LIBRARY_PATH};
+
+if ($ldlibpthname_defined &&
+    $ldlibpthname ne 'LD_LIBRARY_PATH' &&
+    exists $ENV{LD_LIBRARY_PATH}) {
+    push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
 }
+EOT
+
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) {
+    eval $env_dl_library_path;
+}
+else {
+    print OUT <<EOT;
+# Add to \@dl_library_path any extra directories we can gather from environment
+# during runtime.
+
+$env_dl_library_path
 
+EOT
+}
+
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) {
+    my $dl_library_path = dquoted_comma_list(@dl_library_path);
+    print OUT <<EOT;
+# The below \@dl_library_path has been expanded (%Config, %ENV)
+# in Perl build time.
+
+\@dl_library_path = ($dl_library_path);
+
+EOT
+}
+
+print OUT <<'EOT';
 # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
 # NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
 boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
@@ -198,7 +264,7 @@ sub bootstrap {
     croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
        unless $file;   # wording similar to error from 'require'
 
-    $file = uc($file) if $Is_VMS && $Config{d_vms_case_sensitive_symbols};
+    $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols};
     my $bootname = "boot_$module";
     $bootname =~ s/\W/_/g;
     @dl_require_symbols = ($bootname);
@@ -326,7 +392,7 @@ print OUT <<'EOT';
         #  (this is a more complicated issue than it first appears)
         if (m:/: && -d $_) {   push(@dirs, $_); next; }
 
-        # VMS: we may be using native VMS directry syntax instead of
+        # VMS: we may be using native VMS directory syntax instead of
         # Unix emulation, so check this as well
         if ($Is_VMS && /[:>\]]/ && -d $_) {   push(@dirs, $_); next; }
 
index d6acc68..89b8439 100644 (file)
@@ -11,6 +11,8 @@
  *  on statup...   It can probably be trimmed more.
  */
 
+#define PERLIO_NOT_STDIO 0
+
 /*
  * @(#)dlfcn.c 1.5 revision of 93/02/14  20:14:17
  * This is an unpublished work copyright (c) 1992 Helios Software GmbH
 # define FREAD(p,s,n,ldptr)    fread(p,s,n,IOPTR(ldptr))
 #endif
 
-/* If using PerlIO, redefine these macros from <ldfcn.h> */
-#ifdef USE_PERLIO
-#undef FSEEK
-#undef FREAD
-#define FSEEK(ldptr,o,p)        PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p)
-#define FREAD(p,s,n,ldptr)      PerlIO_read(IOPTR(ldptr),p,s*n)
-#endif
-
 /*
  * We simulate dlopen() et al. through a call to load. Because AIX has
  * no call to find an exported symbol we read the loader section of the
@@ -532,11 +526,7 @@ static int readExports(ModulePtr mp)
        }
 /* This first case is a hack, since it assumes that the 3rd parameter to
    FREAD is 1. See the redefinition of FREAD above to see how this works. */
-#ifdef USE_PERLIO
-       if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) {
-#else
        if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {
-#endif
                errvalid++;
                strcpy(errbuf, "readExports: cannot read loader section");
                safefree(ldbuf);
index 8ba7232..1f4ffb1 100644 (file)
@@ -22,6 +22,10 @@ require Exporter;
        off_utf8
        utf_to_utf
        encodings
+       utf8_decode
+       utf8_encode
+       utf8_upgrade
+       utf8_downgrade
       );
 
 bootstrap Encode ();
@@ -340,9 +344,9 @@ sub from_to
  return length($_[0] = $string);
 }
 
-my %encoding = ( Unicode      => bless({},'Encode::Unicode'),
-                 'iso10646-1' => bless({},'Encode::iso10646_1'),
-               );
+# The global hash is declared in XS code
+$encoding{Unicode}    = bless({},'Encode::Unicode');
+$encoding{'iso10646-1'} = bless({},'Encode::iso10646_1');
 
 sub encodings
 {
@@ -378,6 +382,7 @@ sub loadEncoding
      last unless $type eq '#';
     }
    $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table'));
+   #warn "Loading $file";
    return $class->read($fh,$name,$type);
   }
  else
@@ -407,13 +412,20 @@ sub getEncoding
 
 package Encode::Unicode;
 
-# Dummy package that provides the encode interface
+# Dummy package that provides the encode interface but leaves data
+# as UTF-8 encoded. It is here so that from_to() works.
 
 sub name { 'Unicode' }
 
-sub toUnicode   { $_[1] }
+sub toUnicode
+{
+ my ($obj,$str,$chk) = @_;
+ Encode::utf8_upgrade($str);
+ $_[1] = '' if $chk;
+ return $str;
+}
 
-sub fromUnicode { $_[1] }
+*fromUnicode = \&toUnicode;
 
 package Encode::Table;
 
@@ -532,7 +544,9 @@ sub fromUnicode
  return $str;
 }
 
-package Encode::iso10646_1;#
+package Encode::iso10646_1;
+# Encoding is 16-bit network order Unicode
+# Used for X font encodings
 
 sub name { 'iso10646-1' }
 
@@ -546,6 +560,7 @@ sub toUnicode
    $uni .= chr($code);
   }
  $_[1] = $str if $chk;
+ Encode::utf8_upgrade($uni);
  return $uni;
 }
 
@@ -568,6 +583,7 @@ sub fromUnicode
  return $str;
 }
 
+
 package Encode::Escape;
 use Carp;
 
index c231bba..a7acd88 100644 (file)
@@ -1,6 +1,11 @@
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+#define U8 U8
+#include "encode.h"
+#include "iso8859.h"
+#include "EBCDIC.h"
+#include "Symbols.h"
 
 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {   \
                          Perl_croak(aTHX_ "panic_unimplemented"); \
 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
 
+#ifdef USE_PERLIO
+/* Define an encoding "layer" in the perliol.h sense.
+   The layer defined here "inherits" in an object-oriented sense from the
+   "perlio" layer with its PerlIOBuf_* "methods".
+   The implementation is particularly efficient as until Encode settles down
+   there is no point in tryint to tune it.
+
+   The layer works by overloading the "fill" and "flush" methods.
+
+   "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
+   to convert the encoded data to UTF-8 form, then copies it back to the
+   buffer. The "base class's" read methods then see the UTF-8 data.
+
+   "flush" transforms the UTF-8 data deposited by the "base class's write
+   method in the buffer back into the encoded form using the encode OO perl API,
+   then copies data back into the buffer and calls "SUPER::flush.
+
+   Note that "flush" is _also_ called for read mode - we still do the (back)-translate
+   so that the the base class's "flush" sees the correct number of encoded chars
+   for positioning the seek pointer. (This double translation is the worst performance
+   issue - particularly with all-perl encode engine.)
+
+*/
+
+
+#include "perliol.h"
+
+typedef struct
+{
+ PerlIOBuf     base;         /* PerlIOBuf stuff */
+ SV *          bufsv;
+ SV *          enc;
+} PerlIOEncode;
+
+
+IV
+PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ dSP;
+ IV code;
+ code = PerlIOBuf_pushed(f,mode,Nullch,0);
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVpv("Encode",0)));
+ XPUSHs(sv_2mortal(newSVpvn(arg,len)));
+ PUTBACK;
+ if (perl_call_method("getEncoding",G_SCALAR) != 1)
+  return -1;
+ SPAGAIN;
+ e->enc = POPs;
+ PUTBACK;
+ if (!SvROK(e->enc))
+  return -1;
+ SvREFCNT_inc(e->enc);
+ FREETMPS;
+ LEAVE;
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+ return code;
+}
+
+IV
+PerlIOEncode_popped(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ if (e->enc)
+  {
+   SvREFCNT_dec(e->enc);
+   e->enc = Nullsv;
+  }
+ if (e->bufsv)
+  {
+   SvREFCNT_dec(e->bufsv);
+   e->bufsv = Nullsv;
+  }
+ return 0;
+}
+
+STDCHAR *
+PerlIOEncode_get_base(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ if (!e->base.bufsiz)
+  e->base.bufsiz = 1024;
+ if (!e->bufsv)
+  {
+   e->bufsv = newSV(e->base.bufsiz);
+   sv_setpvn(e->bufsv,"",0);
+  }
+ e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
+ if (!e->base.ptr)
+  e->base.ptr = e->base.buf;
+ if (!e->base.end)
+  e->base.end = e->base.buf;
+ if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
+  {
+   Perl_warn(aTHX_ " ptr %p(%p)%p",
+             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
+   abort();
+  }
+ if (SvLEN(e->bufsv) < e->base.bufsiz)
+  {
+   SSize_t poff = e->base.ptr - e->base.buf;
+   SSize_t eoff = e->base.end - e->base.buf;
+   e->base.buf  = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz);
+   e->base.ptr  = e->base.buf + poff;
+   e->base.end  = e->base.buf + eoff;
+  }
+ if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
+  {
+   Perl_warn(aTHX_ " ptr %p(%p)%p",
+             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
+   abort();
+  }
+ return e->base.buf;
+}
+
+IV
+PerlIOEncode_fill(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ dSP;
+ IV code;
+ code = PerlIOBuf_fill(f);
+ if (code == 0)
+  {
+   SV *uni;
+   STRLEN len;
+   char *s;
+   /* Set SV that is the buffer to be buf..ptr */
+   SvCUR_set(e->bufsv, e->base.end - e->base.buf);
+   SvUTF8_off(e->bufsv);
+   ENTER;
+   SAVETMPS;
+   PUSHMARK(sp);
+   XPUSHs(e->enc);
+   XPUSHs(e->bufsv);
+   XPUSHs(&PL_sv_yes);
+   PUTBACK;
+   if (perl_call_method("toUnicode",G_SCALAR) != 1)
+    code = -1;
+   SPAGAIN;
+   uni = POPs;
+   PUTBACK;
+   /* Now get translated string (forced to UTF-8) and copy back to buffer
+      don't use sv_setsv as that may "steal" PV from returned temp
+      and so free() our known-large-enough buffer.
+      sv_setpvn() should do but let us do it long hand.
+    */
+   s = SvPVutf8(uni,len);
+   if (s != SvPVX(e->bufsv))
+    {
+     e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
+     Move(s,e->base.buf,len,char);
+     SvCUR_set(e->bufsv,len);
+    }
+   SvUTF8_on(e->bufsv);
+   e->base.end    = e->base.buf+len;
+   e->base.ptr    = e->base.buf;
+   FREETMPS;
+   LEAVE;
+  }
+ return code;
+}
+
+IV
+PerlIOEncode_flush(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ IV code = 0;
+ dTHX;
+ if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF)))
+  {
+   dSP;
+   SV *str;
+   char *s;
+   STRLEN len;
+   SSize_t left = 0;
+   if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+    {
+     /* This is really just a flag to see if we took all the data, if
+        we did PerlIOBase_flush avoids a seek to lower layer.
+        Need to revisit if we start getting clever with unreads or seeks-in-buffer
+      */
+     left = e->base.end - e->base.ptr;
+    }
+   ENTER;
+   SAVETMPS;
+   PUSHMARK(sp);
+   XPUSHs(e->enc);
+   SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
+   SvUTF8_on(e->bufsv);
+   XPUSHs(e->bufsv);
+   XPUSHs(&PL_sv_yes);
+   PUTBACK;
+   if (perl_call_method("fromUnicode",G_SCALAR) != 1)
+    code = -1;
+   SPAGAIN;
+   str = POPs;
+   PUTBACK;
+   s = SvPV(str,len);
+   if (s != SvPVX(e->bufsv))
+    {
+     e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
+     Move(s,e->base.buf,len,char);
+     SvCUR_set(e->bufsv,len);
+    }
+   SvUTF8_off(e->bufsv);
+   e->base.ptr = e->base.buf+len;
+   /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */
+   e->base.end = e->base.ptr + left;
+   FREETMPS;
+   LEAVE;
+   if (PerlIOBuf_flush(f) != 0)
+    code = -1;
+  }
+ return code;
+}
+
+IV
+PerlIOEncode_close(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ IV code = PerlIOBase_close(f);
+ dTHX;
+ if (e->bufsv)
+  {
+   SvREFCNT_dec(e->bufsv);
+   e->bufsv = Nullsv;
+  }
+ e->base.buf = NULL;
+ e->base.ptr = NULL;
+ e->base.end = NULL;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+Off_t
+PerlIOEncode_tell(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ /* Unfortunately the only way to get a postion is to back-translate,
+    the UTF8-bytes we have buf..ptr and adjust accordingly.
+    But we will try and save any unread data in case stream
+    is un-seekable.
+  */
+ if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end)
+  {
+   Size_t count = b->end - b->ptr;
+   PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
+   /* Save what we have left to read */
+   PerlIOSelf(f,PerlIOBuf)->bufsiz = count;
+   PerlIO_unread(f,b->ptr,count);
+   /* There isn't any unread data - we just saved it - so avoid the lower seek */
+   b->end = b->ptr;
+   /* Flush ourselves - now one layer down,
+      this does the back translate and adjusts position
+    */
+   PerlIO_flush(PerlIONext(f));
+   /* Set position of the saved data */
+   PerlIOSelf(f,PerlIOBuf)->posn = b->posn;
+  }
+ else
+  {
+   PerlIO_flush(f);
+  }
+ return b->posn;
+}
+
+PerlIO_funcs PerlIO_encode = {
+ "encoding",
+ sizeof(PerlIOEncode),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOEncode_pushed,
+ PerlIOEncode_popped,
+ PerlIOBuf_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOBuf_seek,
+ PerlIOEncode_tell,
+ PerlIOEncode_close,
+ PerlIOEncode_flush,
+ PerlIOEncode_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOEncode_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+#endif
+
+void
+Encode_Define(pTHX_ encode_t *enc)
+{
+ HV *hash  = get_hv("Encode::encoding",GV_ADD|GV_ADDMULTI);
+ HV *stash = gv_stashpv("Encode::XS", TRUE);
+ SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
+ hv_store(hash,enc->name,strlen(enc->name),sv,0);
+}
+
 void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}
 
+static SV *
+encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check)
+{
+ STRLEN slen;
+ U8 *s = (U8 *) SvPV(src,slen);
+ SV *dst = sv_2mortal(newSV(2*slen+1));
+ if (slen)
+  {
+   U8 *d = (U8 *) SvGROW(dst, 2*slen+1);
+   STRLEN dlen = SvLEN(dst);
+   int code;
+   while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
+    {
+     SvCUR_set(dst,dlen);
+     SvPOK_on(dst);
+
+     if (code == ENCODE_FALLBACK)
+      break;
+
+     switch(code)
+      {
+       case ENCODE_NOSPACE:
+        {
+         STRLEN need = (slen) ? (SvLEN(dst)*SvCUR(src)/slen) : (dlen + UTF8_MAXLEN);
+         if (need <= SvLEN(dst))
+          need += UTF8_MAXLEN;
+         d = (U8 *) SvGROW(dst, need);
+         dlen = SvLEN(dst);
+         slen = SvCUR(src);
+         break;
+        }
+
+       case ENCODE_NOREP:
+        if (dir == enc->f_utf8)
+         {
+          if (!check && ckWARN_d(WARN_UTF8))
+           {
+            STRLEN clen;
+            UV ch = utf8_to_uv(s+slen,(SvCUR(src)-slen),&clen,0);
+            Perl_warner(aTHX_ WARN_UTF8, "\"\\x{%x}\" does not map to %s", ch, enc->name);
+            /* FIXME: Skip over the character, copy in replacement and continue
+             * but that is messy so for now just fail.
+             */
+            return &PL_sv_undef;
+           }
+          else
+           {
+            return &PL_sv_undef;
+           }
+         }
+        else
+         {
+          /* UTF-8 is supposed to be "Universal" so should not happen */
+          Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
+                 enc->name, (SvCUR(src)-slen),s+slen);
+         }
+        break;
+
+       case ENCODE_PARTIAL:
+         if (!check && ckWARN_d(WARN_UTF8))
+          {
+           Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
+                       (dir == enc->f_utf8) ? "UTF-8" : enc->name);
+          }
+         return &PL_sv_undef;
+
+       default:
+        Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
+                 code, (dir == enc->f_utf8) ? "to" : "from",enc->name);
+        return &PL_sv_undef;
+      }
+    }
+   SvCUR_set(dst,dlen);
+   SvPOK_on(dst);
+   if (check)
+    {
+     if (slen < SvCUR(src))
+      {
+       Move(s+slen,s,SvCUR(src)-slen,U8);
+      }
+     SvCUR_set(src,SvCUR(src)-slen);
+    }
+  }
+ return dst;
+}
+
+MODULE = Encode                PACKAGE = Encode        PREFIX = sv_
+
+void
+valid_utf8(sv)
+SV *   sv
+CODE:
+ {
+  STRLEN len;
+  char *s = SvPV(sv,len);
+  if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
+   XSRETURN_YES;
+  else
+   XSRETURN_NO;
+ }
+
+void
+sv_utf8_encode(sv)
+SV *   sv
+
+bool
+sv_utf8_decode(sv)
+SV *   sv
+
+void
+sv_utf8_upgrade(sv)
+SV *   sv
+
+bool
+sv_utf8_downgrade(sv,failok=0)
+SV *   sv
+bool   failok
+
+MODULE = Encode                PACKAGE = Encode::XS    PREFIX = Encode_
+
+PROTOTYPES: ENABLE
+
+void
+Encode_toUnicode(obj,src,check = 0)
+SV *   obj
+SV *   src
+int    check
+CODE:
+ {
+  encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+  ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
+  SvUTF8_on(ST(0));
+  XSRETURN(1);
+ }
+
+void
+Encode_fromUnicode(obj,src,check = 0)
+SV *   obj
+SV *   src
+int    check
+CODE:
+ {
+  encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
+  sv_utf8_upgrade(src);
+  ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
+  XSRETURN(1);
+ }
+
 MODULE = Encode         PACKAGE = Encode
 
 PROTOTYPES: ENABLE
@@ -182,7 +648,7 @@ _is_utf8(sv, ...)
        {
          SV *  check = items == 2 ? ST(1) : Nullsv;
          if (SvPOK(sv)) {
-           RETVAL = SvUTF8(sv);
+           RETVAL = SvUTF8(sv) ? 1 : 0;
            if (RETVAL &&
                SvTRUE(check) &&
                !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
@@ -239,3 +705,12 @@ _utf_to_utf(sv, from, to, ...)
       OUTPUT:
        RETVAL
 
+BOOT:
+{
+#ifdef USE_PERLIO
+ PerlIO_define_layer(&PerlIO_encode);
+#endif
+#include "iso8859.def"
+#include "EBCDIC.def"
+#include "Symbols.def"
+}
diff --git a/ext/Encode/Encode/EncodeFormat.pod b/ext/Encode/Encode/EncodeFormat.pod
new file mode 100644 (file)
index 0000000..d83b128
--- /dev/null
@@ -0,0 +1,164 @@
+=head1 NAME
+
+EncodeFormat - the format of encoding tables of the Encode extension
+
+=head1 DESCRIPTION
+
+I<The format used in the encoding tables of the Encode extension has
+been borrowed from Tcl, as has the following documentation been borrowed
+from the same.  The documentation has been reformatted as Perl pod.>
+
+Space would prohibit precompiling into Tcl every possible encoding
+algorithm, so many encodings are stored on disk as dynamically-loadable
+encoding files.  This behavior also allows the user to create additional
+encoding files that can be loaded using the same mechanism.  These
+encoding files contain information about the tables and/or escape
+sequences used to map between an external encoding and Unicode.  The
+external encoding may consist of single-byte, multi-byte, or double-byte
+characters.
+
+Each dynamically-loadable encoding is represented as a text file.  The
+initial line of the file, beginning with a ``#'' symbol, is a comment
+that provides a human-readable description of the file.  The next line
+identifies the type of encoding file.  It can be one of the following
+letters:
+
+=over 4
+
+=item [1]   B<S>
+
+A single-byte encoding, where one character is always one byte long in
+the encoding.  An example is B<iso8859-1>, used by many European languages.
+
+=item [2]   B<D>
+
+A double-byte encoding, where one character is always two bytes long in the
+encoding.  An example is B<big5>, used for Chinese text.
+
+=item [3]   B<M>
+
+A multi-byte encoding, where one character may be either one or two
+bytes long.  Certain bytes are a lead bytes, indicating that another
+byte must follow and that together the two bytes represent one
+character.  Other bytes are not lead bytes and represent themselves.
+An example is B<shiftjis>, used by many Japanese computers.
+
+=item [4]   B<E>
+
+An escape-sequence encoding, specifying that certain sequences of
+bytes do not represent characters, but commands that describe how
+following bytes should be interpreted.
+
+=back
+
+The rest of the lines in the file depend on the type.
+
+Cases [1], [2], and [3] are collectively referred to as table-based
+encoding files.  The lines in a table-based encoding file are in the
+same format as this example taken from the B<shiftjis> encoding (this
+is not the complete file):
+
+ # Encoding file: shiftjis, multi-byte
+ M
+ 003F 0 40
+ 00
+ 0000000100020003000400050006000700080009000A000B000C000D000E000F
+ 0010001100120013001400150016001700180019001A001B001C001D001E001F
+ 0020002100220023002400250026002700280029002A002B002C002D002E002F
+ 0030003100320033003400350036003700380039003A003B003C003D003E003F
+ 0040004100420043004400450046004700480049004A004B004C004D004E004F
+ 0050005100520053005400550056005700580059005A005B005C005D005E005F
+ 0060006100620063006400650066006700680069006A006B006C006D006E006F
+ 0070007100720073007400750076007700780079007A007B007C007D203E007F
+ 0080000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
+ FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
+ FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
+ FF90FF91FF92FF93FF94FF95FF96FF97FF98FF99FF9AFF9BFF9CFF9DFF9EFF9F
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 81
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 300030013002FF0CFF0E30FBFF1AFF1BFF1FFF01309B309C00B4FF4000A8FF3E
+ FFE3FF3F30FD30FE309D309E30034EDD30053006300730FC20152010FF0F005C
+ 301C2016FF5C2026202520182019201C201DFF08FF0930143015FF3BFF3DFF5B
+ FF5D30083009300A300B300C300D300E300F30103011FF0B221200B100D70000
+ 00F7FF1D2260FF1CFF1E22662267221E22342642264000B0203220332103FFE5
+ FF0400A200A3FF05FF03FF06FF0AFF2000A72606260525CB25CF25CE25C725C6
+ 25A125A025B325B225BD25BC203B301221922190219121933013000000000000
+ 000000000000000000000000000000002208220B2286228722822283222A2229
+ 000000000000000000000000000000002227222800AC21D221D4220022030000
+ 0000000000000000000000000000000000000000222022A52312220222072261
+ 2252226A226B221A223D221D2235222B222C0000000000000000000000000000
+ 212B2030266F266D266A2020202100B6000000000000000025EF000000000000
+
+The third line of the file is three numbers.  The first number is the
+fallback character (in base 16) to use when converting from UTF-8 to
+this encoding.  The second number is a B<1> if this file represents
+the encoding for a symbol font, or B<0> otherwise.  The last number
+(in base 10) is how many pages of data follow.
+
+Subsequent lines in the example above are pages that describe how to
+map from the encoding into 2-byte Unicode.  The first line in a page
+identifies the page number.  Following it are 256 double-byte numbers,
+arranged as 16 rows of 16 numbers.  Given a character in the encoding,
+the high byte of that character is used to select which page, and the
+low byte of that character is used as an index to select one of the
+double-byte numbers in that page - the value obtained being the
+corresponding Unicode character.  By examination of the example above,
+one can see that the characters 0x7E and 0x8163 in B<shiftjis> map to
+203E and 2026 in Unicode, respectively.
+
+Following the first page will be all the other pages, each in the same
+format as the first: one number identifying the page followed by 256
+double-byte Unicode characters.  If a character in the encoding maps
+to the Unicode character 0000, it means that the character doesn't
+actually exist.  If all characters on a page would map to 0000, that
+page can be omitted.
+
+Case [4] is the escape-sequence encoding file.  The lines in an this
+type of file are in the same format as this example taken from the
+B<iso2022-jp> encoding:
+
+ # Encoding file: iso2022-jp, escape-driven
+ E
+ init          {}
+ final         {}
+ iso8859-1     \\x1b(B
+ jis0201               \\x1b(J
+ jis0208               \\x1b$@
+ jis0208               \\x1b$B
+ jis0212               \\x1b$(D
+ gb2312                \\x1b$A
+ ksc5601               \\x1b$(C
+
+In the file, the first column represents an option and the second
+column is the associated value.  B<init> is a string to emit or expect
+before the first character is converted, while B<final> is a string to
+emit or expect after the last character.  All other options are names
+of table-based encodings; the associated value is the escape-sequence
+that marks that encoding.  Tcl syntax is used for the values; in the
+above example, for instance, ``B<{}>'' represents the empty string and
+``B<\\x1b>'' represents character 27.
+
+B<Completely Tcl-specific paragraph, ignore in the context of Perl>
+When B<Tcl_GetEncoding> encounters an encoding I<name> that has not
+been loaded, it attempts to load an encoding file called
+I<name>B<.enc> from the B<encoding> subdirectory of each directory
+specified in the library path B<$tcl_libPath>.  If the encoding file
+exists, but is malformed, an error message will be left in I<interp>.
+
+=head1 KEYWORDS
+
+utf, encoding, convert
+
+=head1 COPYRIGHT
+
+  #  Copyright (c) 1997-1998 Sun Microsystems, Inc.
+  #  See the file "license.terms" for information on usage and redistribution
+  #  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+  #  RCS: @(#) $Id: Encoding.3,v 1.7 1999/10/13 00:32:05 hobbs Exp $
index e0320b8..284a9f5 100644 (file)
@@ -9,7 +9,7 @@ S
 0040004100420043004400450046004700480049004A004B004C004D004E004F
 0050005100520053005400550056005700580059005A005B005C005D005E005F
 0060006100620063006400650066006700680069006A006B006C006D006E006F
-0070007100720073007400750076007700780079007A007B007C007D007E0000
+0070007100720073007400750076007700780079007A007B007C007D007E007F
 0000000000000000000000000000000000000000000000000000000000000000
 0000000000000000000000000000000000000000000000000000000000000000
 0000000000000000000000000000000000000000000000000000000000000000
diff --git a/ext/Encode/Encode/cp1006.enc b/ext/Encode/Encode/cp1006.enc
new file mode 100644 (file)
index 0000000..3ba00dd
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: cp1006, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A006F006F106F206F306F406F506F606F706F806F9060C061B00AD061FFE81
+FE8DFE8EFE8EFE8FFE91FB56FB58FE93FE95FE97FB66FB68FE99FE9BFE9DFE9F
+FB7AFB7CFEA1FEA3FEA5FEA7FEA9FB84FEABFEADFB8CFEAFFB8AFEB1FEB3FEB5
+FEB7FEB9FEBBFEBDFEBFFEC1FEC5FEC9FECAFECBFECCFECDFECEFECFFED0FED1
+FED3FED5FED7FED9FEDBFB92FB94FEDDFEDFFEE0FEE1FEE3FB9EFEE5FEE7FE85
+FEEDFBA6FBA8FBA9FBAAFE80FE89FE8AFE8BFEF1FEF2FEF3FBB0FBAEFE7CFE7D
diff --git a/ext/Encode/Encode/cp1047.enc b/ext/Encode/Encode/cp1047.enc
new file mode 100644 (file)
index 0000000..8956fa4
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: cp1047 (EBCDIC), single-byte
+S
+006F 0 1
+00
+0000000100020003009C00090086007F0097008D008E000B000C000D000E000F
+0010001100120013009D000A00080087001800190092008F001C001D001E001F
+0080008100820083008400850017001B00880089008A008B008C000500060007
+0090009100160093009400950096000400980099009A009B00140015009E001A
+002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C
+002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B005E
+002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F
+00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022
+00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1
+00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4
+00B5007E0073007400750076007700780079007A00A100BF00D0005B00DE00AE
+00AC00A300A500B700A900A700B600BC00BD00BE00DD00A800AF005D00B400D7
+007B00410042004300440045004600470048004900AD00F400F600F200F300F5
+007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF
+005C00F70053005400550056005700580059005A00B200D400D600D200D300D5
+003000310032003300340035003600370038003900B300DB00DC00D900DA009F
diff --git a/ext/Encode/Encode/cp37.enc b/ext/Encode/Encode/cp37.enc
new file mode 100644 (file)
index 0000000..94d8c33
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: cp37 (EBCDIC), single-byte
+S
+006F 0 1
+00
+0000000100020003009C00090086007F0097008D008E000B000C000D000E000F
+0010001100120013009D008500080087001800190092008F001C001D001E001F
+00800081008200830084000A0017001B00880089008A008B008C000500060007
+0090009100160093009400950096000400980099009A009B00140015009E001A
+002000A000E200E400E000E100E300E500E700F100A2002E003C0028002B007C
+002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B00AC
+002D002F00C200C400C000C100C300C500C700D100A6002C0025005F003E003F
+00F800C900CA00CB00C800CD00CE00CF00CC0060003A002300400027003D0022
+00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1
+00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4
+00B5007E0073007400750076007700780079007A00A100BF00D000DD00DE00AE
+005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7
+007B00410042004300440045004600470048004900AD00F400F600F200F300F5
+007D004A004B004C004D004E004F00500051005200B900FB00FC00F900FA00FF
+005C00F70053005400550056005700580059005A00B200D400D600D200D300D5
+003000310032003300340035003600370038003900B300DB00DC00D900DA009F
diff --git a/ext/Encode/Encode/cp424.enc b/ext/Encode/Encode/cp424.enc
new file mode 100644 (file)
index 0000000..3b0c23e
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: cp424, single-byte
+S
+003F 0 1
+00
+0000000100020003009C00090086007F0097008D008E000B000C000D000E000F
+0010001100120013009D008500080087001800190092008F001C001D001E001F
+00800081008200830084000A0017001B00880089008A008B008C000500060007
+0090009100160093009400950096000400980099009A009B00140015009E001A
+002005D005D105D205D305D405D505D605D705D800A2002E003C0028002B007C
+002605D905DA05DB05DC05DD05DE05DF05E005E100210024002A0029003B00AC
+002D002F05E205E305E405E505E605E705E805E900A6002C0025005F003E003F
+000005EA0000000000A000000000000020170060003A002300400027003D0022
+000000610062006300640065006600670068006900AB00BB00000000000000B1
+00B0006A006B006C006D006E006F00700071007200000000000000B8000000A4
+00B5007E0073007400750076007700780079007A0000000000000000000000AE
+005E00A300A500B700A900A700B600BC00BD00BE005B005D00AF00A800B400D7
+007B00410042004300440045004600470048004900AD00000000000000000000
+007D004A004B004C004D004E004F00500051005200B900000000000000000000
+005C00F70053005400550056005700580059005A00B200000000000000000000
+003000310032003300340035003600370038003900B30000000000000000009F
diff --git a/ext/Encode/Encode/cp856.enc b/ext/Encode/Encode/cp856.enc
new file mode 100644 (file)
index 0000000..cab493c
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: cp856, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+05D005D105D205D305D405D505D605D705D805D905DA05DB05DC05DD05DE05DF
+05E005E105E205E305E405E505E605E705E805E905EA000000A3000000D70000
+00000000000000000000000000000000000000AE00AC00BD00BC000000AB00BB
+2591259225932502252400000000000000A9256325512557255D00A200A52510
+25142534252C251C2500253C00000000255A25542569256625602550256C00A4
+0000000000000000000000000000000000002518250C2588258400A600002580
+00000000000000000000000000B5000000000000000000000000000000AF00B4
+00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0
diff --git a/ext/Encode/Encode/gsm0338.enc b/ext/Encode/Encode/gsm0338.enc
new file mode 100644 (file)
index 0000000..bf09e70
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: GSM 03.38, single-byte
+S
+003F 0 1
+00
+004000A3002400A500E800E900F900EC00F200E7000A00D800F8000D00C500E5
+0394005F03A60393039B03A903A003A803A30398039E00A000C600E600DF00C9
+002000210022002300A400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+00A1004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A00C400D600D100DC00A7
+00BF006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A00E400F600F100FC00E0
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
diff --git a/ext/Encode/Encode/iso8859-10.enc b/ext/Encode/Encode/iso8859-10.enc
new file mode 100644 (file)
index 0000000..934b3b9
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: iso8859-10, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A0010401120122012A0128013600A7013B011001600166017D00AD016A014A
+00B0010501130123012B0129013700B7013C011101610167017E2015016B014B
+010000C100C200C300C400C500C6012E010C00C9011800CB011600CD00CE00CF
+00D00145014C00D300D400D500D6016800D8017200DA00DB00DC00DD00DE00DF
+010100E100E200E300E400E500E6012F010D00E9011900EB011700ED00EE00EF
+00F00146014D00F300F400F500F6016900F8017300FA00FB00FC00FD00FE0138
diff --git a/ext/Encode/Encode/iso8859-13.enc b/ext/Encode/Encode/iso8859-13.enc
new file mode 100644 (file)
index 0000000..b7edcaf
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: iso8859-13, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A0201D00A200A300A4201E00A600A700D800A9015600AB00AC00AD00AE00C6
+00B000B100B200B3201C00B500B600B700F800B9015700BB00BC00BD00BE00E6
+0104012E0100010600C400C501180112010C00C90179011601220136012A013B
+01600143014500D3014C00D500D600D701720141015A016A00DC017B017D00DF
+0105012F0101010700E400E501190113010D00E9017A011701230137012B013C
+01610144014600F3014D00F500F600F701730142015B016B00FC017C017E2019
diff --git a/ext/Encode/Encode/iso8859-14.enc b/ext/Encode/Encode/iso8859-14.enc
new file mode 100644 (file)
index 0000000..a65ba05
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: iso8859-14, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A01E021E0300A3010A010B1E0A00A71E8000A91E821E0B1EF200AD00AE0178
+1E1E1E1F012001211E401E4100B61E561E811E571E831E601EF31E841E851E61
+00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
+017400D100D200D300D400D500D61E6A00D800D900DA00DB00DC00DD017600DF
+00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
+017500F100F200F300F400F500F61E6B00F800F900FA00FB00FC00FD017700FF
diff --git a/ext/Encode/Encode/iso8859-15.enc b/ext/Encode/Encode/iso8859-15.enc
new file mode 100644 (file)
index 0000000..823af46
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: iso8859-15, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A000A100A200A320AC00A5016000A7016100A900AA00AB00AC00AD00AE00AF
+00B000B100B200B3017D00B500B600B7017E00B900BA00BB01520153017800BF
+00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
+00D000D100D200D300D400D500D600D700D800D900DA00DB00DC00DD00DE00DF
+00E000E100E200E300E400E500E600E700E800E900EA00EB00EC00ED00EE00EF
+00F000F100F200F300F400F500F600F700F800F900FA00FB00FC00FD00FE00FF
diff --git a/ext/Encode/Encode/iso8859-16.enc b/ext/Encode/Encode/iso8859-16.enc
new file mode 100644 (file)
index 0000000..1936b97
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: iso8859-16, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+0080008100820083008400850086008700880089008A008B008C008D008E008F
+0090009100920093009400950096009700980099009A009B009C009D009E009F
+00A001040105014120AC00AB016000A7016100A90218201E017900AD017A017B
+00B000B1010C0142017D201D00B600B7017E010D021900BB015201530178017C
+00C000C100C2010200C4010600C600C700C800C900CA00CB00CC00CD00CE00CF
+0110014300D200D300D4015000D6015A017000D900DA00DB00DC0118021A00DF
+00E000E100E2010300E4010700E600E700E800E900EA00EB00EC00ED00EE00EF
+0111014400F200F300F4015100F6015B017100F900FA00FB00FC0119021B00FF
diff --git a/ext/Encode/Encode/posix-bc.enc b/ext/Encode/Encode/posix-bc.enc
new file mode 100644 (file)
index 0000000..8b533a4
--- /dev/null
@@ -0,0 +1,20 @@
+# Encoding file: posix-bc (EBCDIC), single-byte
+S
+006F 0 1
+00
+0000000100020003009C00090086007F0097008D008E000B000C000D000E000F
+0010001100120013009D000A00080087001800190092008F001C001D001E001F
+0080008100820083008400850017001B00880089008A008B008C000500060007
+0090009100160093009400950096000400980099009A009B00140015009E001A
+002000A000E200E400E000E100E300E500E700F10060002E003C0028002B007C
+002600E900EA00EB00E800ED00EE00EF00EC00DF00210024002A0029003B009F
+002D002F00C200C400C000C100C300C500C700D1005E002C0025005F003E003F
+00F800C900CA00CB00C800CD00CE00CF00CC00A8003A002300400027003D0022
+00D800610062006300640065006600670068006900AB00BB00F000FD00FE00B1
+00B0006A006B006C006D006E006F00700071007200AA00BA00E600B800C600A4
+00B500AF0073007400750076007700780079007A00A100BF00D000DD00DE00AE
+00A200A300A500B700A900A700B600BC00BD00BE00AC005B005C005D00B400D7
+00F900410042004300440045004600470048004900AD00F400F600F200F300F5
+00A6004A004B004C004D004E004F00500051005200B900FB00FC00DB00FA00FF
+00D900F70053005400550056005700580059005A00B200D400D600D200D300D5
+003000310032003300340035003600370038003900B3007B00DC007D00DA007E
index 329937e..4b1ec95 100644 (file)
@@ -1,7 +1,25 @@
 use ExtUtils::MakeMaker;
+
+my %tables = (iso8859 => ['ascii.enc', 'cp1250.enc'],
+              EBCDIC  => ['cp1047.enc','cp37.enc','posix-bc.enc'],
+              Symbols => ['symbol.enc','dingbats.enc'],
+             );
+
+opendir(ENC,'Encode');
+while (defined(my $file = readdir(ENC)))
+ {
+  if ($file =~ /iso8859.*\.enc/)
+   {
+    push(@{$tables{iso8859}},$file);
+   }
+ }
+closedir(ENC);
+
+
 WriteMakefile(
        NAME            => "Encode",
        VERSION_FROM    => 'Encode.pm',
+       OBJECT          => '$(O_FILES)',
        'dist'          => {
                             COMPRESS   => 'gzip -9f',
                             SUFFIX     => 'gz',
@@ -9,3 +27,84 @@ WriteMakefile(
                           },
        MAN3PODS        => {},
 );
+
+package MY;
+
+
+sub post_initialize
+{
+ my ($self) = @_;
+ my %o;
+ # Find existing O_FILES
+ foreach my $f (@{$self->{'O_FILES'}})
+  {
+   $o{$f} = 1;
+  } 
+ my $x = $self->{'OBJ_EXT'};
+ # Add the table O_FILES
+ foreach my $e (keys %tables)
+  {
+   $o{$e.$x} = 1;
+  }  
+ # Reset the variable 
+ $self->{'O_FILES'} = [sort keys %o];
+ my @files;
+ foreach my $table (keys %tables)
+  {
+   foreach my $ext (qw($(OBJ_EXT) .c .h .def))
+    {
+     push (@files,$table.$ext);
+    }
+  }
+ $self->{'clean'}{'FILES'} .= join(' ',@files);
+ return '';
+}
+
+sub postamble
+{
+ my $self = shift;
+ my $dir  = $self->catdir($self->curdir,'Encode');
+ my $str  = "# Encode$(OBJ_EXT) depends on .h and .def files not .c files - but all written by compile\n";
+ $str  .= 'Encode$(OBJ_EXT) :';
+ my @rules;
+ foreach my $table (keys %tables)
+  {
+   $str .= " $table.c";
+  }
+ $str .= "\n\n";
+ foreach my $table (keys %tables)
+  {
+   my $numlines = 1;
+   my $lengthsofar = length($str);
+   my $continuator = '';
+   $str .= "$table.c : compile Makefile.PL";
+   foreach my $file (@{$tables{$table}})
+    {
+     $str .= $continuator.' '.$self->catfile($dir,$file);
+     if ( length($str)-$lengthsofar > 128*$numlines )
+      {
+       $continuator .= " \\\n\t";
+       $numlines++;
+      } else {
+       $continuator = '';
+      }
+    }
+   $numlines = 1;
+   $lengthsofar = length($str);
+   $continuator = '';
+   $str .= "\n\t\$(PERL) compile \$\@";
+   foreach my $file (@{$tables{$table}})
+    {
+     $str .= $continuator.' '.$self->catfile($dir,$file);
+     if ( length($str)-$lengthsofar > 128*$numlines )
+      {
+       $continuator .= "\n\t\$(PERL) compile \$\@";
+       $numlines++;
+      } else {
+       $continuator = '';
+      }
+    }
+   $str .= "\n\n";
+  }
+ return $str;
+}
diff --git a/ext/Encode/compile b/ext/Encode/compile
new file mode 100755 (executable)
index 0000000..b890a04
--- /dev/null
@@ -0,0 +1,530 @@
+#!../../perl -w
+BEGIN { @INC = '../../lib' };
+use strict;
+
+sub encode_U
+{
+ # UTF-8 encode long hand - only covers part of perl's range
+ my $uv = shift;
+ if ($uv < 0x80)
+  {
+   return chr($uv)
+  }
+ if ($uv < 0x800)
+  {
+   return chr(($uv >> 6)        | 0xC0).
+          chr(($uv & 0x3F)      | 0x80);
+  }
+ return chr(($uv >> 12)         | 0xE0).
+        chr((($uv >> 6) & 0x3F) | 0x80).
+        chr(($uv & 0x3F)        | 0x80);
+}
+
+sub encode_S
+{
+ # encode single byte
+ my ($ch,$page) = @_;
+ return chr($ch);
+}
+
+sub encode_D
+{
+ # encode double byte MS byte first
+ my ($ch,$page) = @_;
+ return chr($page).chr($ch);
+}
+
+sub encode_M
+{
+ # encode Multi-byte - single for 0..255 otherwise double
+ my ($ch,$page) = @_;
+ return &encode_D if $page;
+ return &encode_S;
+}
+
+# Win32 does not expand globs on command line
+eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
+
+my $cname = shift(@ARGV);
+chmod(0666,$cname) if -f $cname && !-w $cname;
+open(C,">$cname") || die "Cannot open $cname:$!";
+my $dname = $cname;
+$dname =~ s/(\.[^\.]*)?$/.def/;
+
+my ($doC,$doEnc,$doUcm);
+
+if ($cname =~ /\.(c|xs)$/)
+ {
+  $doC = 1;
+  chmod(0666,$dname) if -f $cname && !-w $dname;
+  open(D,">$dname") || die "Cannot open $dname:$!";
+  my $hname = $cname;
+  $hname =~ s/(\.[^\.]*)?$/.h/;
+  chmod(0666,$hname) if -f $cname && !-w $hname;
+  open(H,">$hname") || die "Cannot open $hname:$!";
+
+  foreach my $fh (\*C,\*D,\*H)
+  {
+   print $fh <<"END";
+/*
+ !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+ This file was autogenerated by:
+ $^X $0 $cname @ARGV
+*/
+END
+  }
+
+  if ($cname =~ /(\w+)\.xs$/)
+   {
+    print C "#include <EXTERN.h>\n";
+    print C "#include <perl.h>\n";
+    print C "#include <XSUB.h>\n";
+    print C "#define U8 U8\n";
+   }
+  print C "#include \"encode.h\"\n";
+ }
+elsif ($cname =~ /\.enc$/)
+ {
+  $doEnc = 1;
+ }
+elsif ($cname =~ /\.ucm$/)
+ {
+  $doUcm = 1;
+ }
+
+my %encoding;
+my %strings;
+
+sub cmp_name
+{
+ if ($a =~ /^.*-(\d+)/)
+  {
+   my $an = $1;
+   if ($b =~ /^.*-(\d+)/)
+    {
+     my $r = $an <=> $1;
+     return $r if $r;
+    }
+  }
+ return $a cmp $b;
+}
+
+foreach my $enc (sort cmp_name @ARGV)
+ {
+  my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
+  if (open(E,$enc))
+   {
+    if ($sfx eq 'enc')
+     {
+      compile_enc(\*E,lc($name),\*C);
+     }
+    else
+     {
+      compile_ucm(\*E,lc($name),\*C);
+     }
+   }
+  else
+   {
+    warn "Cannot open $enc for $name:$!";
+   }
+ }
+
+if ($doC)
+ {
+  foreach my $enc (sort cmp_name keys %encoding)
+   {
+    my $sym = "${enc}_encoding";
+    $sym =~ s/\W+/_/g;
+    print C "encode_t $sym = \n";
+    print C " {",join(',',"\"$enc\"",@{$encoding{$enc}}),"};\n\n";
+   }
+
+  foreach my $enc (sort cmp_name keys %encoding)
+   {
+    my $sym = "${enc}_encoding";
+    $sym =~ s/\W+/_/g;
+    print H "extern encode_t $sym;\n";
+    print D " Encode_Define(aTHX_ &$sym);\n";
+   }
+
+  if ($cname =~ /(\w+)\.xs$/)
+   {
+    my $mod = $1;
+    print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
+    print C "BOOT:\n{\n";
+    print C "#include \"$dname\"\n";
+    print C "}\n";
+   }
+  close(D);
+  close(H);
+ }
+close(C);
+
+
+sub compile_ucm
+{
+ my ($fh,$name,$ch) = @_;
+ my $e2u = {};
+ my $u2e = {};
+ my $cs;
+ my %attr;
+ while (<$fh>)
+  {
+   s/#.*$//;
+   last if /^\s*CHARMAP\s*$/i;
+   if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i)
+    {
+     $attr{$1} = $2;
+    }
+  }
+ if (!defined($cs =  $attr{'code_set_name'}))
+  {
+   warn "No <code_set_name> in $name\n";
+  }
+ else
+  {
+   # $name = lc($cs);
+  }
+ my $erep;
+ my $urep;
+ if (exists $attr{'subchar'})
+  {
+   my @byte = $attr{'subchar'} =~ /^\s*(?:\\x([0-9a-f]+))+\s*$/;
+   $erep = join('',map(hex($_),@byte));
+  }
+ warn "Scanning $name ($cs)\n";
+ my $nfb = 0;
+ my $hfb = 0;
+ while (<$fh>)
+  {
+   s/#.*$//;
+   last if /^\s*END\s+CHARMAP\s*$/i;
+   next if /^\s*$/;
+   my ($u,@byte) = /^<U([0-9a-f]+)>\s+(?:\\x([0-9a-f]+))+\s*(\|[0-3]|)\s*$/i;
+   my $fb = pop(@byte);
+   if (defined($u))
+    {
+     my $uch = encode_U(hex($u));
+     my $ech = join('',map(chr(hex($_)),@byte));
+     if (length($fb))
+      {
+       $fb = substr($fb,1);
+       $hfb++;
+      }
+     else
+      {
+       $nfb++;
+       $fb = '0';
+      }
+     # $fb is fallback flag
+     # 0 - round trip safe
+     # 1 - fallback for unicode -> enc
+     # 2 - skip sub-char mapping
+     # 3 - fallback enc -> unicode
+     enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
+     enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
+    }
+   else
+    {
+     warn $_;
+    }
+
+  }
+ if ($nfb && $hfb)
+  {
+   die "$nfb entries without fallback, $hfb entries with\n";
+  }
+ if ($doC)
+  {
+   output($ch,$name.'_utf8',$e2u);
+   output($ch,'utf8_'.$name,$u2e);
+   $encoding{$name} = [$e2u->{Cname},$u2e->{Cname},
+                       outstring($ch,$e2u->{Cname}.'_def',$erep),length($erep)];
+  }
+ elsif ($doEnc)
+  {
+   output_enc($ch,$name,$e2u);
+  }
+ elsif ($doUcm)
+  {
+   output_ucm($ch,$name,$u2e);
+  }
+}
+
+sub compile_enc
+{
+ my ($fh,$name,$ch) = @_;
+ my $e2u = {};
+ my $u2e = {};
+
+ my $type;
+ while ($type = <$fh>)
+  {
+   last if $type !~ /^\s*#/;
+  }
+ chomp($type);
+ return if $type eq 'E';
+ my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
+ warn "$type encoded $name\n";
+ my $rep = '';
+ {
+  my $v = hex($def);
+  no strict 'refs';
+  $rep = &{"encode_$type"}($v & 0xFF, ($v >> 8) & 0xffe);
+ }
+ while ($pages--)
+  {
+   my $line = <$fh>;
+   chomp($line);
+   my $page = hex($line);
+   my $ch = 0;
+   for (my $i = 0; $i < 16; $i++)
+    {
+     my $line = <$fh>;
+     for (my $j = 0; $j < 16; $j++)
+      {
+       no strict 'refs';
+       my $ech = &{"encode_$type"}($ch,$page);
+       my $val = hex(substr($line,0,4,''));
+       if ($val || (!$ch && !$page))
+        {
+         my $uch = encode_U($val);
+         enter($e2u,$ech,$uch,$e2u,0);
+         enter($u2e,$uch,$ech,$u2e,0);
+        }
+       else
+        {
+         # No character at this position
+         # enter($e2u,$ech,undef,$e2u);
+        }
+       $ch++;
+      }
+    }
+  }
+ if ($doC)
+  {
+   output($ch,$name.'_utf8',$e2u);
+   output($ch,'utf8_'.$name,$u2e);
+   $encoding{$name} = [$e2u->{Cname},$u2e->{Cname},
+                       outstring($ch,$e2u->{Cname}.'_def',$rep),length($rep)];
+  }
+ elsif ($doEnc)
+  {
+   output_enc($ch,$name,$e2u);
+  }
+ elsif ($doUcm)
+  {
+   output_ucm($ch,$name,$u2e);
+  }
+}
+
+sub enter
+{
+ my ($a,$s,$d,$t,$fb) = @_;
+ $t = $a if @_ < 4;
+ my $b = substr($s,0,1);
+ my $e = $a->{$b};
+ unless ($e)
+  {     # 0  1  2  3         4  5
+   $e = [$b,$b,'',{},length($s),0,$fb];
+   $a->{$b} = $e;
+  }
+ if (length($s) > 1)
+  {
+   enter($e->[3],substr($s,1),$d,$t,$fb);
+  }
+ else
+  {
+   $e->[2] = $d;
+   $e->[3] = $t;
+   $e->[5] = length($d);
+  }
+}
+
+sub outstring
+{
+ my ($fh,$name,$s) = @_;
+ my $sym = $strings{$s};
+ unless ($sym)
+  {
+   foreach my $o (keys %strings)
+    {
+     my $i = index($o,$s);
+     if ($i >= 0)
+      {
+       $sym = $strings{$o};
+       $sym .= sprintf("+0x%02x",$i) if ($i);
+       return $sym;
+      }
+    }
+   $strings{$s} = $sym = $name;
+   printf $fh "\nstatic const U8 %s[%d] =\n",$name,length($s);
+   # Do in chunks of 16 chars to constrain line length
+   # Assumes ANSI C adjacent string litteral concatenation
+   while (length($s))
+    {
+     my $c = substr($s,0,16,'');
+     print  $fh '"',join('',map(sprintf('\x%02x',ord($_)),split(//,$c))),'"';
+     print  $fh "\n" if length($s);
+    }
+   printf $fh ";\n";
+  }
+ return $sym;
+}
+
+sub process
+{
+ my ($name,$a) = @_;
+ $name =~ s/\W+/_/g;
+ $a->{Cname} = $name;
+ my @keys = grep(ref($a->{$_}),sort keys %$a);
+ my $l;
+ my @ent;
+ foreach my $b (@keys)
+  {
+   my ($s,$f,$out,$t,$end) = @{$a->{$b}};
+   if (defined($l) &&
+       ord($b) == ord($a->{$l}[1])+1 &&
+       $a->{$l}[3] == $a->{$b}[3] &&
+       $a->{$l}[4] == $a->{$b}[4] &&
+       $a->{$l}[5] == $a->{$b}[5] &&
+       $a->{$l}[6] == $a->{$b}[6]
+       # && length($a->{$l}[2]) < 16
+      )
+    {
+     my $i = ord($b)-ord($a->{$l}[0]);
+     $a->{$l}[1]  = $b;
+     $a->{$l}[2] .= $a->{$b}[2];
+    }
+   else
+    {
+     $l = $b;
+     push(@ent,$b);
+    }
+   if (exists $t->{Cname})
+    {
+     $t->{'Forward'} = 1 if $t != $a;
+    }
+   else
+    {
+     process(sprintf("%s_%02x",$name,ord($s)),$t);
+    }
+  }
+ if (ord($keys[-1]) < 255)
+  {
+   my $t = chr(ord($keys[-1])+1);
+   $a->{$t} = [$t,chr(255),undef,$a,0,0];
+   push(@ent,$t);
+  }
+ $a->{'Entries'} = \@ent;
+}
+
+sub outtable
+{
+ my ($fh,$a) = @_;
+ my $name = $a->{'Cname'};
+ # String tables
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   next unless $a->{$b}[5];
+   my $s = ord($a->{$b}[0]);
+   my $e = ord($a->{$b}[1]);
+   outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$a->{$b}[2]);
+  }
+ if ($a->{'Forward'})
+  {
+   print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
+  }
+ $a->{'Done'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   my ($s,$e,$out,$t,$end,$l) = @{$a->{$b}};
+   outtable($fh,$t) unless $t->{'Done'};
+  }
+ print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
+ foreach my $b (@{$a->{'Entries'}})
+  {
+   my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+   my $sc = ord($s);
+   my $ec = ord($e);
+   $end |= 0x80 if $fb;
+   print  $fh "{";
+   if ($l)
+    {
+     printf $fh outstring($fh,'',$out);
+    }
+   else
+    {
+     print  $fh "0";
+    }
+   print  $fh ",",$t->{Cname};
+   printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
+  }
+ print $fh "};\n";
+}
+
+sub output
+{
+ my ($fh,$name,$a) = @_;
+ process($name,$a);
+ # Sub-tables
+ outtable($fh,$a);
+}
+
+sub output_enc
+{
+ my ($fh,$name,$a) = @_;
+ foreach my $b (sort keys %$a)
+  {
+   my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+  }
+}
+
+sub decode_U
+{
+ my $s = shift;
+
+}
+
+
+sub output_ucm_page
+{
+ my ($fh,$a,$t,$pre) = @_;
+ # warn sprintf("Page %x\n",$pre);
+ foreach my $b (sort keys %$t)
+  {
+   my ($s,$e,$out,$n,$end,$l,$fb) = @{$t->{$b}};
+   die "oops $s $e" unless $s eq $e;
+   my $u = ord($s);
+   if ($n != $a && $n != $t)
+    {
+     output_ucm_page($fh,$a,$n,(($pre|($u &0x3F)) << 6)&0xFFFF);
+    }
+   elsif (length($out))
+    {
+     if ($pre)
+      {
+       $u = $pre|($u &0x3f);
+      }
+     printf $fh "<U%04X> ",$u;
+     foreach my $c (split(//,$out))
+      {
+       printf $fh "\\x%02X",ord($c);
+      }
+     printf $fh " |%d\n",($fb ? 1 : 0);
+    }
+   else
+    {
+     warn join(',',@{$t->{$b}},$a,$t);
+    }
+  }
+}
+
+sub output_ucm
+{
+ my ($fh,$name,$a) = @_;
+ print $fh "CHARMAP\n";
+ output_ucm_page($fh,$a,$a,0);
+ print $fh "END CHARMAP\n";
+}
+
diff --git a/ext/Encode/encengine.c b/ext/Encode/encengine.c
new file mode 100644 (file)
index 0000000..513ef9a
--- /dev/null
@@ -0,0 +1,164 @@
+/*
+Data structures for encoding transformations.
+
+Perl works internally in either a native 'byte' encoding or
+in UTF-8 encoded Unicode.  We have no immediate need for a "wchar_t"
+representation. When we do we can use utf8_to_uv().
+
+Most character encodings are either simple byte mappings or
+variable length multi-byte encodings. UTF-8 can be viewed as a
+rather extreme case of the latter.
+
+So to solve an important part of perl's encode needs we need to solve the
+"multi-byte -> multi-byte" case. The simple byte forms are then just degenerate
+case. (Where one of multi-bytes will usually be UTF-8.)
+
+The other type of encoding is a shift encoding where a prefix sequence
+determines what subsequent bytes mean. Such encodings have state.
+
+We also need to handle case where a character in one encoding has to be
+represented as multiple characters in the other. e.g. letter+diacritic.
+
+The process can be considered as pseudo perl:
+
+my $dst = '';
+while (length($src))
+ {
+  my $size    = $count($src);
+  my $in_seq  = substr($src,0,$size,'');
+  my $out_seq = $s2d_hash{$in_seq};
+  if (defined $out_seq)
+   {
+    $dst .= $out_seq;
+   }
+  else
+   {
+    # an error condition
+   }
+ }
+return $dst;
+
+That has the following components:
+ &src_count - a "rule" for how many bytes make up the next character in the
+              source.
+ %s2d_hash  - a mapping from input sequences to output sequences
+
+The problem with that scheme is that it does not allow the output
+character repertoire to affect the characters considered from the
+input.
+
+So we use a "trie" representation which can also be considered
+a state machine:
+
+my $dst   = '';
+my $seq   = \@s2d_seq;
+my $next  = \@s2d_next;
+while (length($src))
+ {
+  my $byte    = $substr($src,0,1,'');
+  my $out_seq = $seq->[$byte];
+  if (defined $out_seq)
+   {
+    $dst .= $out_seq;
+   }
+  else
+   {
+    # an error condition
+   }
+  ($next,$seq) = @$next->[$byte] if $next;
+ }
+return $dst;
+
+There is now a pair of data structures to represent everything.
+It is valid for output sequence at a particular point to
+be defined but zero length, that just means "don't know yet".
+For the single byte case there is no 'next' so new tables will be the same as
+the original tables. For a multi-byte case a prefix byte will flip to the tables
+for  the next page (adding nothing to the output), then the tables for the page
+will provide the actual output and set tables back to original base page.
+
+This scheme can also handle shift encodings.
+
+A slight enhancement to the scheme also allows for look-ahead - if
+we add a flag to re-add the removed byte to the source we could handle
+  a" -> Ã¤
+  ab -> a (and take b back please)
+
+*/
+
+#include <EXTERN.h>
+#include <perl.h>
+#define U8 U8
+#include "encode.h"
+
+int
+do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, U8 *dst, STRLEN dlen, STRLEN *dout, int approx)
+{
+ const U8 *s    = src;
+ const U8 *send = s+*slen;
+ const U8 *last = s;
+ U8 *d          = dst;
+ U8 *dend       = d+dlen;
+ int code       = 0;
+ while (s < send)
+  {
+   encpage_t *e = enc;
+   U8 byte = *s;
+   while (byte > e->max)
+    e++;
+   if (byte >= e->min && e->slen && (approx || !(e->slen & 0x80)))
+    {
+     const U8 *cend = s + (e->slen & 0x7f);
+     if (cend <= send)
+      {
+       STRLEN n;
+       if ((n = e->dlen))
+        {
+         const U8 *out  = e->seq+n*(byte - e->min);
+         U8 *oend = d+n;
+         if (dst)
+          {
+           if (oend <= dend)
+            {
+             while (d < oend)
+              *d++ = *out++;
+            }
+           else
+            {
+             /* Out of space */
+             code = ENCODE_NOSPACE;
+             break;
+            }
+          }
+         else
+          d = oend;
+        }
+       enc = e->next;
+       s++;
+       if (s == cend)
+        {
+         if (approx && (e->slen & 0x80))
+          code = ENCODE_FALLBACK;
+         last = s;
+        }
+      }
+     else
+      {
+       /* partial source character */
+       code = ENCODE_PARTIAL;
+       break;
+      }
+    }
+   else
+    {
+     /* Cannot represent */
+     code = ENCODE_NOREP;
+     break;
+    }
+  }
+ *slen = last - src;
+ *dout = d - dst;
+ return code;
+}
+
+
diff --git a/ext/Encode/encode.h b/ext/Encode/encode.h
new file mode 100644 (file)
index 0000000..853ad04
--- /dev/null
@@ -0,0 +1,40 @@
+#ifndef ENCODE_H
+#define ENCODE_H
+#ifndef U8
+typedef unsigned char U8;
+#endif
+
+typedef struct encpage_s encpage_t;
+
+struct encpage_s
+{
+ const U8   *seq;
+ encpage_t  *next;
+ U8         min;
+ U8         max;
+ U8         dlen;
+ U8         slen;
+};
+
+typedef struct encode_s encode_t;
+struct encode_s
+{
+ const char *name;
+ encpage_t  *t_utf8;
+ encpage_t  *f_utf8;
+ const U8   *rep;
+ int        replen;
+};
+
+#ifdef U8
+extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen,
+                     U8 *dst, STRLEN dlen, STRLEN *dout, int approx);
+
+extern void Encode_DefineEncoding(encode_t *enc);
+#endif
+
+#define ENCODE_NOSPACE  1
+#define ENCODE_PARTIAL  2
+#define ENCODE_NOREP    3
+#define ENCODE_FALLBACK 4
+#endif
index 0666b2a..3e34b90 100644 (file)
@@ -2,9 +2,7 @@ use ExtUtils::MakeMaker;
 use Config;
 use strict;
 
-use vars qw($VERSION);
-
-$VERSION = "1.111";
+our $VERSION = "1.111";
 
 my %err = ();
 
@@ -29,6 +27,12 @@ sub process_file {
             warn "Cannot open '$file'";
             return;
        }     
+    } elsif ($Config{gccversion} ne '') { 
+       # With the -dM option, gcc outputs every #define it finds
+       unless(open(FH,"$Config{cc} -E -dM $file |")) {
+            warn "Cannot open '$file'";
+            return;
+       }     
     } else {
        unless(open(FH,"< $file")) {
            # This file could be a temporary file created by cppstdin
@@ -79,6 +83,10 @@ sub get_files {
     } elsif ($^O eq 'vmesa') {
        # OS/390 C compiler doesn't generate #file or #line directives
        $file{'../../vmesa/errno.h'} = 1;
+    } elsif ($^O eq 'linux') {
+       # Some Linuxes have weird errno.hs which generate
+       # no #file or #line directives
+       $file{'/usr/include/errno.h'} = 1;
     } else {
        open(CPPI,"> errno.c") or
            die "Cannot open errno.c";
@@ -175,7 +183,7 @@ sub write_errno_pm {
 #
 
 package Errno;
-use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
+our (\@EXPORT_OK,\%EXPORT_TAGS,\@ISA,\$VERSION,\%errno,\$AUTOLOAD);
 use Exporter ();
 use Config;
 use strict;
index 92103a1..c68dda1 100644 (file)
@@ -201,7 +201,7 @@ sub S_ISENFMT  { ( $_[0] & _S_IFMT() ) == S_IFENFMT() }
 
 sub AUTOLOAD {
     (my $constname = $AUTOLOAD) =~ s/.*:://;
-    my $val = constant($constname, 0);
+    my $val = constant($constname);
     if ($! != 0) {
        if ($! =~ /Invalid/ || $!{EINVAL}) {
            $AutoLoader::AUTOLOAD = $AUTOLOAD;
index b597e03..21029b2 100644 (file)
@@ -40,13 +40,13 @@ not_here(char *s)
     return -1;
 }
 
-static double
-constant(char *name, int arg)
+static IV
+constant(char *name)
 {
     errno = 0;
-    switch (*name) {
+    switch (*(name++)) {
     case '_':
-       if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */
+       if (strEQ(name, "S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */
 #ifdef S_IFMT
          return S_IFMT;
 #else
@@ -54,218 +54,219 @@ constant(char *name, int arg)
 #endif
        break;
     case 'F':
-       if (strnEQ(name, "F_", 2)) {
-           if (strEQ(name, "F_ALLOCSP"))
+       if (*name == '_') {
+           name++;
+           if (strEQ(name, "ALLOCSP"))
 #ifdef F_ALLOCSP
                return F_ALLOCSP;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_ALLOCSP64"))
+           if (strEQ(name, "ALLOCSP64"))
 #ifdef F_ALLOCSP64
                return F_ALLOCSP64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_COMPAT"))
+           if (strEQ(name, "COMPAT"))
 #ifdef F_COMPAT
                return F_COMPAT;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_DUP2FD"))
+           if (strEQ(name, "DUP2FD"))
 #ifdef F_DUP2FD
                return F_DUP2FD;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_DUPFD"))
+           if (strEQ(name, "DUPFD"))
 #ifdef F_DUPFD
                return F_DUPFD;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_EXLCK"))
+           if (strEQ(name, "EXLCK"))
 #ifdef F_EXLCK
                return F_EXLCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_FREESP"))
+           if (strEQ(name, "FREESP"))
 #ifdef F_FREESP
                return F_FREESP;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_FREESP64"))
+           if (strEQ(name, "FREESP64"))
 #ifdef F_FREESP64
                return F_FREESP64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_FSYNC"))
+           if (strEQ(name, "FSYNC"))
 #ifdef F_FSYNC
                return F_FSYNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_FSYNC64"))
+           if (strEQ(name, "FSYNC64"))
 #ifdef F_FSYNC64
                return F_FSYNC64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_GETFD"))
+           if (strEQ(name, "GETFD"))
 #ifdef F_GETFD
                return F_GETFD;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_GETFL"))
+           if (strEQ(name, "GETFL"))
 #ifdef F_GETFL
                return F_GETFL;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_GETLK"))
+           if (strEQ(name, "GETLK"))
 #ifdef F_GETLK
                return F_GETLK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_GETLK64"))
+           if (strEQ(name, "GETLK64"))
 #ifdef F_GETLK64
                return F_GETLK64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_GETOWN"))
+           if (strEQ(name, "GETOWN"))
 #ifdef F_GETOWN
                return F_GETOWN;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_NODNY"))
+           if (strEQ(name, "NODNY"))
 #ifdef F_NODNY
                return F_NODNY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_POSIX"))
+           if (strEQ(name, "POSIX"))
 #ifdef F_POSIX
                return F_POSIX;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_RDACC"))
+           if (strEQ(name, "RDACC"))
 #ifdef F_RDACC
                return F_RDACC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_RDDNY"))
+           if (strEQ(name, "RDDNY"))
 #ifdef F_RDDNY
                return F_RDDNY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_RDLCK"))
+           if (strEQ(name, "RDLCK"))
 #ifdef F_RDLCK
                return F_RDLCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_RWACC"))
+           if (strEQ(name, "RWACC"))
 #ifdef F_RWACC
                return F_RWACC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_RWDNY"))
+           if (strEQ(name, "RWDNY"))
 #ifdef F_RWDNY
                return F_RWDNY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETFD"))
+           if (strEQ(name, "SETFD"))
 #ifdef F_SETFD
                return F_SETFD;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETFL"))
+           if (strEQ(name, "SETFL"))
 #ifdef F_SETFL
                return F_SETFL;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETLK"))
+           if (strEQ(name, "SETLK"))
 #ifdef F_SETLK
                return F_SETLK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETLK64"))
+           if (strEQ(name, "SETLK64"))
 #ifdef F_SETLK64
                return F_SETLK64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETLKW"))
+           if (strEQ(name, "SETLKW"))
 #ifdef F_SETLKW
                return F_SETLKW;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETLKW64"))
+           if (strEQ(name, "SETLKW64"))
 #ifdef F_SETLKW64
                return F_SETLKW64;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SETOWN"))
+           if (strEQ(name, "SETOWN"))
 #ifdef F_SETOWN
                return F_SETOWN;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SHARE"))
+           if (strEQ(name, "SHARE"))
 #ifdef F_SHARE
                return F_SHARE;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_SHLCK"))
+           if (strEQ(name, "SHLCK"))
 #ifdef F_SHLCK
                return F_SHLCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_UNLCK"))
+           if (strEQ(name, "UNLCK"))
 #ifdef F_UNLCK
                return F_UNLCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_UNSHARE"))
+           if (strEQ(name, "UNSHARE"))
 #ifdef F_UNSHARE
                return F_UNSHARE;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_WRACC"))
+           if (strEQ(name, "WRACC"))
 #ifdef F_WRACC
                return F_WRACC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_WRDNY"))
+           if (strEQ(name, "WRDNY"))
 #ifdef F_WRDNY
                return F_WRDNY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "F_WRLCK"))
+           if (strEQ(name, "WRLCK"))
 #ifdef F_WRLCK
                return F_WRLCK;
 #else
@@ -274,79 +275,79 @@ constant(char *name, int arg)
            errno = EINVAL;
            return 0;
        }
-        if (strEQ(name, "FAPPEND"))
+        if (strEQ(name, "APPEND"))
 #ifdef FAPPEND
             return FAPPEND;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FASYNC"))
+        if (strEQ(name, "ASYNC"))
 #ifdef FASYNC
             return FASYNC;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FCREAT"))
+        if (strEQ(name, "CREAT"))
 #ifdef FCREAT
             return FCREAT;
 #else
             goto not_there;
 #endif
-       if (strEQ(name, "FD_CLOEXEC"))
+       if (strEQ(name, "D_CLOEXEC"))
 #ifdef FD_CLOEXEC
            return FD_CLOEXEC;
 #else
            goto not_there;
 #endif
-       if (strEQ(name, "FDEFER"))
+       if (strEQ(name, "DEFER"))
 #ifdef FDEFER
            return FDEFER;
 #else
            goto not_there;
 #endif
-        if (strEQ(name, "FDSYNC"))
+        if (strEQ(name, "DSYNC"))
 #ifdef FDSYNC
             return FDSYNC;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FEXCL"))
+        if (strEQ(name, "EXCL"))
 #ifdef FEXCL
             return FEXCL;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FLARGEFILE"))
+        if (strEQ(name, "LARGEFILE"))
 #ifdef FLARGEFILE
             return FLARGEFILE;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FNDELAY"))
+        if (strEQ(name, "NDELAY"))
 #ifdef FNDELAY
             return FNDELAY;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FNONBLOCK"))
+        if (strEQ(name, "NONBLOCK"))
 #ifdef FNONBLOCK
             return FNONBLOCK;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FRSYNC"))
+        if (strEQ(name, "RSYNC"))
 #ifdef FRSYNC
             return FRSYNC;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FSYNC"))
+        if (strEQ(name, "SYNC"))
 #ifdef FSYNC
             return FSYNC;
 #else
             goto not_there;
 #endif
-        if (strEQ(name, "FTRUNC"))
+        if (strEQ(name, "TRUNC"))
 #ifdef FTRUNC
             return FTRUNC;
 #else
@@ -354,28 +355,29 @@ constant(char *name, int arg)
 #endif
        break;
     case 'L':
-       if (strnEQ(name, "LOCK_", 5)) {
+       if (strnEQ(name, "OCK_", 4)) {
            /* We support flock() on systems which don't have it, so
               always supply the constants. */
-           if (strEQ(name, "LOCK_SH"))
+           name += 4;
+           if (strEQ(name, "SH"))
 #ifdef LOCK_SH
                return LOCK_SH;
 #else
                return 1;
 #endif
-           if (strEQ(name, "LOCK_EX"))
+           if (strEQ(name, "EX"))
 #ifdef LOCK_EX
                return LOCK_EX;
 #else
                return 2;
 #endif
-           if (strEQ(name, "LOCK_NB"))
+           if (strEQ(name, "NB"))
 #ifdef LOCK_NB
                return LOCK_NB;
 #else
                return 4;
 #endif
-           if (strEQ(name, "LOCK_UN"))
+           if (strEQ(name, "UN"))
 #ifdef LOCK_UN
                return LOCK_UN;
 #else
@@ -385,188 +387,189 @@ constant(char *name, int arg)
          goto not_there;
        break;
     case 'O':
-       if (strnEQ(name, "O_", 2)) {
-           if (strEQ(name, "O_ACCMODE"))
+       if (name[0] == '_') {
+           name++;
+           if (strEQ(name, "ACCMODE"))
 #ifdef O_ACCMODE
                return O_ACCMODE;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_APPEND"))
+           if (strEQ(name, "APPEND"))
 #ifdef O_APPEND
                return O_APPEND;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_ASYNC"))
+           if (strEQ(name, "ASYNC"))
 #ifdef O_ASYNC
                return O_ASYNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_BINARY"))
+           if (strEQ(name, "BINARY"))
 #ifdef O_BINARY
                return O_BINARY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_CREAT"))
+           if (strEQ(name, "CREAT"))
 #ifdef O_CREAT
                return O_CREAT;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_DEFER"))
+           if (strEQ(name, "DEFER"))
 #ifdef O_DEFER
                return O_DEFER;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_DIRECT"))
+           if (strEQ(name, "DIRECT"))
 #ifdef O_DIRECT
                return O_DIRECT;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_DIRECTORY"))
+           if (strEQ(name, "DIRECTORY"))
 #ifdef O_DIRECTORY
                return O_DIRECTORY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_DSYNC"))
+           if (strEQ(name, "DSYNC"))
 #ifdef O_DSYNC
                return O_DSYNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_EXCL"))
+           if (strEQ(name, "EXCL"))
 #ifdef O_EXCL
                return O_EXCL;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_EXLOCK"))
+           if (strEQ(name, "EXLOCK"))
 #ifdef O_EXLOCK
                return O_EXLOCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_LARGEFILE"))
+           if (strEQ(name, "LARGEFILE"))
 #ifdef O_LARGEFILE
                return O_LARGEFILE;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_NDELAY"))
+           if (strEQ(name, "NDELAY"))
 #ifdef O_NDELAY
                return O_NDELAY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_NOCTTY"))
+           if (strEQ(name, "NOCTTY"))
 #ifdef O_NOCTTY
                return O_NOCTTY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_NOFOLLOW"))
+           if (strEQ(name, "NOFOLLOW"))
 #ifdef O_NOFOLLOW
                return O_NOFOLLOW;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_NOINHERIT"))
+           if (strEQ(name, "NOINHERIT"))
 #ifdef O_NOINHERIT
                return O_NOINHERIT;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_NONBLOCK"))
+           if (strEQ(name, "NONBLOCK"))
 #ifdef O_NONBLOCK
                return O_NONBLOCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RANDOM"))
+           if (strEQ(name, "RANDOM"))
 #ifdef O_RANDOM
                return O_RANDOM;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RAW"))
+           if (strEQ(name, "RAW"))
 #ifdef O_RAW
                return O_RAW;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RDONLY"))
+           if (strEQ(name, "RDONLY"))
 #ifdef O_RDONLY
                return O_RDONLY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RDWR"))
+           if (strEQ(name, "RDWR"))
 #ifdef O_RDWR
                return O_RDWR;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RSYNC"))
+           if (strEQ(name, "RSYNC"))
 #ifdef O_RSYNC
                return O_RSYNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_SEQUENTIAL"))
+           if (strEQ(name, "SEQUENTIAL"))
 #ifdef O_SEQUENTIAL
                return O_SEQUENTIAL;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_SHLOCK"))
+           if (strEQ(name, "SHLOCK"))
 #ifdef O_SHLOCK
                return O_SHLOCK;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_SYNC"))
+           if (strEQ(name, "SYNC"))
 #ifdef O_SYNC
                return O_SYNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_TEMPORARY"))
+           if (strEQ(name, "TEMPORARY"))
 #ifdef O_TEMPORARY
                return O_TEMPORARY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_TEXT"))
+           if (strEQ(name, "TEXT"))
 #ifdef O_TEXT
                return O_TEXT;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_TRUNC"))
+           if (strEQ(name, "TRUNC"))
 #ifdef O_TRUNC
                return O_TRUNC;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_WRONLY"))
+           if (strEQ(name, "WRONLY"))
 #ifdef O_WRONLY
                return O_WRONLY;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_ALIAS"))
+           if (strEQ(name, "ALIAS"))
 #ifdef O_ALIAS
                return O_ALIAS;
 #else
                goto not_there;
 #endif
-           if (strEQ(name, "O_RSRC"))
+           if (strEQ(name, "RSRC"))
 #ifdef O_RSRC
                return O_RSRC;
 #else
@@ -576,171 +579,171 @@ constant(char *name, int arg)
          goto not_there;
        break;
     case 'S':
-      switch (name[1]) {
+      switch (*(name++)) {
       case '_':
-       if (strEQ(name, "S_ISUID"))
+       if (strEQ(name, "ISUID"))
 #ifdef S_ISUID
          return S_ISUID;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_ISGID"))
+       if (strEQ(name, "ISGID"))
 #ifdef S_ISGID
          return S_ISGID;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_ISVTX"))
+       if (strEQ(name, "ISVTX"))
 #ifdef S_ISVTX
          return S_ISVTX;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_ISTXT"))
+       if (strEQ(name, "ISTXT"))
 #ifdef S_ISTXT
          return S_ISTXT;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFREG"))
+       if (strEQ(name, "IFREG"))
 #ifdef S_IFREG
          return S_IFREG;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFDIR"))
+       if (strEQ(name, "IFDIR"))
 #ifdef S_IFDIR
          return S_IFDIR;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFLNK"))
+       if (strEQ(name, "IFLNK"))
 #ifdef S_IFLNK
          return S_IFLNK;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFSOCK"))
+       if (strEQ(name, "IFSOCK"))
 #ifdef S_IFSOCK
          return S_IFSOCK;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFBLK"))
+       if (strEQ(name, "IFBLK"))
 #ifdef S_IFBLK
          return S_IFBLK;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFCHR"))
+       if (strEQ(name, "IFCHR"))
 #ifdef S_IFCHR
          return S_IFCHR;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFIFO"))
+       if (strEQ(name, "IFIFO"))
 #ifdef S_IFIFO
          return S_IFIFO;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IFWHT"))
+       if (strEQ(name, "IFWHT"))
 #ifdef S_IFWHT
          return S_IFWHT;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_ENFMT"))
+       if (strEQ(name, "ENFMT"))
 #ifdef S_ENFMT
          return S_ENFMT;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IRUSR"))
+       if (strEQ(name, "IRUSR"))
 #ifdef S_IRUSR
          return S_IRUSR;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IWUSR"))
+       if (strEQ(name, "IWUSR"))
 #ifdef S_IWUSR
          return S_IWUSR;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IXUSR"))
+       if (strEQ(name, "IXUSR"))
 #ifdef S_IXUSR
          return S_IXUSR;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IRWXU"))
+       if (strEQ(name, "IRWXU"))
 #ifdef S_IRWXU
          return S_IRWXU;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IRGRP"))
+       if (strEQ(name, "IRGRP"))
 #ifdef S_IRGRP
          return S_IRGRP;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IWGRP"))
+       if (strEQ(name, "IWGRP"))
 #ifdef S_IWGRP
          return S_IWGRP;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IXGRP"))
+       if (strEQ(name, "IXGRP"))
 #ifdef S_IXGRP
          return S_IXGRP;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IRWXG"))
+       if (strEQ(name, "IRWXG"))
 #ifdef S_IRWXG
          return S_IRWXG;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IROTH"))
+       if (strEQ(name, "IROTH"))
 #ifdef S_IROTH
          return S_IROTH;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IWOTH"))
+       if (strEQ(name, "IWOTH"))
 #ifdef S_IWOTH
          return S_IWOTH;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IXOTH"))
+       if (strEQ(name, "IXOTH"))
 #ifdef S_IXOTH
          return S_IXOTH;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IRWXO"))
+       if (strEQ(name, "IRWXO"))
 #ifdef S_IRWXO
          return S_IRWXO;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IREAD"))
+       if (strEQ(name, "IREAD"))
 #ifdef S_IREAD
          return S_IREAD;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IWRITE"))
+       if (strEQ(name, "IWRITE"))
 #ifdef S_IWRITE
          return S_IWRITE;
 #else
          goto not_there;
 #endif
-       if (strEQ(name, "S_IEXEC"))
+       if (strEQ(name, "IEXEC"))
 #ifdef S_IEXEC
          return S_IEXEC;
 #else
@@ -748,19 +751,19 @@ constant(char *name, int arg)
 #endif
        break;
       case 'E':
-         if (strEQ(name, "SEEK_CUR"))
+         if (strEQ(name, "EK_CUR"))
 #ifdef SEEK_CUR
            return SEEK_CUR;
 #else
            return 1;
 #endif
-       if (strEQ(name, "SEEK_END"))
+       if (strEQ(name, "EK_END"))
 #ifdef SEEK_END
            return SEEK_END;
 #else
            return 2;
 #endif
-       if (strEQ(name, "SEEK_SET"))
+       if (strEQ(name, "EK_SET"))
 #ifdef SEEK_SET
            return SEEK_SET;
 #else
@@ -780,8 +783,7 @@ not_there:
 
 MODULE = Fcntl         PACKAGE = Fcntl
 
-double
-constant(name,arg)
+IV
+constant(name)
        char *          name
-       int             arg
 
diff --git a/ext/Filter/Util/Call/Call.pm b/ext/Filter/Util/Call/Call.pm
new file mode 100644 (file)
index 0000000..694b1b3
--- /dev/null
@@ -0,0 +1,474 @@
+package Filter::Util::Call ;
+
+require 5.002 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.04" ;
+
+sub filter_read_exact($)
+{
+    my ($size)   = @_ ;
+    my ($left)   = $size ;
+    my ($status) ;
+
+    croak ("filter_read_exact: size parameter must be > 0")
+       unless $size > 0 ;
+
+    # try to read a block which is exactly $size bytes long
+    while ($left and ($status = filter_read($left)) > 0) {
+        $left = $size - length $_ ;
+    }
+
+    # EOF with pending data is a special case
+    return 1 if $status == 0 and length $_ ;
+
+    return $status ;
+}
+
+sub filter_add($)
+{
+    my($obj) = @_ ;
+
+    # Did we get a code reference?
+    my $coderef = (ref $obj eq 'CODE') ;
+
+    # If the parameter isn't already a reference, make it one.
+    $obj = \$obj unless ref $obj ;
+
+    $obj = bless ($obj, (caller)[0]) unless $coderef ;
+
+    # finish off the installation of the filter in C.
+    Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
+}
+
+bootstrap Filter::Util::Call ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::Util::Call - Perl Source Filter Utility Module
+
+=head1 SYNOPSIS
+    use Filter::Util::Call ;
+
+=head1 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+A I<Perl Source Filter> is implemented as a Perl module. The structure
+of the module can take one of two broadly similar formats. To
+distinguish between them, the first will be referred to as I<method
+filter> and the second as I<closure filter>.
+
+Here is a skeleton for the I<method filter>:
+
+    package MyFilter ;
+    
+    use Filter::Util::Call ;
+
+    sub import
+    {
+        my($type, @arguments) = @_ ;
+        filter_add([]) ;
+    }
+    
+    sub filter
+    {
+        my($self) = @_ ;
+        my($status) ;
+    
+        $status = filter_read() ;
+        $status ;
+    }
+    
+    1 ;
+
+and this is the equivalent skeleton for the I<closure filter>:
+
+    package MyFilter ;
+    
+    use Filter::Util::Call ;
+
+    sub import
+    {
+        my($type, @arguments) = @_ ;
+    
+        filter_add(
+            sub 
+            {
+                my($status) ;
+                $status = filter_read() ;
+                $status ;
+            } )
+    }
+    
+    1 ;
+
+To make use of either of the two filter modules above, place the line
+below in a Perl source file.
+
+    use MyFilter; 
+
+In fact, the skeleton modules shown above are fully functional I<Source
+Filters>, albeit fairly useless ones. All they does is filter the
+source stream without modifying it at all.
+
+As you can see both modules have a broadly similar structure. They both
+make use of the C<Filter::Util::Call> module and both have an C<import>
+method. The difference between them is that the I<method filter>
+requires a I<filter> method, whereas the I<closure filter> gets the
+equivalent of a I<filter> method with the anonymous sub passed to
+I<filter_add>.
+
+To make proper use of the I<closure filter> shown above you need to
+have a good understanding of the concept of a I<closure>. See
+L<perlref> for more details on the mechanics of I<closures>.
+
+=head2 B<use Filter::Util::Call>
+
+The following functions are exported by C<Filter::Util::Call>:
+
+    filter_add()
+    filter_read()
+    filter_read_exact()
+    filter_del()
+
+=head2 B<import()>
+
+The C<import> method is used to create an instance of the filter. It is
+called indirectly by Perl when it encounters the C<use MyFilter> line
+in a source file (See L<perlfunc/import> for more details on
+C<import>).
+
+It will always have at least one parameter automatically passed by Perl
+- this corresponds to the name of the package. In the example above it
+will be C<"MyFilter">.
+
+Apart from the first parameter, import can accept an optional list of
+parameters. These can be used to pass parameters to the filter. For
+example:
+
+    use MyFilter qw(a b c) ;
+
+will result in the C<@_> array having the following values:
+
+    @_ [0] => "MyFilter"
+    @_ [1] => "a"
+    @_ [2] => "b"
+    @_ [3] => "c"
+
+Before terminating, the C<import> function must explicitly install the
+filter by calling C<filter_add>.
+
+B<filter_add()>
+
+The function, C<filter_add>, actually installs the filter. It takes one
+parameter which should be a reference. The kind of reference used will
+dictate which of the two filter types will be used.
+
+If a CODE reference is used then a I<closure filter> will be assumed.
+
+If a CODE reference is not used, a I<method filter> will be assumed.
+In a I<method filter>, the reference can be used to store context
+information. The reference will be I<blessed> into the package by
+C<filter_add>.
+
+See the filters at the end of this documents for examples of using
+context information using both I<method filters> and I<closure
+filters>.
+
+=head2 B<filter() and anonymous sub>
+
+Both the C<filter> method used with a I<method filter> and the
+anonymous sub used with a I<closure filter> is where the main
+processing for the filter is done.
+
+The big difference between the two types of filter is that the I<method
+filter> uses the object passed to the method to store any context data,
+whereas the I<closure filter> uses the lexical variables that are
+maintained by the closure.
+
+Note that the single parameter passed to the I<method filter>,
+C<$self>, is the same reference that was passed to C<filter_add>
+blessed into the filter's package. See the example filters later on for
+details of using C<$self>.
+
+Here is a list of the common features of the anonymous sub and the
+C<filter()> method.
+
+=over 5
+
+=item B<$_>
+
+Although C<$_> doesn't actually appear explicitly in the sample filters
+above, it is implicitly used in a number of places.
+
+Firstly, when either C<filter> or the anonymous sub are called, a local
+copy of C<$_> will automatically be created. It will always contain the
+empty string at this point.
+
+Next, both C<filter_read> and C<filter_read_exact> will append any
+source data that is read to the end of C<$_>.
+
+Finally, when C<filter> or the anonymous sub are finished processing,
+they are expected to return the filtered source using C<$_>.
+
+This implicit use of C<$_> greatly simplifies the filter.
+
+=item B<$status>
+
+The status value that is returned by the user's C<filter> method or
+anonymous sub and the C<filter_read> and C<read_exact> functions take
+the same set of values, namely:
+
+    < 0  Error
+    = 0  EOF
+    > 0  OK
+
+=item B<filter_read> and B<filter_read_exact>
+
+These functions are used by the filter to obtain either a line or block
+from the next filter in the chain or the actual source file if there
+aren't any other filters.
+
+The function C<filter_read> takes two forms:
+
+    $status = filter_read() ;
+    $status = filter_read($size) ;
+
+The first form is used to request a I<line>, the second requests a
+I<block>.
+
+In line mode, C<filter_read> will append the next source line to the
+end of the C<$_> scalar.
+
+In block mode, C<filter_read> will append a block of data which is <=
+C<$size> to the end of the C<$_> scalar. It is important to emphasise
+the that C<filter_read> will not necessarily read a block which is
+I<precisely> C<$size> bytes.
+
+If you need to be able to read a block which has an exact size, you can
+use the function C<filter_read_exact>. It works identically to
+C<filter_read> in block mode, except it will try to read a block which
+is exactly C<$size> bytes in length. The only circumstances when it
+will not return a block which is C<$size> bytes long is on EOF or
+error.
+
+It is I<very> important to check the value of C<$status> after I<every>
+call to C<filter_read> or C<filter_read_exact>.
+
+=item B<filter_del>
+
+The function, C<filter_del>, is used to disable the current filter. It
+does not affect the running of the filter. All it does is tell Perl not
+to call filter any more.
+
+See L<Example 4: Using filter_del> for details.
+
+=back
+
+=head1 EXAMPLES
+
+Here are a few examples which illustrate the key concepts - as such
+most of them are of little practical use.
+
+The C<examples> sub-directory has copies of all these filters
+implemented both as I<method filters> and as I<closure filters>.
+
+=head2 Example 1: A simple filter.
+
+Below is a I<method filter> which is hard-wired to replace all
+occurrences of the string C<"Joe"> to C<"Jim">. Not particularly
+Useful, but it is the first example and I wanted to keep it simple.
+
+    package Joe2Jim ;
+    
+    use Filter::Util::Call ;
+
+    sub import
+    {
+        my($type) = @_ ;
+    
+        filter_add(bless []) ;
+    }
+    
+    sub filter
+    {
+        my($self) = @_ ;
+        my($status) ;
+    
+        s/Joe/Jim/g
+            if ($status = filter_read()) > 0 ;
+        $status ;
+    }
+    
+    1 ;
+
+Here is an example of using the filter:
+
+    use Joe2Jim ;
+    print "Where is Joe?\n" ;
+
+And this is what the script above will print:
+
+    Where is Jim?
+
+=head2 Example 2: Using the context
+
+The previous example was not particularly useful. To make it more
+general purpose we will make use of the context data and allow any
+arbitrary I<from> and I<to> strings to be used. This time we will use a
+I<closure filter>. To reflect its enhanced role, the filter is called
+C<Subst>.
+
+    package Subst ;
+    use Filter::Util::Call ;
+    use Carp ;
+    sub import
+    {
+        croak("usage: use Subst qw(from to)")
+            unless @_ == 3 ;
+        my ($self, $from, $to) = @_ ;
+        filter_add(
+            sub 
+            {
+                my ($status) ;
+                s/$from/$to/
+                    if ($status = filter_read()) > 0 ;
+                $status ;
+            })
+    }
+    1 ;
+
+and is used like this:
+
+    use Subst qw(Joe Jim) ;
+    print "Where is Joe?\n" ;
+
+
+=head2 Example 3: Using the context within the filter
+
+Here is a filter which a variation of the C<Joe2Jim> filter. As well as
+substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count
+of the number of substitutions made in the context object.
+
+Once EOF is detected (C<$status> is zero) the filter will insert an
+extra line into the source stream. When this extra line is executed it
+will print a count of the number of substitutions actually made.
+Note that C<$status> is set to C<1> in this case.
+
+    package Count ;
+    use Filter::Util::Call ;
+    sub filter
+    {
+        my ($self) = @_ ;
+        my ($status) ;
+        if (($status = filter_read()) > 0 ) {
+            s/Joe/Jim/g ;
+           ++ $$self ;
+        }
+       elsif ($$self >= 0) { # EOF
+            $_ = "print q[Made ${$self} substitutions\n]" ;
+            $status = 1 ;
+           $$self = -1 ;
+        }
+
+        $status ;
+    }
+    sub import
+    {
+        my ($self) = @_ ;
+        my ($count) = 0 ;
+        filter_add(\$count) ;
+    }
+    1 ;
+
+Here is a script which uses it:
+
+    use Count ;
+    print "Hello Joe\n" ;
+    print "Where is Joe\n" ;
+
+Outputs:
+
+    Hello Jim
+    Where is Jim
+    Made 2 substitutions
+
+=head2 Example 4: Using filter_del
+
+Another variation on a theme. This time we will modify the C<Subst>
+filter to allow a starting and stopping pattern to be specified as well
+as the I<from> and I<to> patterns. If you know the I<vi> editor, it is
+the equivalent of this command:
+
+    :/start/,/stop/s/from/to/
+
+When used as a filter we want to invoke it like this:
+
+    use NewSubst qw(start stop from to) ;
+
+Here is the module.
+
+    package NewSubst ;
+    use Filter::Util::Call ;
+    use Carp ;
+    sub import
+    {
+        my ($self, $start, $stop, $from, $to) = @_ ;
+        my ($found) = 0 ;
+        croak("usage: use Subst qw(start stop from to)")
+            unless @_ == 5 ;
+        filter_add( 
+            sub 
+            {
+                my ($status) ;
+             
+                if (($status = filter_read()) > 0) {
+             
+                    $found = 1
+                        if $found == 0 and /$start/ ;
+             
+                    if ($found) {
+                        s/$from/$to/ ;
+                        filter_del() if /$stop/ ;
+                    }
+             
+                }
+                $status ;
+            } )
+    
+    }
+     
+    1 ;
+
+=head1 AUTHOR
+
+Paul Marquess 
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
diff --git a/ext/Filter/Util/Call/Call.xs b/ext/Filter/Util/Call/Call.xs
new file mode 100644 (file)
index 0000000..c8105d0
--- /dev/null
@@ -0,0 +1,252 @@
+/* 
+ * Filename : Call.xs
+ * 
+ * Author   : Paul Marquess 
+ * Date     : 26th March 2000
+ * Version  : 1.05
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef PERL_VERSION
+#    include "patchlevel.h"
+#    define PERL_REVISION      5
+#    define PERL_VERSION       PATCHLEVEL
+#    define PERL_SUBVERSION    SUBVERSION
+#endif
+
+/* defgv must be accessed differently under threaded perl */
+/* DEFSV et al are in 5.004_56 */
+#ifndef DEFSV
+#    define DEFSV              GvSV(defgv)
+#endif
+
+#ifndef pTHX
+#    define pTHX
+#    define pTHX_
+#    define aTHX
+#    define aTHX_
+#endif
+
+
+/* Internal defines */
+#define PERL_MODULE(s)         IoBOTTOM_NAME(s)
+#define PERL_OBJECT(s)         IoTOP_GV(s)
+#define FILTER_ACTIVE(s)       IoLINES(s)
+#define BUF_OFFSET(sv)         IoPAGE_LEN(sv)
+#define CODE_REF(sv)           IoPAGE(sv)
+
+#define SET_LEN(sv,len) \
+        do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+
+
+
+static int fdebug = 0;
+static int current_idx ;
+
+static I32
+filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+    SV   *my_sv = FILTER_DATA(idx);
+    char *nl = "\n";
+    char *p;
+    char *out_ptr;
+    int n;
+
+    if (fdebug)
+       warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n", 
+               maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
+
+    while (1) {
+
+       /* anything left from last time */
+       if (n = SvCUR(my_sv)) {
+
+           out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
+
+           if (maxlen) { 
+               /* want a block */ 
+               if (fdebug)
+                   warn("BLOCK(%d): size = %d, maxlen = %d\n", 
+                       idx, n, maxlen) ;
+
+               sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
+               if(n <= maxlen) {
+                   BUF_OFFSET(my_sv) = 0 ;
+                   SET_LEN(my_sv, 0) ;
+               }
+               else {
+                   BUF_OFFSET(my_sv) += maxlen ;
+                   SvCUR_set(my_sv, n - maxlen) ;
+               }
+               return SvCUR(buf_sv);
+           }
+           else {
+               /* want lines */
+                if (p = ninstr(out_ptr, out_ptr + n - 1, nl, nl)) {
+
+                   sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
+
+                   n = n - (p - out_ptr + 1);
+                   BUF_OFFSET(my_sv) += (p - out_ptr + 1);
+                   SvCUR_set(my_sv, n) ;
+                   if (fdebug)
+                       warn("recycle %d - leaving %d, returning %d [%s]", 
+                               idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
+
+                   return SvCUR(buf_sv);
+               }
+               else /* no EOL, so append the complete buffer */
+                   sv_catpvn(buf_sv, out_ptr, n) ;
+           }
+           
+       }
+
+
+       SET_LEN(my_sv, 0) ;
+       BUF_OFFSET(my_sv) = 0 ;
+
+       if (FILTER_ACTIVE(my_sv))
+       {
+           dSP ;
+           int count ;
+
+            if (fdebug)
+               warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
+
+           ENTER ;
+           SAVETMPS;
+       
+           SAVEINT(current_idx) ;      /* save current idx */
+           current_idx = idx ;
+
+           SAVESPTR(DEFSV) ;   /* save $_ */
+           /* make $_ use our buffer */
+           DEFSV = sv_2mortal(newSVpv("", 0)) ; 
+
+           PUSHMARK(sp) ;
+
+           if (CODE_REF(my_sv)) {
+           /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
+               count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
+           }
+           else {
+                XPUSHs((SV*)PERL_OBJECT(my_sv)) ;  
+       
+               PUTBACK ;
+
+               count = perl_call_method("filter", G_SCALAR);
+           }
+
+           SPAGAIN ;
+
+            if (count != 1)
+               croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", 
+                       PERL_MODULE(my_sv), count ) ;
+    
+           n = POPi ;
+
+           if (fdebug)
+               warn("status = %d, length op buf = %d [%s]\n",
+                    n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
+           if (SvCUR(DEFSV))
+               sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; 
+
+           PUTBACK ;
+           FREETMPS ;
+           LEAVE ;
+       }
+       else
+           n = FILTER_READ(idx + 1, my_sv, maxlen) ;
+
+       if (n <= 0)
+       {
+           /* Either EOF or an error */
+
+           if (fdebug) 
+               warn ("filter_read %d returned %d , returning %d\n", idx, n,
+                   (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
+
+           /* PERL_MODULE(my_sv) ; */
+           /* PERL_OBJECT(my_sv) ; */
+           filter_del(filter_call); 
+
+           /* If error, return the code */
+           if (n < 0)
+               return n ;
+
+           /* return what we have so far else signal eof */
+           return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
+       }
+
+    }
+}
+
+
+
+MODULE = Filter::Util::Call            PACKAGE = Filter::Util::Call
+
+REQUIRE:       1.924
+PROTOTYPES:    ENABLE
+
+#define IDX            current_idx
+
+int
+filter_read(size=0)
+       int     size 
+       CODE:
+       {
+           SV * buffer = DEFSV ;
+
+           RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
+       }
+       OUTPUT:
+           RETVAL
+
+
+
+
+void
+real_import(object, perlmodule, coderef)
+    SV *       object
+    char *     perlmodule 
+    int                coderef
+    PPCODE:
+    {
+        SV * sv = newSV(1) ;
+
+        (void)SvPOK_only(sv) ;
+        filter_add(filter_call, sv) ;
+
+       PERL_MODULE(sv) = savepv(perlmodule) ;
+       PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
+       FILTER_ACTIVE(sv) = TRUE ;
+        BUF_OFFSET(sv) = 0 ;
+       CODE_REF(sv)   = coderef ;
+
+        SvCUR_set(sv, 0) ;
+
+    }
+
+void
+filter_del()
+    CODE:
+       FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
+
+
+
+void
+unimport(...)
+    PPCODE:
+    filter_del(filter_call);
+
+
+BOOT:
+    /* temporary hack to control debugging in toke.c */
+    if (fdebug)
+        filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  
+
+
diff --git a/ext/Filter/Util/Call/Makefile.PL b/ext/Filter/Util/Call/Makefile.PL
new file mode 100644 (file)
index 0000000..030dbc2
--- /dev/null
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+       NAME            => 'Filter::Util::Call',
+       VERSION_FROM    => 'Call.pm',
+       MAN3PODS        => {},  # Pods will be built by installman.
+);
index ab866ee..fe87dd0 100644 (file)
@@ -59,7 +59,7 @@ use XSLoader ();
        GDBM_WRITER
 );
 
-$VERSION = "1.03";
+$VERSION = "1.04";
 
 sub AUTOLOAD {
     my($constname);
index 13123ef..b4d3b3d 100644 (file)
@@ -56,7 +56,7 @@ not_here(char *s)
 static void
 output_datum(pTHX_ SV *arg, char *str, int size)
 {
-#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST))
+#if (!defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC))) && !defined(LEAKTEST)
        sv_usepvn(arg, str, size);
 #else
        sv_setpvn(arg, str, size);
index 4f79ae3..1dd0630 100644 (file)
@@ -19,8 +19,14 @@ T_DATUM_K
        $var.dsize = (int)PL_na;
 T_DATUM_V
         ckFilter($arg, filter_store_value, \"filter_store_value\");
-       $var.dptr = SvPV($arg, PL_na);
-       $var.dsize = (int)PL_na;
+       if (SvOK($arg)) {
+           $var.dptr = SvPV($arg, PL_na);
+           $var.dsize = (int)PL_na;
+       }
+       else {
+           $var.dptr = \"\";
+           $var.dsize = 0;
+       }
 OUTPUT
 T_DATUM_K
        output_datum(aTHX_ $arg, $var.dptr, $var.dsize);
index 1b79cfd..13b198c 100644 (file)
@@ -59,9 +59,9 @@ io_blocking(InputStream f, int block)
     if (RETVAL >= 0) {
        int mode = RETVAL;
 #ifdef O_NONBLOCK
-       /* POSIX style */ 
+       /* POSIX style */
 #if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
-       /* Ooops has O_NDELAY too - make sure we don't 
+       /* Ooops has O_NDELAY too - make sure we don't
         * get SysV behaviour by mistake. */
 
        /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
@@ -86,7 +86,7 @@ io_blocking(InputStream f, int block)
               }
        }
 #else
-       /* Standard POSIX */ 
+       /* Standard POSIX */
        RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
 
        if ((block == 0) && !(mode & O_NONBLOCK)) {
@@ -103,11 +103,11 @@ io_blocking(InputStream f, int block)
            if(ret < 0)
                RETVAL = ret;
         }
-#endif 
+#endif
 #else
        /* Not POSIX - better have O_NDELAY or we can't cope.
         * for BSD-ish machines this is an acceptable alternative
-        * for SysV we can't tell "would block" from EOF but that is 
+        * for SysV we can't tell "would block" from EOF but that is
         * the way SysV is...
         */
        RETVAL = RETVAL & O_NDELAY ? 0 : 1;
@@ -141,13 +141,18 @@ fgetpos(handle)
        InputStream     handle
     CODE:
        if (handle) {
-           Fpos_t pos;
 #ifdef PerlIO
-           PerlIO_getpos(handle, &pos);
+           ST(0) = sv_2mortal(newSV(0));
+           if (PerlIO_getpos(handle, ST(0)) != 0) {
+               ST(0) = &PL_sv_undef;
+           }
 #else
-           fgetpos(handle, &pos);
+           if (fgetpos(handle, &pos)) {
+               ST(0) = &PL_sv_undef;
+           } else {
+               ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+           }
 #endif
-           ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
        }
        else {
            ST(0) = &PL_sv_undef;
@@ -159,14 +164,21 @@ fsetpos(handle, pos)
        InputStream     handle
        SV *            pos
     CODE:
-        char *p;
-       STRLEN len;
-       if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
+       if (handle) {
 #ifdef PerlIO
-           RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+           RETVAL = PerlIO_setpos(handle, pos);
 #else
-           RETVAL = fsetpos(handle, (Fpos_t*)p);
+           char *p;
+           STRLEN len;
+           if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
+               RETVAL = fsetpos(handle, (Fpos_t*)p);
+           }
+           else {
+               RETVAL = -1;
+               errno = EINVAL;
+           }
 #endif
+       }
        else {
            RETVAL = -1;
            errno = EINVAL;
@@ -202,7 +214,7 @@ new_tmpfile(packname = "IO::File")
 
 MODULE = IO    PACKAGE = IO::Poll
 
-void   
+void
 _poll(timeout,...)
        int timeout;
 PPCODE:
index b6cb410..fb754a6 100644 (file)
@@ -110,7 +110,8 @@ or a file descriptor number.
 
 =item $io->opened
 
-Returns true if the object is currently a valid file descriptor.
+Returns true if the object is currently a valid file descriptor, false
+otherwise.
 
 =item $io->getline
 
@@ -139,31 +140,37 @@ called C<format_write>.
 =item $io->error
 
 Returns a true value if the given handle has experienced any errors
-since it was opened or since the last call to C<clearerr>.
+since it was opened or since the last call to C<clearerr>, or if the
+handle is invalid. It only returns false for a valid handle with no
+outstanding errors.
 
 =item $io->clearerr
 
-Clear the given handle's error indicator.
+Clear the given handle's error indicator. Returns -1 if the handle is
+invalid, 0 otherwise.
 
 =item $io->sync
 
 C<sync> synchronizes a file's in-memory state  with  that  on the
 physical medium. C<sync> does not operate at the perlio api level, but
-operates on the file descriptor, this means that any data held at the
-perlio api level will not be synchronized. To synchronize data that is
-buffered at the perlio api level you must use the flush method. C<sync>
-is not implemented on all platforms. See L<fsync(3c)>.
+operates on the file descriptor (similar to sysread, sysseek and
+systell). This means that any data held at the perlio api level will not
+be synchronized. To synchronize data that is buffered at the perlio api
+level you must use the flush method. C<sync> is not implemented on all
+platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
+for an invalid handle. See L<fsync(3c)>.
 
 =item $io->flush
 
 C<flush> causes perl to flush any buffered data at the perlio api level.
 Any unread data in the buffer will be discarded, and any unwritten data
-will be written to the underlying file descriptor.
+will be written to the underlying file descriptor. Returns "0 but true"
+on success, C<undef> on error.
 
 =item $io->printflush ( ARGS )
 
 Turns on autoflush, print ARGS and then restores the autoflush status of the
-C<IO::Handle> object.
+C<IO::Handle> object. Returns the return value from print.
 
 =item $io->blocking ( [ BOOL ] )
 
@@ -183,11 +190,18 @@ C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
 policy for an IO::Handle.  The calling sequences for the Perl functions
 are the same as their C counterparts--including the constants C<_IOFBF>,
 C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
-specifies a scalar variable to use as a buffer.  WARNING: A variable
-used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
-way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
-again, or memory corruption may result! Note that you need to import
-the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
+specifies a scalar variable to use as a buffer. You should only
+change the buffer before any I/O, or immediately after calling flush.
+
+WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
+be modified> in any way until the IO::Handle is closed or C<setbuf> or
+C<setvbuf> is called again, or memory corruption may result! Remember that
+the order of global destruction is undefined, so even if your buffer
+variable remains in scope until program termination, it may be undefined
+before the file IO::Handle is closed. Note that you need to import the
+constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
+returns nothing. setvbuf returns "0 but true", on success, C<undef> on
+failure.
 
 Lastly, there is a special method for working under B<-T> and setuid/gid
 scripts:
@@ -199,7 +213,8 @@ scripts:
 Marks the object as taint-clean, and as such data read from it will also
 be considered taint-clean. Note that this is a very trusting action to
 take, and appropriate consideration for the data source and potential
-vulnerability should be kept in mind.
+vulnerability should be kept in mind. Returns 0 on success, -1 if setting
+the taint-clean flag failed. (eg invalid handle)
 
 =back
 
index e09d48b..243a971 100644 (file)
@@ -18,19 +18,69 @@ C<IO::Seekable> does not have a constructor of its own as it is intended to
 be inherited by other C<IO::Handle> based objects. It provides methods
 which allow seeking of the file descriptors.
 
-If the C functions fgetpos() and fsetpos() are available, then
-C<$io-E<lt>getpos> returns an opaque value that represents the
-current position of the IO::File, and C<$io-E<gt>setpos(POS)> uses
-that value to return to a previously visited position.
+=over 4
 
+=item $io->getpos
+
+Returns an opaque value that represents the current position of the
+IO::File, or C<undef> if this is not possible (eg an unseekable stream such
+as a terminal, pipe or socket). If the fgetpos() function is available in
+your C library it is used to implements getpos, else perl emulates getpos
+using C's ftell() function.
+
+=item $io->setpos
+
+Uses the value of a previous getpos call to return to a previously visited
+position. Returns "0 but true" on success, C<undef> on failure.
+
+=back
+  
 See L<perlfunc> for complete descriptions of each of the following
 supported C<IO::Seekable> methods, which are just front ends for the
 corresponding built-in functions:
 
-  $io->seek( POS, WHENCE )
-  $io->sysseek( POS, WHENCE )
-  $io->tell
+=over 4
+
+=item $io->setpos ( POS, WHENCE )
+
+Seek the IO::File to position POS, relative to WHENCE:
+
+=over 8
+
+=item WHENCE=0 (SEEK_SET)
+
+POS is absolute position. (Seek relative to the start of the file)
+
+=item WHENCE=1 (SEEK_CUR)
+
+POS is an offset from the current position. (Seek relative to current)
+
+=item WHENCE=1 (SEEK_END)
+
+POS is an offset from the end of the file. (Seek relative to end)
+
+=back
+
+The SEEK_* constants can be imported from the C<Fcntl> module if you
+don't wish to use the numbers C<0> C<1> or C<2> in your code.
+
+Returns C<1> upon success, C<0> otherwise.
+
+=item $io->sysseek( POS, WHENCE )
+
+Similar to $io->seek, but sets the IO::File's position using the system
+call lseek(2) directly, so will confuse most perl IO operators except
+sysread and syswrite (see L<perlfunc> for full details)
+
+Returns the new position, or C<undef> on failure.  A position
+of zero is returned as the string C<"0 but true">
+
+=item $io->tell
+
+Returns the IO::File's current position, or -1 on error.
 
+=back
+  
 =head1 SEE ALSO
 
 L<perlfunc>, 
index e84b54f..1a3a26f 100644 (file)
@@ -56,6 +56,7 @@ sub exists
 sub _fileno
 {
  my($self, $f) = @_;
+ return unless defined $f;
  $f = $f->[0] if ref($f) eq 'ARRAY';
  ($f =~ /^\d+$/) ? $f : fileno($f);
 }
index 38062e0..4a10eb9 100644 (file)
@@ -203,7 +203,7 @@ ftok(path, id)
         key_t k = ftok(path, id);
         ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
 #else
-        DIE(PL_no_func, "ftok");
+        DIE(aTHX_ PL_no_func, "ftok");
 #endif
 
 int
index c9ef699..99aae17 100644 (file)
@@ -10,7 +10,7 @@ require Tie::Hash;
 use XSLoader ();
 
 our @ISA = qw(Tie::Hash);
-our $VERSION = "1.03";
+our $VERSION = "1.04";
 
 XSLoader::load 'NDBM_File', $VERSION;
 
index 49a1db5..c417eb6 100644 (file)
@@ -1,6 +1,11 @@
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
+/* If using the DB3 emulation, ENTER is defined both
+ * by DB3 and Perl.  We drop the Perl definition now.
+ * See also INSTALL section on DB3.
+ * -- Stanislav Brabec <utx@penguin.cz> */
+#undef ENTER
 #include <ndbm.h>
 
 typedef struct {
index eeb5d59..40b95f2 100644 (file)
@@ -20,8 +20,14 @@ T_DATUM_K
        $var.dsize = (int)PL_na;
 T_DATUM_V
         ckFilter($arg, filter_store_value, \"filter_store_value\");
-       $var.dptr = SvPV($arg, PL_na);
-       $var.dsize = (int)PL_na;
+       if (SvOK($arg)) {
+           $var.dptr = SvPV($arg, PL_na);
+           $var.dsize = (int)PL_na;
+       }
+       else {
+           $var.dptr = \"\";
+           $var.dsize = 0;
+       }
 T_GDATUM
        UNIMPLEMENTED
 OUTPUT
index 732ed60..4244eb9 100644 (file)
@@ -6,7 +6,7 @@ require Tie::Hash;
 use XSLoader ();
 
 our @ISA = qw(Tie::Hash);
-our $VERSION = "1.02";
+our $VERSION = "1.03";
 
 XSLoader::load 'ODBM_File', $VERSION;
 
index 150f2ef..27174ef 100644 (file)
@@ -3,6 +3,11 @@
 #include "XSUB.h"
 
 #ifdef I_DBM
+/* If using the DB3 emulation, ENTER is defined both
+ * by DB3 and Perl.  We drop the Perl definition now.
+ * See also INSTALL section on DB3.
+ * -- Stanislav Brabec <utx@penguin.cz> */
+#  undef ENTER
 #  include <dbm.h>
 #else
 #  ifdef I_RPCSVC_DBM
index 7c23815..096427e 100644 (file)
@@ -20,8 +20,14 @@ T_DATUM_K
        $var.dsize = (int)PL_na;
 T_DATUM_V
         ckFilter($arg, filter_store_value, \"filter_store_value\");
-       $var.dptr = SvPV($arg, PL_na);
-       $var.dsize = (int)PL_na;
+       if (SvOK($arg)) {
+           $var.dptr = SvPV($arg, PL_na);
+           $var.dsize = (int)PL_na;
+       }
+       else {
+           $var.dptr = \"\";
+           $var.dsize = 0;
+       }
 T_GDATUM
        UNIMPLEMENTED
 OUTPUT
index 841120c..6a5e30d 100644 (file)
@@ -2,18 +2,19 @@ package Opcode;
 
 require 5.005_64;
 
+use strict;
+
 our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK);
 
 $VERSION = "1.04";
 $XS_VERSION = "1.03";
 
-use strict;
 use Carp;
 use Exporter ();
 use XSLoader ();
-@ISA = qw(Exporter);
 
 BEGIN {
+    @ISA = qw(Exporter);
     @EXPORT_OK = qw(
        opset ops_to_opset
        opset_to_ops opset_to_hex invert_opset
index e191ec7..04f7c3f 100644 (file)
@@ -253,6 +253,12 @@ PPCODE:
     save_hptr(&PL_defstash);           /* save current default stash   */
     /* the assignment to global defstash changes our sense of 'main'   */
     PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already     */
+    if (strNE(HvNAME(PL_defstash),"main")) {
+        Safefree(HvNAME(PL_defstash));         
+        HvNAME(PL_defstash) = savepv("main"); /* make it think it's in main:: */
+        hv_store(PL_defstash,"_",1,(SV *)PL_defgv,0);  /* connect _ to global */
+        SvREFCNT_inc((SV *)PL_defgv);  /* want to keep _ around! */
+    }
     save_hptr(&PL_curstash);
     PL_curstash = PL_defstash;
 
index 55c5c1f..73bb02d 100644 (file)
@@ -2,12 +2,7 @@ use ExtUtils::MakeMaker;
 use Config;
 my @libs;
 if ($^O ne 'MSWin32') {
-    if ($Config{archname} =~ /RM\d\d\d-svr4/) {
-       @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]);
-    }
-    else {
-       @libs = ('LIBS' => ["-lm -lposix -lcposix"]);
-    }
+    @libs = ('LIBS' => ["-lm -lposix -lcposix"]);
 }
 WriteMakefile(
     NAME       => 'POSIX',
index 252e5bb..e1e6b28 100644 (file)
@@ -734,16 +734,6 @@ sub setbuf {
     redef "IO::Handle::setbuf()";
 }
 
-sub setgid {
-    usage "setgid(gid)" if @_ != 1;
-    $( = $_[0];
-}
-
-sub setuid {
-    usage "setuid(uid)" if @_ != 1;
-    $< = $_[0];
-}
-
 sub setvbuf {
     redef "IO::Handle::setvbuf()";
 }
index 314147c..10199e9 100644 (file)
@@ -1008,9 +1008,12 @@ see L<perlre>.
 
 =item setgid
 
-Sets the real group identifier for this process.
-Identical to assigning a value to the Perl's builtin C<$)> variable,
-see L<perlvar/$UID>.
+Sets the real group identifier and the effective group identifier for
+this process.  Similar to assigning a value to the Perl's builtin
+C<$)> variable, see L<perlvar/$GID>, except that the latter
+will change only the real user identifier, and that the setgid()
+uses only a single numeric argument, as opposed to a space-separated
+list of numbers.
 
 =item setjmp
 
@@ -1063,9 +1066,10 @@ setting the session identifier of the current process.
 
 =item setuid
 
-Sets the real user identifier for this process.
-Identical to assigning a value to the Perl's builtin C<$E<lt>> variable,
-see L<perlvar/$UID>.
+Sets the real user identifier and the effective user identifier for
+this process.  Similar to assigning a value to the Perl's builtin
+C<$E<lt>> variable, see L<perlvar/$UID>, except that the latter
+will change only the real user identifier.
 
 =item sigaction
 
@@ -1434,7 +1438,9 @@ Returns a name for a temporary file.
 
        $tmpfile = POSIX::tmpnam();
 
-See also L<File::Temp>.
+For security reasons, which are probably detailed in your system's
+documentation for the C library tmpnam() function, this interface
+should not be used; instead see L<File::Temp>.
 
 =item tolower
 
index a536671..887fcbc 100644 (file)
@@ -3940,6 +3940,14 @@ pathconf(filename, name)
 SysRet
 pause()
 
+SysRet
+setgid(gid)
+       Gid_t           gid
+
+SysRet
+setuid(uid)
+       Uid_t           uid
+
 SysRetLong
 sysconf(name)
        int             name
@@ -3947,3 +3955,4 @@ sysconf(name)
 char *
 ttyname(fd)
        int             fd
+
diff --git a/ext/POSIX/hints/svr4.pl b/ext/POSIX/hints/svr4.pl
new file mode 100644 (file)
index 0000000..07f2cb0
--- /dev/null
@@ -0,0 +1,12 @@
+# NCR MP-RAS.  Thanks to Doug Hendricks for this info.
+# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0'
+# This system needs to explicitly link against -lmw to pull in some
+# symbols such as _mwoflocheckl and possibly others.
+#  A. Dougherty  Thu Dec  7 11:55:28 EST 2000
+if ($Config{'archname'} =~ /3441-svr4/) {
+    $self->{LIBS} = ['-lm -posix -lcposix -lmw'];
+}
+# Not sure what OS this one is.
+elsif ($Config{archname} =~ /RM\d\d\d-svr4/) {
+    $self->{LIBS} = ['-lm -lc -lposix -lcposix'];
+}
index baf9bfc..d54d5d1 100644 (file)
@@ -3,6 +3,7 @@ pid_t                   T_NV
 Uid_t                  T_NV
 Time_t                 T_NV
 Gid_t                  T_NV
+Uid_t                  T_NV
 Off_t                  T_NV
 Dev_t                  T_NV
 NV                     T_NV
index a1debb9..132bdad 100644 (file)
@@ -1,4 +1,5 @@
 use ExtUtils::MakeMaker;
+use Config;
 
 # The existence of the ./sdbm/Makefile.PL file causes MakeMaker
 # to automatically include Makefile code for the targets
@@ -21,18 +22,26 @@ WriteMakefile(
 
 sub MY::postamble {
   if ($^O =~ /MSWin32/ && Win32::IsWin95()) {
-    # XXX: dmake-specific, like rest of Win95 port
-    return
-    '
+       if ($Config{'make'} =~ /dmake/i) {
+           # dmake-specific
+           return <<EOT;
 $(MYEXTLIB): sdbm/Makefile
 @[
        cd sdbm
        $(MAKE) all
        cd ..
 ]
-';
-  }
-  elsif ($^O ne 'VMS') {
+EOT
+       } elsif ($Config{'make'} =~ /nmake/i) {
+           #
+           return <<EOT;
+$(MYEXTLIB): sdbm/Makefile
+       cd sdbm
+       $(MAKE) all
+       cd ..
+EOT
+       } 
+} elsif ($^O ne 'VMS') {
     '
 $(MYEXTLIB): sdbm/Makefile
        cd sdbm && $(MAKE) all
index b3502b9..4d1411b 100644 (file)
@@ -6,7 +6,7 @@ require Tie::Hash;
 use XSLoader ();
 
 our @ISA = qw(Tie::Hash);
-our $VERSION = "1.02" ;
+our $VERSION = "1.03" ;
 
 XSLoader::load 'SDBM_File', $VERSION;
 
index 64c75cb..d41c770 100644 (file)
@@ -283,6 +283,10 @@ makroom(register DBM *db, long int hash, int need)
 {
        long newp;
        char twin[PBLKSIZ];
+#if defined(DOSISH) || defined(WIN32)
+       char zer[PBLKSIZ];
+       long oldtail;
+#endif
        char *pag = db->pagbuf;
        char *New = twin;
        register int smax = SPLTMAX;
@@ -305,6 +309,23 @@ makroom(register DBM *db, long int hash, int need)
  * still looking at the page of interest. current page is not updated
  * here, as sdbm_store will do so, after it inserts the incoming pair.
  */
+
+#if defined(DOSISH) || defined(WIN32)
+               /*
+                * Fill hole with 0 if made it.
+                * (hole is NOT read as 0)
+                */
+               oldtail = lseek(db->pagf, 0L, SEEK_END);
+               memset(zer, 0, PBLKSIZ);
+               while (OFF_PAG(newp) > oldtail) {
+                       if (lseek(db->pagf, 0L, SEEK_END) < 0 ||
+                           write(db->pagf, zer, PBLKSIZ) < 0) {
+
+                               return 0;
+                       }
+                       oldtail += PBLKSIZ;
+               }
+#endif
                if (hash & (db->hmask + 1)) {
                        if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0
                            || write(db->pagf, db->pagbuf, PBLKSIZ) < 0)
index eeb5d59..40b95f2 100644 (file)
@@ -20,8 +20,14 @@ T_DATUM_K
        $var.dsize = (int)PL_na;
 T_DATUM_V
         ckFilter($arg, filter_store_value, \"filter_store_value\");
-       $var.dptr = SvPV($arg, PL_na);
-       $var.dsize = (int)PL_na;
+       if (SvOK($arg)) {
+           $var.dptr = SvPV($arg, PL_na);
+           $var.dsize = (int)PL_na;
+       }
+       else {
+           $var.dptr = \"\";
+           $var.dsize = 0;
+       }
 T_GDATUM
        UNIMPLEMENTED
 OUTPUT
index 049ce29..92789b5 100644 (file)
@@ -1,3 +1,50 @@
+Wed Jan  3 10:43:18 MET 2001   Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+. Description:
+
+       Removed spurious 'clean' entry in Makefile.PL.
+
+       Added CAN_FLOCK to determine whether we can flock() or not,
+       by inspecting Perl's configuration parameters, as determined
+       by Configure.
+
+       Trace offending package when overloading cannot be restored
+       on a scalar.
+
+       Made context cleanup safer to avoid dup freeing, mostly in the
+       presence of repeated exceptions during store/retrieve (which can
+       cause memory leaks anyway, so it's just additional safety, not a
+       definite fix).
+
+Sun Nov  5 18:23:48 MET 2000   Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+. Description:
+
+       Version 1.0.6.
+
+       Fixed severe "object lost" bug for STORABLE_freeze returns,
+       when refs to lexicals, taken within the hook, were to be
+       serialized by Storable.  Enhanced the t/recurse.t test to
+       stress hook a little more with refs to lexicals.
+
+Thu Oct 26 19:14:38 MEST 2000   Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+. Description:
+
+       Version 1.0.5.
+
+       Documented that store() and retrieve() can return undef.
+       That is, the error reporting is not always made via exceptions,
+       as the paragraph on error reporting was implying.
+
+       Auto requires module of blessed ref when STORABLE_thaw misses.
+       When the Storable engine looks for the STORABLE_thaw hook and
+       does not find it, it now tries to require the package into which
+       the blessed reference is.
+
+       Just check $^O, in t/lock.t: there's no need to pull the whole
+       Config module for that.
+
 Fri Sep 29 21:52:29 MEST 2000   Raphael Manfredi <Raphael_Manfredi@pobox.com>
 
 . Description:
index 7ed71e6..c8151f3 100644 (file)
@@ -1,4 +1,4 @@
-# $Id: Makefile.PL,v 1.0 2000/09/01 19:40:41 ram Exp $
+# $Id: Makefile.PL,v 1.0.1.1 2001/01/03 09:38:39 ram Exp $
 #
 #  Copyright (c) 1995-2000, Raphael Manfredi
 #  
@@ -6,6 +6,9 @@
 #  in the README file that comes with the distribution.
 #
 # $Log: Makefile.PL,v $
+# Revision 1.0.1.1  2001/01/03 09:38:39  ram
+# patch7: removed spurious 'clean' entry
+#
 # Revision 1.0  2000/09/01 19:40:41  ram
 # Baseline for first official release.
 #
@@ -19,6 +22,5 @@ WriteMakefile(
        'MAN3PODS'              => {},
     'VERSION_FROM'     => 'Storable.pm',
     'dist'                     => { SUFFIX => 'gz', COMPRESS => 'gzip -f' },
-    'clean'                    => {'FILES' => '*%'},
 );
 
index 76c3209..06c05d4 100644 (file)
@@ -1,4 +1,4 @@
-;# $Id: Storable.pm,v 1.0 2000/09/01 19:40:41 ram Exp $
+;# $Id: Storable.pm,v 1.0.1.7 2001/01/03 09:39:02 ram Exp $
 ;#
 ;#  Copyright (c) 1995-2000, Raphael Manfredi
 ;#  
@@ -6,6 +6,21 @@
 ;#  in the README file that comes with the distribution.
 ;#
 ;# $Log: Storable.pm,v $
+;# Revision 1.0.1.7  2001/01/03 09:39:02  ram
+;# patch7: added CAN_FLOCK to determine whether we can flock() or not
+;#
+;# Revision 1.0.1.6  2000/11/05 17:20:25  ram
+;# patch6: increased version number
+;#
+;# Revision 1.0.1.5  2000/10/26 17:10:18  ram
+;# patch5: documented that store() and retrieve() can return undef
+;# patch5: added paragraph explaining the auto require for thaw hooks
+;#
+;# Revision 1.0.1.4  2000/10/23 18:02:57  ram
+;# patch4: protected calls to flock() for dos platform
+;# patch4: added logcarp emulation if they don't have Log::Agent
+;#
+;# $Log: Storable.pm,v $
 ;# Revision 1.0  2000/09/01 19:40:41  ram
 ;# Baseline for first official release.
 ;#
@@ -26,7 +41,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 use AutoLoader;
 use vars qw($forgive_me $VERSION);
 
-$VERSION = '1.003';
+$VERSION = '1.007';
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;            # Grrr...
 
 #
@@ -41,6 +56,10 @@ unless (defined @Log::Agent::EXPORT) {
                        require Carp;
                        Carp::croak(@_);
                }
+               sub logcarp {
+                       require Carp;
+                       Carp::carp(@_);
+               }
        };
 }
 
@@ -61,9 +80,25 @@ BEGIN {
 }
 
 sub logcroak;
+sub logcarp;
 
 sub retrieve_fd { &fd_retrieve }               # Backward compatibility
 
+#
+# Determine whether locking is possible, but only when needed.
+#
+
+my $CAN_FLOCK;
+
+sub CAN_FLOCK {
+       return $CAN_FLOCK if defined $CAN_FLOCK;
+       require Config; import Config;
+       return $CAN_FLOCK =
+               $Config{'d_flock'} ||
+               $Config{'d_fcntl_can_lock'} ||
+               $Config{'d_lockf'};
+}
+
 bootstrap Storable;
 1;
 __END__
@@ -118,6 +153,10 @@ sub _store {
        open(FILE, ">$file") || logcroak "can't create $file: $!";
        binmode FILE;                           # Archaic systems...
        if ($use_locking) {
+               unless (&CAN_FLOCK) {
+                       logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
+                       return undef;
+               }
                flock(FILE, LOCK_EX) ||
                        logcroak "can't get exclusive lock on $file: $!";
                truncate FILE, 0;
@@ -234,7 +273,12 @@ sub _retrieve {
        my $self;
        my $da = $@;                                                    # Could be from exception handler
        if ($use_locking) {
-               flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
+               unless (&CAN_FLOCK) {
+                       logcarp "Storable::lock_retrieve: fcntl/flock emulation broken on $^O";
+                       return undef;
+               }
+               flock(FILE, LOCK_SH) ||
+                       logcroak "can't get shared lock on $file: $!";
                # Unlocking will happen when FILE is closed
        }
        eval { $self = pretrieve(*FILE) };              # Call C routine
@@ -435,6 +479,9 @@ those exceptions.
 When Storable croaks, it tries to report the error via the C<logcroak()>
 routine from the C<Log::Agent> package, if it is available.
 
+Normal errors are reported by having store() or retrieve() return C<undef>.
+Such errors are usually I/O errors (or truncated stream errors at retrieval).
+
 =head1 WIZARDS ONLY
 
 =head2 Hooks
@@ -514,6 +561,13 @@ and there may be an optional list of references, in the same order you gave
 them at serialization time, pointing to the deserialized objects (which
 have been processed courtesy of the Storable engine).
 
+When the Storable engine does not find any C<STORABLE_thaw> hook routine,
+it tries to load the class by requiring the package dynamically (using
+the blessed package name), and then re-attempts the lookup.  If at that
+time the hook cannot be located, the engine croaks.  Note that this mechanism
+will fail if you define several classes in the same file, but perlmod(1)
+warned you.
+
 It is up to you to use these information to populate I<obj> the way you want.
 
 Returned value: none.
index 1c412b5..9378001 100644 (file)
@@ -3,7 +3,7 @@
  */
 
 /*
- * $Id: Storable.xs,v 1.0 2000/09/01 19:40:41 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $
  *
  *  Copyright (c) 1995-2000, Raphael Manfredi
  *  
  *  in the README file that comes with the distribution.
  *
  * $Log: Storable.xs,v $
+ * Revision 1.0.1.6  2001/01/03 09:40:40  ram
+ * patch7: prototype and casting cleanup
+ * patch7: trace offending package when overloading cannot be restored
+ * patch7: made context cleanup safer to avoid dup freeing
+ *
+ * Revision 1.0.1.5  2000/11/05 17:21:24  ram
+ * patch6: fixed severe "object lost" bug for STORABLE_freeze returns
+ *
+ * Revision 1.0.1.4  2000/10/26 17:11:04  ram
+ * patch5: auto requires module of blessed ref when STORABLE_thaw misses
+ *
+ * Revision 1.0.1.3  2000/09/29 19:49:57  ram
+ * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
+ *
+ * $Log: Storable.xs,v $
  * Revision 1.0  2000/09/01 19:40:41  ram
  * Baseline for first official release.
  *
@@ -87,14 +102,21 @@ typedef double NV;                 /* Older perls lack the NV type */
 #endif
 
 #ifdef DEBUGME
-#ifndef DASSERT
-#define DASSERT
-#endif
-#define TRACEME(x)     do { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } while (0)
+/*
+ * TRACEME() will only output things when the $Storable::DEBUGME is true.
+ */
+
+#define TRACEME(x)     do {                                                                    \
+       if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE)))     \
+               { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }                     \
+} while (0)
 #else
 #define TRACEME(x)
 #endif
 
+#ifndef DASSERT
+#define DASSERT
+#endif
 #ifdef DASSERT
 #define ASSERT(x,y)    do {                                                                    \
        if (!(x)) {                                                                                             \
@@ -235,6 +257,7 @@ typedef struct stcxt {
        int entry;                      /* flags recursion */
        int optype;                     /* type of traversal operation */
     HV *hseen;                 /* which objects have been seen, store time */
+    AV *hook_seen;             /* which SVs were returned by STORABLE_freeze() */
     AV *aseen;                 /* which objects have been seen, retrieve time */
     HV *hclass;                        /* which classnames have been seen, store time */
     AV *aclass;                        /* which classnames have been seen, retrieve time */
@@ -652,7 +675,7 @@ static char magicstr[] = "pst0";                    /* Used as a magic number */
 #define GETMARK(x) do {                                                        \
        if (!cxt->fio)                                                          \
                MBUF_GETC(x);                                                   \
-       else if ((x = PerlIO_getc(cxt->fio)) == EOF)    \
+       else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)      \
                return (SV *) 0;                                                \
 } while (0)
 
@@ -740,14 +763,14 @@ static int store_tied_item(stcxt_t *cxt, SV *sv);
 static int store_other(stcxt_t *cxt, SV *sv);
 static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
 
-static int (*sv_store[])() = {
-       store_ref,                      /* svis_REF */
-       store_scalar,           /* svis_SCALAR */
-       store_array,            /* svis_ARRAY */
-       store_hash,                     /* svis_HASH */
-       store_tied,                     /* svis_TIED */
-       store_tied_item,        /* svis_TIED_ITEM */
-       store_other,            /* svis_OTHER */
+static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
+       store_ref,                                                                              /* svis_REF */
+       store_scalar,                                                                   /* svis_SCALAR */
+       (int (*)(stcxt_t *cxt, SV *sv)) store_array,    /* svis_ARRAY */
+       (int (*)(stcxt_t *cxt, SV *sv)) store_hash,             /* svis_HASH */
+       store_tied,                                                                             /* svis_TIED */
+       store_tied_item,                                                                /* svis_TIED_ITEM */
+       store_other,                                                                    /* svis_OTHER */
 };
 
 #define SV_STORE(x)    (*sv_store[x])
@@ -773,7 +796,7 @@ static SV *retrieve_tied_hash(stcxt_t *cxt);
 static SV *retrieve_tied_scalar(stcxt_t *cxt);
 static SV *retrieve_other(stcxt_t *cxt);
 
-static SV *(*sv_old_retrieve[])() = {
+static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = {
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        old_retrieve_array,             /* SX_ARRAY -- for pre-0.6 binaries */
@@ -814,7 +837,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt);
 static SV *retrieve_tied_key(stcxt_t *cxt);
 static SV *retrieve_tied_idx(stcxt_t *cxt);
 
-static SV *(*sv_retrieve[])() = {
+static SV *(*sv_retrieve[])(stcxt_t *cxt) = {
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        retrieve_array,                 /* SX_ARRAY */
@@ -946,6 +969,15 @@ static void init_store_context(
         */
 
        cxt->hook = newHV();                    /* Table where hooks are cached */
+
+       /*
+        * The `hook_seen' array keeps track of all the SVs returned by
+        * STORABLE_freeze hooks for us to serialize, so that they are not
+        * reclaimed until the end of the serialization process.  Each SV is
+        * only stored once, the first time it is seen.
+        */
+
+       cxt->hook_seen = newAV();               /* Lists SVs returned by STORABLE_freeze */
 }
 
 /*
@@ -975,16 +1007,41 @@ static void clean_store_context(stcxt_t *cxt)
 
        /*
         * And now dispose of them...
+        *
+        * The surrounding if() protection has been added because there might be
+        * some cases where this routine is called more than once, during
+        * exceptionnal events.  This was reported by Marc Lehmann when Storable
+        * is executed from mod_perl, and the fix was suggested by him.
+        *              -- RAM, 20/12/2000
         */
 
-       hv_undef(cxt->hseen);
-       sv_free((SV *) cxt->hseen);
+       if (cxt->hseen) {
+               HV *hseen = cxt->hseen;
+               cxt->hseen = 0;
+               hv_undef(hseen);
+               sv_free((SV *) hseen);
+       }
+
+       if (cxt->hclass) {
+               HV *hclass = cxt->hclass;
+               cxt->hclass = 0;
+               hv_undef(hclass);
+               sv_free((SV *) hclass);
+       }
 
-       hv_undef(cxt->hclass);
-       sv_free((SV *) cxt->hclass);
+       if (cxt->hook) {
+               HV *hook = cxt->hook;
+               cxt->hook = 0;
+               hv_undef(hook);
+               sv_free((SV *) hook);
+       }
 
-       hv_undef(cxt->hook);
-       sv_free((SV *) cxt->hook);
+       if (cxt->hook_seen) {
+               AV *hook_seen = cxt->hook_seen;
+               cxt->hook_seen = 0;
+               av_undef(hook_seen);
+               sv_free((SV *) hook_seen);
+       }
 
        cxt->entry = 0;
        cxt->s_dirty = 0;
@@ -1039,17 +1096,33 @@ static void clean_retrieve_context(stcxt_t *cxt)
 
        ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
 
-       av_undef(cxt->aseen);
-       sv_free((SV *) cxt->aseen);
+       if (cxt->aseen) {
+               AV *aseen = cxt->aseen;
+               cxt->aseen = 0;
+               av_undef(aseen);
+               sv_free((SV *) aseen);
+       }
 
-       av_undef(cxt->aclass);
-       sv_free((SV *) cxt->aclass);
+       if (cxt->aclass) {
+               AV *aclass = cxt->aclass;
+               cxt->aclass = 0;
+               av_undef(aclass);
+               sv_free((SV *) aclass);
+       }
 
-       hv_undef(cxt->hook);
-       sv_free((SV *) cxt->hook);
+       if (cxt->hook) {
+               HV *hook = cxt->hook;
+               cxt->hook = 0;
+               hv_undef(hook);
+               sv_free((SV *) hook);
+       }
 
-       if (cxt->hseen)
-               sv_free((SV *) cxt->hseen);             /* optional HV, for backward compat. */
+       if (cxt->hseen) {
+               HV *hseen = cxt->hseen;
+               cxt->hseen = 0;
+               hv_undef(hseen);
+               sv_free((SV *) hseen);          /* optional HV, for backward compat. */
+       }
 
        cxt->entry = 0;
        cxt->s_dirty = 0;
@@ -1071,6 +1144,8 @@ stcxt_t *cxt;
                clean_retrieve_context(cxt);
        else
                clean_store_context(cxt);
+
+       ASSERT(!cxt->s_dirty, ("context is clean"));
 }
 
 /*
@@ -1223,6 +1298,19 @@ static void pkg_hide(
 }
 
 /*
+ * pkg_uncache
+ *
+ * Discard cached value: a whole fetch loop will be retried at next lookup.
+ */
+static void pkg_uncache(
+       HV *cache,
+       HV *pkg,
+       char *method)
+{
+       (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
+}
+
+/*
  * pkg_can
  *
  * Our own "UNIVERSAL::can", which caches results.
@@ -2096,11 +2184,14 @@ static int store_hook(
 
        for (i = 1; i < count; i++) {
                SV **svh;
-               SV *xsv = ary[i];
+               SV *rsv = ary[i];
+               SV *xsv;
+               AV *av_hook = cxt->hook_seen;
 
-               if (!SvROK(xsv))
-                       CROAK(("Item #%d from hook in %s is not a reference", i, class));
-               xsv = SvRV(xsv);                /* Follow ref to know what to look for */
+               if (!SvROK(rsv))
+                       CROAK(("Item #%d returned by STORABLE_freeze "
+                               "for %s is not a reference", i, class));
+               xsv = SvRV(rsv);                /* Follow ref to know what to look for */
 
                /*
                 * Look in hseen and see if we have a tag already.
@@ -2136,11 +2227,34 @@ static int store_hook(
                        CROAK(("Could not serialize item #%d from hook in %s", i, class));
 
                /*
-                * Replace entry with its tag (not a real SV, so no refcnt increment)
+                * It was the first time we serialized `xsv'.
+                *
+                * Keep this SV alive until the end of the serialization: if we
+                * disposed of it right now by decrementing its refcount, and it was
+                * a temporary value, some next temporary value allocated during
+                * another STORABLE_freeze might take its place, and we'd wrongly
+                * assume that new SV was already serialized, based on its presence
+                * in cxt->hseen.
+                *
+                * Therefore, push it away in cxt->hook_seen.
                 */
 
+               av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
+
        sv_seen:
-               SvREFCNT_dec(xsv);
+               /*
+                * Dispose of the REF they returned.  If we saved the `xsv' away
+                * in the array of returned SVs, that will not cause the underlying
+                * referenced SV to be reclaimed.
+                */
+
+               ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
+               SvREFCNT_dec(rsv);                      /* Dispose of reference */
+
+               /*
+                * Replace entry with its tag (not a real SV, so no refcnt increment)
+                */
+
                ary[i] = *svh;
                TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
                         i-1, PTR2UV(xsv), PTR2UV(*svh)));
@@ -3131,8 +3245,37 @@ static SV *retrieve_hook(stcxt_t *cxt)
 
        BLESS(sv, class);
        hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
-       if (!hook)
-               CROAK(("No STORABLE_thaw defined for objects of class %s", class));
+       if (!hook) {
+               /*
+                * Hook not found.  Maybe they did not require the module where this
+                * hook is defined yet?
+                *
+                * If the require below succeeds, we'll be able to find the hook.
+                * Still, it only works reliably when each class is defined in a
+                * file of its own.
+                */
+
+               SV *psv = newSVpvn("require ", 8);
+               sv_catpv(psv, class);
+
+               TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
+               TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
+
+               perl_eval_sv(psv, G_DISCARD);
+               sv_free(psv);
+
+               /*
+                * We cache results of pkg_can, so we need to uncache before attempting
+                * the lookup again.
+                */
+
+               pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+               hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+
+               if (!hook)
+                       CROAK(("No STORABLE_thaw defined for objects of class %s "
+                                       "(even after a \"require %s;\")", class, class));
+       }
 
        /*
         * If we don't have an `av' yet, prepare one.
@@ -3273,9 +3416,10 @@ static SV *retrieve_overloaded(stcxt_t *cxt)
 
        stash = (HV *) SvSTASH (sv);
        if (!stash || !Gv_AMG(stash))
-               CROAK(("Cannot restore overloading on %s(0x%"UVxf")",
+               CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
                       sv_reftype(sv, FALSE),
-                      PTR2UV(sv)));
+                      PTR2UV(sv),
+                          stash ? HvNAME(stash) : "<unknown>"));
 
        SvAMAGIC_on(rv);
 
index c7ce3de..71f5b82 100644 (file)
@@ -264,7 +264,9 @@ sub xlate {
     $name = uc $name;
     $name = "LOG_$name" unless $name =~ /^LOG_/;
     $name = "Sys::Syslog::$name";
-    eval { &$name } || -1;
+    # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
+    my $value = eval { &$name };
+    defined $value ? $value : -1;
 }
 
 sub connect {
@@ -274,8 +276,8 @@ sub connect {
        ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
     }
     unless ( $sock_type ) {
-        my $udp = getprotobyname('udp');
-        my $syslog = getservbyname('syslog','udp');
+        my $udp = getprotobyname('udp')                 || croak "getprotobyname failed for udp";
+        my $syslog = getservbyname('syslog','udp')      || croak "getservbyname failed";
         my $this = sockaddr_in($syslog, INADDR_ANY);
         my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
         socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp)           || croak "socket: $!";
index c752e3d..f8a8a26 100644 (file)
@@ -21,6 +21,11 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change)
     $result = $t->join;
     $result = $t->eval;
     $t->detach;
+    $flags = $t->flags;
+    
+    if ($t->done) {
+        $t->join;
+    }
 
     if($t->equal($another_thread)) {
        # ...
@@ -181,6 +186,17 @@ increasing integer assigned when a thread is created. The main thread of a
 program will have a tid of zero, while subsequent threads will have tids
 assigned starting with one.
 
+=item flags
+
+The C<flags> method returns the flags for the thread. This is the
+integer value corresponding to the internal flags for the thread, and
+the value may not be all that meaningful to you.
+
+=item done
+
+The C<done> method returns true if the thread you're checking has
+finished, and false otherwise.
+
 =back
 
 =head1 LIMITATIONS
index 17e5aef..c117c60 100644 (file)
@@ -98,7 +98,6 @@ threadstart(void *arg)
     DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n",
                          thr));
 
-    /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */
     /*
      * Wait until our creator releases us. If we didn't do this, then
      * it would be potentially possible for out thread to carry on and
@@ -116,7 +115,6 @@ threadstart(void *arg)
      */
     PERL_SET_THX(thr);
 
-    /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
     DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
                          thr, SvPEEK(TOPs)));
 
@@ -177,7 +175,7 @@ threadstart(void *arg)
     Safefree(PL_savestack);
     Safefree(PL_retstack);
     Safefree(PL_tmps_stack);
-    Safefree(PL_ofs);
+    SvREFCNT_dec(PL_ofs_sv);
 
     SvREFCNT_dec(PL_rs);
     SvREFCNT_dec(PL_nrs);
@@ -191,6 +189,7 @@ threadstart(void *arg)
     Safefree(PL_reg_poscache);
 
     MUTEX_LOCK(&thr->mutex);
+    thr->thr_done = 1;
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: threadstart finishing: state is %u\n",
                          thr, ThrSTATE(thr)));
@@ -448,6 +447,14 @@ flags(t)
 #endif
 
 void
+done(t)
+       Thread  t
+    PPCODE:
+#ifdef USE_THREADS
+       PUSHs(t->thr_done ? &PL_sv_yes : &PL_sv_no);
+#endif
+
+void
 self(classname)
        char *  classname
     PREINIT:
index bc31b2c..b8d25bd 100644 (file)
@@ -1,12 +1,15 @@
 use ExtUtils::MakeMaker;
 use File::Spec;
+use Config;
+
+my $object = 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)';
 
 WriteMakefile(
     NAME               => 're',
     VERSION_FROM       => 're.pm',
     MAN3PODS           => {},  # Pods will be built by installman.
     XSPROTOARG         => '-noprototypes',
-    OBJECT             => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)',
+    OBJECT             => $object,
     DEFINE             => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG',
     clean              => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' },
 );
diff --git a/ext/re/hints/aix.pl b/ext/re/hints/aix.pl
new file mode 100644 (file)
index 0000000..4fbfefd
--- /dev/null
@@ -0,0 +1,22 @@
+# Add explicit link to deb.o to pick up .Perl_deb symbol which is not
+# mentioned in perl.exp for earlier cc (xlc) versions in at least
+# non DEBUGGING builds
+#  Peter Prymmer <pvhp@best.com>
+
+use Config;
+
+if ($^O eq 'aix' && defined($Config{'ccversion'}) && 
+    ( $Config{'ccversion'} =~ /^3\.\d/
+      # needed for at least these versions:
+      # $Config{'ccversion'} eq '3.6.6.0' 
+      # $Config{'ccversion'} eq '3.6.4.0' 
+      # $Config{'ccversion'} eq '3.1.4.0'  AIX 4.2
+      # $Config{'ccversion'} eq '3.1.4.10' AIX 4.2
+      # $Config{'ccversion'} eq '3.1.3.3' 
+      ||
+      $Config{'ccversion'} =~ /^4\.4\.0\.[0-3]/
+    )
+   ) {
+    $self->{OBJECT} .= ' ../../deb$(OBJ_EXT)';
+}
+
index 04a5fdc..25c2a90 100644 (file)
@@ -25,7 +25,6 @@ static int oldfl;
 static void
 deinstall(pTHX)
 {
-    dTHR;
     PL_regexecp = Perl_regexec_flags;
     PL_regcompp = Perl_pregcomp;
     PL_regint_start = Perl_re_intuit_start;
@@ -39,7 +38,6 @@ deinstall(pTHX)
 static void
 install(pTHX)
 {
-    dTHR;
     PL_colorset = 0;                   /* Allow reinspection of ENV. */
     PL_regexecp = &my_regexec;
     PL_regcompp = &my_regcomp;
diff --git a/fakesdio.h b/fakesdio.h
new file mode 100644 (file)
index 0000000..4791232
--- /dev/null
@@ -0,0 +1,104 @@
+/*
+ * This is "source level" stdio compatibility mode.
+ * We try and #define stdio functions in terms of PerlIO.
+ */
+#define _CANNOT "CANNOT"
+#undef FILE
+#define FILE                   PerlIO
+#undef clearerr
+#undef fclose
+#undef fdopen
+#undef feof
+#undef ferror
+#undef fflush
+#undef fgetc
+#undef fgetpos
+#undef fgets
+#undef fileno
+#undef flockfile
+#undef fopen
+#undef fprintf
+#undef fputc
+#undef fputs
+#undef fread
+#undef freopen
+#undef fscanf
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef ftrylockfile
+#undef funlockfile
+#undef fwrite
+#undef getc
+#undef getc_unlocked
+#undef getw
+#undef pclose
+#undef popen
+#undef putc
+#undef putc_unlocked
+#undef putw
+#undef rewind
+#undef setbuf
+#undef setvbuf
+#undef stderr
+#undef stdin
+#undef stdout
+#undef tmpfile
+#undef ungetc
+#undef vfprintf
+#define fprintf                        PerlIO_printf
+#define stdin                  PerlIO_stdin()
+#define stdout                 PerlIO_stdout()
+#define stderr                 PerlIO_stderr()
+#define tmpfile()              PerlIO_tmpfile()
+#define fclose(f)              PerlIO_close(f)
+#define fflush(f)              PerlIO_flush(f)
+#define fopen(p,m)             PerlIO_open(p,m)
+#define vfprintf(f,fmt,a)      PerlIO_vprintf(f,fmt,a)
+#define fgetc(f)               PerlIO_getc(f)
+#define fputc(c,f)             PerlIO_putc(f,c)
+#define fputs(s,f)             PerlIO_puts(f,s)
+#define getc(f)                        PerlIO_getc(f)
+#define getc_unlocked(f)       PerlIO_getc(f)
+#define putc(c,f)              PerlIO_putc(f,c)
+#define putc_unlocked(c,f)     PerlIO_putc(c,f)
+#define ungetc(c,f)            PerlIO_ungetc(f,c)
+#if 0
+/* return values of read/write need work */
+#define fread(b,s,c,f)         PerlIO_read(f,b,(s*c))
+#define fwrite(b,s,c,f)                PerlIO_write(f,b,(s*c))
+#else
+#define fread(b,s,c,f)         _CANNOT fread
+#define fwrite(b,s,c,f)                _CANNOT fwrite
+#endif
+#define fseek(f,o,w)           PerlIO_seek(f,o,w)
+#define ftell(f)               PerlIO_tell(f)
+#define rewind(f)              PerlIO_rewind(f)
+#define clearerr(f)            PerlIO_clearerr(f)
+#define feof(f)                        PerlIO_eof(f)
+#define ferror(f)              PerlIO_error(f)
+#define fdopen(fd,p)           PerlIO_fdopen(fd,p)
+#define fileno(f)              PerlIO_fileno(f)
+#define popen(c,m)             my_popen(c,m)
+#define pclose(f)              my_pclose(f)
+
+#define fsetpos(f,p)           _CANNOT _fsetpos_
+#define fgetpos(f,p)           _CANNOT _fgetpos_
+
+#define __filbuf(f)            _CANNOT __filbuf_
+#define _filbuf(f)             _CANNOT _filbuf_
+#define __flsbuf(c,f)          _CANNOT __flsbuf_
+#define _flsbuf(c,f)           _CANNOT _flsbuf_
+#define getw(f)                        _CANNOT _getw_
+#define putw(v,f)              _CANNOT _putw_
+#if SFIO_VERSION < 20000101L
+#define flockfile(f)           _CANNOT _flockfile_
+#define ftrylockfile(f)                _CANNOT _ftrylockfile_
+#define funlockfile(f)         _CANNOT _funlockfile_
+#endif
+#define freopen(p,m,f)         _CANNOT _freopen_
+#define setbuf(f,b)            _CANNOT _setbuf_
+#define setvbuf(f,b,x,s)       _CANNOT _setvbuf_
+#define fscanf                 _CANNOT _fscanf_
+#define fgets(s,n,f)           _CANNOT _fgets_
+
diff --git a/fix_pl b/fix_pl
deleted file mode 100644 (file)
index 44c3f52..0000000
--- a/fix_pl
+++ /dev/null
@@ -1,21 +0,0 @@
-#!perl
-# Not fixing perl, but fixing the patchlevel if this perl comes
-# from the repository rather than an official release
-exit unless -e ".patch";
-open PATCH, ".patch" or die "Couldn't open .patch: $!";
-open PLIN, "patchlevel.h" or die "Couldn't open patchlevel.h : $!";
-open PLOUT, ">patchlevel.new" or die "Couldn't write on patchlevel.new : $!";
-my $pl = <PATCH>;
-chomp ($pl);
-$pl =~ s/\D//g;
-my $seen=0;
-while (<PLIN>) {
-    if (/\t,NULL/ and $seen) {
-        print PLOUT "\t,\"devel-$pl\"\n";
-    }
-    $seen++ if /local_patches\[\]/;
-    print PLOUT;
-}
-close PLOUT; close PLIN;
-rename "patchlevel.new", "patchlevel.h" or die "Couldn't rename: $!";
-unlink ".patch";
diff --git a/form.h b/form.h
index ca2a0c8..4353b63 100644 (file)
--- a/form.h
+++ b/form.h
@@ -1,6 +1,6 @@
 /*    form.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -23,4 +23,5 @@
 #define FF_NEWLINE     13
 #define FF_BLANK       14
 #define FF_MORE                15
+#define FF_0DECIMAL   16
 
index 0dea03e..2f6f65b 100644 (file)
@@ -21,6 +21,7 @@ Perl_get_context
 Perl_set_context
 Perl_amagic_call
 Perl_Gv_AMupdate
+Perl_gv_handler
 Perl_apply_attrs_string
 Perl_avhv_delete_ent
 Perl_avhv_exists_ent
@@ -315,6 +316,7 @@ Perl_pmflag
 Perl_pop_scope
 Perl_push_scope
 Perl_regdump
+Perl_regclass_swash
 Perl_pregexec
 Perl_pregfree
 Perl_pregcomp
@@ -358,6 +360,7 @@ Perl_save_scalar
 Perl_save_pptr
 Perl_save_vptr
 Perl_save_re_context
+Perl_save_padsv
 Perl_save_sptr
 Perl_save_svref
 Perl_save_threadsv
@@ -443,6 +446,7 @@ Perl_sv_taint
 Perl_sv_tainted
 Perl_sv_unmagic
 Perl_sv_unref
+Perl_sv_unref_flags
 Perl_sv_untaint
 Perl_sv_upgrade
 Perl_sv_usepvn
@@ -461,12 +465,13 @@ Perl_unlock_condpair
 Perl_unsharepvn
 Perl_utf16_to_utf8
 Perl_utf16_to_utf8_reversed
+Perl_utf8_length
 Perl_utf8_distance
 Perl_utf8_hop
 Perl_utf8_to_bytes
 Perl_bytes_to_utf8
+Perl_utf8_to_uv_simple
 Perl_utf8_to_uv
-Perl_utf8_to_uv_chk
 Perl_uv_to_utf8
 Perl_warn
 Perl_vwarn
@@ -527,6 +532,7 @@ Perl_sv_utf8_downgrade
 Perl_sv_utf8_encode
 Perl_sv_utf8_decode
 Perl_sv_force_normal
+Perl_sv_force_normal_flags
 Perl_tmps_grow
 Perl_sv_rvweaken
 Perl_newANONATTRSUB
diff --git a/gv.c b/gv.c
index 768824d..f2931ae 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,6 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -53,7 +53,6 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
 GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
-    dTHR;
     char smallbuf[256];
     char *tmpbuf;
     STRLEN tmplen;
@@ -85,7 +84,6 @@ Perl_gv_fetchfile(pTHX_ const char *name)
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
-    dTHR;
     register GP *gp;
     bool doproto = SvTYPE(gv) > SVt_NULL;
     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
@@ -227,7 +225,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
            basestash = gv_stashpvn(packname, packlen, TRUE);
            gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
            if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
-               dTHR;           /* just for SvREFCNT_dec */
                gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
                if (!gvp || !(gv = *gvp))
                    Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
@@ -247,7 +244,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
            SV* sv = *svp++;
            HV* basestash = gv_stashsv(sv, FALSE);
            if (!basestash) {
-               dTHR;           /* just for ckWARN */
                if (ckWARN(WARN_MISC))
                    Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
                        SvPVX(sv), HvNAME(stash));
@@ -342,7 +338,6 @@ C<call_sv> apply equally to these functions.
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
-    dTHR;
     register const char *nend;
     const char *nsplit = 0;
     GV* gv;
@@ -403,7 +398,6 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 GV*
 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 {
-    dTHR;
     static char autoload[] = "AUTOLOAD";
     static STRLEN autolen = 8;
     GV* gv;
@@ -418,7 +412,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
        return Nullgv;
     cv = GvCV(gv);
 
-    if (!CvROOT(cv))
+    if (!(CvROOT(cv) || CvXSUB(cv)))
        return Nullgv;
 
     /*
@@ -430,6 +424,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
             HvNAME(stash), (int)len, name);
 
+#ifndef USE_THREADS
+    if (CvXSUB(cv)) {
+        /* rather than lookup/init $AUTOLOAD here
+         * only to have the XSUB do another lookup for $AUTOLOAD
+         * and split that value on the last '::',
+         * pass along the same data via some unused fields in the CV
+         */
+        CvSTASH(cv) = stash;
+        SvPVX(cv) = (char *)name; /* cast to loose constness warning */
+        SvCUR(cv) = len;
+        return gv;
+    }
+#endif
+
     /*
      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
      * The subroutine's original name may not be "AUTOLOAD", so we don't
@@ -525,7 +533,6 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 GV *
 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 {
-    dTHR;
     register const char *name = nambeg;
     register GV *gv = 0;
     GV**gvp;
@@ -840,7 +847,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case ',':
     case '\\':
     case '/':
-    case '|':
     case '\001':       /* $^A */
     case '\003':       /* $^C */
     case '\004':       /* $^D */
@@ -848,12 +854,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case '\006':       /* $^F */
     case '\010':       /* $^H */
     case '\011':       /* $^I, NOT \t in EBCDIC */
-    case '\017':       /* $^O */
     case '\020':       /* $^P */
     case '\024':       /* $^T */
        if (len > 1)
            break;
        goto magicalize;
+    case '|':
+       if (len > 1)
+           break;
+       sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+       goto magicalize;
+    case '\017':       /* $^O & $^OPEN */
+       if (len > 1 && strNE(name, "\017PEN"))
+           break;
+       goto magicalize;
     case '\023':       /* $^S */
        if (len > 1)
            break;
@@ -992,7 +1006,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 IO *
 Perl_newIO(pTHX)
 {
-    dTHR;
     IO *io;
     GV *iogv;
 
@@ -1011,7 +1024,6 @@ Perl_newIO(pTHX)
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
-    dTHR;
     register HE *entry;
     register I32 i;
     register GV *gv;
@@ -1088,7 +1100,6 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
-    dTHR;
     GP* gp;
 
     if (!gv || !(gp = GvGP(gv)))
@@ -1149,21 +1160,16 @@ register GV *gv;
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
-  dTHR;
   GV* gv;
   CV* cv;
   MAGIC* mg=mg_find((SV*)stash,'c');
   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
   STRLEN n_a;
-#ifdef OVERLOAD_VIA_HASH
-  GV** gvp;
-  HV* hv;
-#endif
 
   if (mg && amtp->was_ok_am == PL_amagic_generation
       && amtp->was_ok_sub == PL_sub_generation)
-      return AMT_AMAGIC(amtp);
+      return AMT_OVERLOADED(amtp);
   if (amtp && AMT_AMAGIC(amtp)) {      /* Have table. */
     int i;
     for (i=1; i<NofAMmeth; i++) {
@@ -1181,90 +1187,40 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   amt.fallback = AMGfallNO;
   amt.flags = 0;
 
-#ifdef OVERLOAD_VIA_HASH
-  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);        /* A shortcut */
-  if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
-    int filled=0;
-    int i;
-    char *cp;
-    SV* sv;
-    SV** svp;
-
-    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
-
-    if (( cp = (char *)PL_AMG_names[0] ) &&
-       (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
-      if (SvTRUE(sv)) amt.fallback=AMGfallYES;
-      else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
-    }
-    for (i = 1; i < NofAMmeth; i++) {
-      cv = 0;
-      cp = (char *)PL_AMG_names[i];
-
-        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
-        if (svp && ((sv = *svp) != &PL_sv_undef)) {
-          switch (SvTYPE(sv)) {
-            default:
-              if (!SvROK(sv)) {
-                if (!SvOK(sv)) break;
-               gv = gv_fetchmethod(stash, SvPV(sv, n_a));
-                if (gv) cv = GvCV(gv);
-                break;
-              }
-              cv = (CV*)SvRV(sv);
-              if (SvTYPE(cv) == SVt_PVCV)
-                  break;
-                /* FALL THROUGH */
-            case SVt_PVHV:
-            case SVt_PVAV:
-             Perl_croak(aTHX_ "Not a subroutine reference in overload table");
-             return FALSE;
-            case SVt_PVCV:
-              cv = (CV*)sv;
-              break;
-            case SVt_PVGV:
-              if (!(cv = GvCVu((GV*)sv)))
-                cv = sv_2cv(sv, &stash, &gv, FALSE);
-              break;
-          }
-          if (cv) filled=1;
-         else {
-           Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
-               cp,HvNAME(stash));
-           return FALSE;
-         }
-        }
-#else
   {
-    int filled = 0;
-    int i;
+    int filled = 0, have_ovl = 0;
+    int i, lim = 1;
     const char *cp;
     SV* sv = NULL;
 
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
-    if ((cp = PL_AMG_names[0])) {
-       /* Try to find via inheritance. */
-       gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
-       if (gv)
-           sv = GvSV(gv);
-
-       if (!gv)
-           goto no_table;
-       else if (SvTRUE(sv))
-           amt.fallback=AMGfallYES;
-       else if (SvOK(sv))
-           amt.fallback=AMGfallNEVER;
-    }
+    /* Try to find via inheritance. */
+    gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
+    if (gv)
+       sv = GvSV(gv);
+
+    if (!gv)
+       lim = DESTROY_amg;              /* Skip overloading entries. */
+    else if (SvTRUE(sv))
+       amt.fallback=AMGfallYES;
+    else if (SvOK(sv))
+       amt.fallback=AMGfallNEVER;
+
+    for (i = 1; i < lim; i++)
+       amt.table[i] = Nullcv;
+    for (; i < NofAMmeth; i++) {
+       char *cooky = (char*)PL_AMG_names[i];
+       /* Human-readable form, for debugging: */
+       char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+       STRLEN l = strlen(cooky);
 
-    for (i = 1; i < NofAMmeth; i++) {
-       SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
        DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
                     cp, HvNAME(stash)) );
        /* don't fill the cache while looking up! */
-       gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+       gv = gv_fetchmeth(stash, cooky, l, -1);
         cv = 0;
-        if(gv && (cv = GvCV(gv))) {
+        if (gv && (cv = GvCV(gv))) {
            if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
                && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
                /* GvSV contains the name of the method. */
@@ -1292,14 +1248,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
                         cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
                         GvNAME(CvGV(cv))) );
            filled = 1;
+           if (i < DESTROY_amg)
+               have_ovl = 1;
        }
-#endif
        amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
+      if (have_ovl)
+         AMT_OVERLOADED_on(&amt);
       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
-      return TRUE;
+      return have_ovl;
     }
   }
   /* Here we have no table: */
@@ -1309,10 +1268,35 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   return FALSE;
 }
 
+
+CV*
+Perl_gv_handler(pTHX_ HV *stash, I32 id)
+{
+    dTHR;
+    MAGIC *mg;
+    AMT *amtp;
+
+    if (!stash)
+        return Nullcv;
+    mg = mg_find((SV*)stash,'c');
+    if (!mg) {
+      do_update:
+       Gv_AMupdate(stash);
+       mg = mg_find((SV*)stash,'c');
+    }
+    amtp = (AMT*)mg->mg_ptr;
+    if ( amtp->was_ok_am != PL_amagic_generation
+        || amtp->was_ok_sub != PL_sub_generation )
+       goto do_update;
+    if (AMT_AMAGIC(amtp))
+       return amtp->table[id];
+    return Nullcv;
+}
+
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
-  dTHR;
   MAGIC *mg;
   CV *cv;
   CV **cvp=NULL, **ocvp=NULL;
@@ -1493,7 +1477,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
        if (off==-1) off=method;
        msg = sv_2mortal(Perl_newSVpvf(aTHX_
                      "Operation `%s': no method found,%sargument %s%s%s%s",
-                     PL_AMG_names[method + assignshift],
+                     AMG_id2name(method + assignshift),
                      (flags & AMGf_unary ? " " : "\n\tleft "),
                      SvAMAGIC(left)?
                        "in overloaded package ":
@@ -1522,11 +1506,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   if (!notfound) {
     DEBUG_o( Perl_deb(aTHX_
   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
-                PL_AMG_names[off],
+                AMG_id2name(off),
                 method+assignshift==off? "" :
                             " (initially `",
                 method+assignshift==off? "" :
-                            PL_AMG_names[method+assignshift],
+                            AMG_id2name(method+assignshift),
                 method+assignshift==off? "" : "')",
                 flags & AMGf_unary? "" :
                   lr==1 ? " for right argument": " for left argument",
@@ -1586,7 +1570,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     PUSHs(lr>0? left: right);
     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
     if (notfound) {
-      PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
+      PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
     }
     PUSHs((SV*)cv);
     PUTBACK;
@@ -1672,6 +1656,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
        if (len == 3 && strEQ(name, "SIG"))
            goto yes;
        break;
+    case '\017':   /* $^O & $^OPEN */
+       if (len == 1
+           || (len == 4 && strEQ(name, "\027PEN")))
+       {
+           goto yes;
+       }
+       break;
     case '\027':   /* $^W & $^WARNING_BITS */
        if (len == 1
            || (len == 12 && strEQ(name, "\027ARNING_BITS"))
@@ -1715,7 +1706,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
     case '\010':   /* $^H */
     case '\011':   /* $^I, NOT \t in EBCDIC */
     case '\014':   /* $^L */
-    case '\017':   /* $^O */
     case '\020':   /* $^P */
     case '\023':   /* $^S */
     case '\024':   /* $^T */
diff --git a/gv.h b/gv.h
index d2234a6..07a04b6 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -1,6 +1,6 @@
 /*    gv.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
diff --git a/handy.h b/handy.h
index f0e39af..9d7e096 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -1,6 +1,6 @@
 /*    handy.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -114,6 +114,10 @@ Null SV pointer.
 
 */
 
+#ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */
+#   include <inttypes.h>
+#endif
+
 typedef I8TYPE I8;
 typedef U8TYPE U8;
 typedef I16TYPE I16;
@@ -122,17 +126,28 @@ typedef I32TYPE I32;
 typedef U32TYPE U32;
 #ifdef PERL_CORE
 #   ifdef HAS_QUAD
-#       if QUADKIND == QUAD_IS_INT64_T
-#           include <sys/types.h>
-#           ifdef I_INTTYPES /* e.g. Linux has int64_t without <inttypes.h> */
-#               include <inttypes.h>
-#           endif
-#       endif
 typedef I64TYPE I64;
 typedef U64TYPE U64;
 #   endif
 #endif /* PERL_CORE */
 
+#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
+#   ifndef UINT64_C /* usually from <inttypes.h> */
+#       if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG
+#           define INT64_C(c)  CAT2(c,LL)
+#           define UINT64_C(c) CAT2(c,ULL)
+#       else
+#           if LONGSIZE == 8 && QUADKIND == QUAD_IS_LONG
+#               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))
+#           endif
+#       endif
+#   endif
+#endif
+
 /* Mention I8SIZE, U8SIZE, I16SIZE, U16SIZE, I32SIZE, U32SIZE,
    I64SIZE, and U64SIZE here so that metaconfig pulls them in. */
 
@@ -448,21 +463,21 @@ Converts the specified character to lowercase.
 #define isPSXSPC_utf8(c)       (isSPACE_utf8(c) ||(c) == '\f')
 #define isBLANK_utf8(c)                isBLANK(c) /* could be wrong */
 
-#define isALNUM_LC_utf8(p)     isALNUM_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isIDFIRST_LC_utf8(p)   isIDFIRST_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isALPHA_LC_utf8(p)     isALPHA_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isSPACE_LC_utf8(p)     isSPACE_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isDIGIT_LC_utf8(p)     isDIGIT_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isUPPER_LC_utf8(p)     isUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isLOWER_LC_utf8(p)     isLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isALNUMC_LC_utf8(p)    isALNUMC_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isCNTRL_LC_utf8(p)     isCNTRL_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isGRAPH_LC_utf8(p)     isGRAPH_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isPRINT_LC_utf8(p)     isPRINT_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define isPUNCT_LC_utf8(p)     isPUNCT_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define toUPPER_LC_utf8(p)     toUPPER_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define toTITLE_LC_utf8(p)     toTITLE_LC_uni(utf8_to_uv_chk(p, 0, 0))
-#define toLOWER_LC_utf8(p)     toLOWER_LC_uni(utf8_to_uv_chk(p, 0, 0))
+#define isALNUM_LC_utf8(p)     isALNUM_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isIDFIRST_LC_utf8(p)   isIDFIRST_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isALPHA_LC_utf8(p)     isALPHA_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isSPACE_LC_utf8(p)     isSPACE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isDIGIT_LC_utf8(p)     isDIGIT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isUPPER_LC_utf8(p)     isUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isLOWER_LC_utf8(p)     isLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isALNUMC_LC_utf8(p)    isALNUMC_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isCNTRL_LC_utf8(p)     isCNTRL_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isGRAPH_LC_utf8(p)     isGRAPH_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isPRINT_LC_utf8(p)     isPRINT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define isPUNCT_LC_utf8(p)     isPUNCT_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toUPPER_LC_utf8(p)     toUPPER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toTITLE_LC_utf8(p)     toTITLE_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
+#define toLOWER_LC_utf8(p)     toLOWER_LC_uni(utf8_to_uv(p, UTF8_MAXLEN, 0, 0))
 
 #define isPSXSPC_LC_utf8(c)    (isSPACE_LC_utf8(c) ||(c) == '\f')
 #define isBLANK_LC_utf8(c)     isBLANK(c) /* could be wrong */
@@ -606,3 +621,14 @@ extern long lastxycount[MAXXCOUNT][MAXYCOUNT];
 #else
 #define StructCopy(s,d,t) Copy(s,d,1,t)
 #endif
+
+#ifdef NEED_VA_COPY
+# ifdef va_copy
+#  define Perl_va_copy(s, d) va_copy(d, s)
+# elif defined(__va_copy)
+#  define Perl_va_copy(s, d) __va_copy(d, s)
+# else
+#  define Perl_va_copy(s, d) Copy(s, d, 1, va_list)
+# endif
+#endif
+
index cf7e43c..b14aad0 100644 (file)
@@ -130,6 +130,13 @@ case "$cc" in
 *gcc*) ccdlflags='-Xlinker' ;;
 *) ccversion=`lslpp -L | grep 'C for AIX Compiler$' | awk '{print $2}'`
    case "$ccversion" in
+     '') ccversion=`lslpp -L | grep 'IBM C and C++ Compilers LUM$' | awk '{print $2}'`
+       ;;
+     esac
+   case "$ccversion" in
+     3.6.6.0)
+       optimize='none'
+       ;;
      4.4.0.0|4.4.0.1|4.4.0.2)
        echo >&4 "*** This C compiler ($ccversion) is outdated."
        echo >&4 "*** Please upgrade to at least 4.4.0.3."
@@ -156,6 +163,20 @@ case "$osvers" in
     lddlflags="$lddlflags -bhalt:4 -bM:SRE -bI:\$(PERL_INC)/perl.exp -bE:\$(BASEEXT).exp -b noentry -lc"
     ;;
 esac
+# AIX 4.2 (using latest patchlevels on 20001130) has a broken bind
+# library (getprotobyname and getprotobynumber are outversioned by
+# the same calls in libc, at least for xlc version 3...
+case "`oslevel`" in
+    4.2.1.*)  # Test for xlc version too, should we?
+      case "$ccversion" in    # Don't know if needed for gcc
+          3.1.4.*)    # libswanted "bind ... c ..." => "... c bind ..."
+              set `echo X "$libswanted "| sed -e 's/ bind\( .*\) \([cC]\) / \1 \2 bind /'`
+              shift
+              libswanted="$*"
+              ;;
+          esac
+      ;;
+    esac
 
 # This script UU/usethreads.cbu will get 'called-back' by Configure 
 # after it has prompted the user for whether to use threads.
index 7be1735..c57d3f6 100644 (file)
@@ -25,6 +25,7 @@ libswanted=`echo " $libswanted " | sed -e 's/ c / /g'`
 libswanted=`echo " $libswanted " | sed -e 's/ m / /g'`
 libswanted="$libswanted cygipc"
 test -z "$optimize" && optimize='-O2'
+ccflags="$ccflags -DPERL_USE_SAFE_PUTENV"
 # - otherwise i686-cygwin
 archname='cygwin'
 
index 07b80ea..ce3a40c 100644 (file)
@@ -70,12 +70,13 @@ case "`$cc -v 2>&1 | grep cc`" in
        if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then
            cat >&4 <<EOF
 
-*** Your cc seems to be gcc and its version seems to be less than 2.95.2.
-*** This is not a good idea since old versions of gcc are known to produce
-*** buggy code when compiling Perl (and no doubt for other programs, too).
+*** Your cc seems to be gcc and its version ($_gcc_version) seems to be
+*** less than 2.95.2.  This is not a good idea since old versions of gcc
+*** are known to produce buggy code when compiling Perl (and no doubt for
+*** other programs, too).
 ***
-*** Therefore, I strongly suggest upgrading your gcc.  (Why don't you
-*** use the vendor cc is also a good question.  It comes with the operating
+*** Therefore, I strongly suggest upgrading your gcc.  (Why don't you use
+*** the vendor cc is also a good question.  It comes with the operating
 *** system and produces good code.)
 
 Cannot continue, aborting.
@@ -88,10 +89,10 @@ EOF
 
 *** Note that as of gcc 2.95.2 (19991024) and Perl 5.6.0 (March 2000)
 *** if the said Perl is compiled with the said gcc the lib/sdbm test
-*** dumps core (meaning  that the SDBM_File is unusable).  As this core
-*** dump doesn't happen with the vendor cc, this is most probably
-*** a lingering bug in gcc.  Therefore unless you have a better gcc
-*** you are still better off using the vendor cc.
+*** may dump core (meaning that the SDBM_File extension is unusable).
+*** As this core dump never happens with the vendor cc, this is most
+*** probably a lingering bug in gcc.  Therefore unless you have a better
+*** gcc installation you are still better off using the vendor cc.
 
 Since you explicitly chose gcc, I assume that you know what are doing.
 
index d50bca4..ebbd786 100644 (file)
@@ -41,10 +41,13 @@ startperl='#!perl'
 case "X$optimize" in
   X)
        optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2"
+       ldflags='-s'
+       ;;
+  X*)
+       ldflags=' '
        ;;
 esac
 ccflags="$ccflags -DPERL_EXTERNAL_GLOB"
-ldflags='-s'
 usemymalloc='n'
 timetype='time_t'
 
index 0ba6b61..cc48351 100644 (file)
@@ -86,13 +86,6 @@ case "$osvers" in
        d_setegid='undef'
        d_seteuid='undef'
        ;;
-3.*)
-       usevfork='true'         
-       usemymalloc='n'
-       libswanted=`echo $libswanted | sed 's/ malloc / /'`     
-       ;;
-#
-# Guesses at what will be needed after 3.*
 *)     usevfork='true'
        usemymalloc='n'
        libswanted=`echo $libswanted | sed 's/ malloc / /'`
index 43d72bc..ca5c50b 100644 (file)
@@ -179,6 +179,7 @@ EOM
     ccflags="$ccflags +DD64"
     ldflags="$ldflags +DD64"
     test -d /lib/pa20_64 && loclibpth="$loclibpth /lib/pa20_64"
+    libswanted="$libswanted pthread"
     libscheck='case "`/usr/bin/file $xxx`" in
 *LP64*|*PA-RISC2.0*) ;;
 *) xxx=/no/64-bit$xxx ;;
index 913cfd0..a6b2bd9 100644 (file)
@@ -189,7 +189,7 @@ fi
 
 rm -f try.c a.out
 
-if /bin/bash -c exit; then
+if /bin/sh -c exit; then
   echo ''
   echo 'You appear to have a working bash.  Good.'
 else
index 69f1635..3a311a1 100644 (file)
@@ -15,6 +15,9 @@
 #      Martijn Koster <m.koster@webcrawler.com>
 #      Richard Yeh <rcyeh@cco.caltech.edu>
 #
+# Deny system's false claims to support mmap() and munmap(); note
+# also that Sys V IPC (re)disabled by jhi due to continuing inadequacy
+#                      -- Dominic Dunlop <domo@computer.org> 001111
 # Remove dynamic loading libraries from search; enable SysV IPC with
 # MachTen 4.1.4 and above; define SYSTEM_ALIGN_BYTES for old MT versions
 #                      -- Dominic Dunlop <domo@computer.org> 000224
@@ -197,6 +200,11 @@ if test "$d_shm" = ""; then
     esac
 fi
 
+# MachTen has stubs for mmap and munmap(), but they just result in the
+# caller being killed on the grounds of "Bad system call"
+d_mmap=${d_mmap:-undef}
+d_munmap=${d_munmap:-undef}
+
 # Get rid of some extra libs which it takes Configure a tediously
 # long time never to find on MachTen, or which break perl
 set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \
@@ -228,6 +236,8 @@ During Configure, you may see the message
 as well as similar messages concerning \$d_sem and \$d_shm.  Select the
 default answers: MachTen 4.1 appears to provide System V IPC support,
 but it is incomplete and buggy: perl should be built without it.
+Similar considerations apply to memory mapping of files, controlled
+by \$d_mmap and \$d_munmap.
 
 Similarly, when you see
 
index f93c312..aec05ee 100644 (file)
@@ -9,7 +9,7 @@ case "$cc" in
                 lddlflags='-shared'
                 ldflags=''
                ;;
-        '')
+        *)
                 cc="cc -Xa -Olimit 4096"
                 malloctype="void *"
                ;;
index 5b79709..2e7a433 100644 (file)
@@ -43,7 +43,7 @@ OpenBSD.alpha|OpenBSD.mips|OpenBSD.powerpc|OpenBSD.vax)
                ;;
        *) # from 2.8 onwards
                ld=${cc:-cc}
-               lddlflags="-shared $lddlflags"
+               lddlflags="-shared -fPIC $lddlflags"
                ;;
        esac
        ;;
@@ -95,6 +95,9 @@ case "$openbsd_distribution" in
        sysman='/usr/share/man/man1'
        libpth='/usr/lib'
        glibpth='/usr/lib'
+       # Local things, however, do go in /usr/local
+       siteprefix='/usr/local'
+       siteprefixexp='/usr/local'
        # Ports installs non-std libs in /usr/local/lib so look there too
        locincpth='/usr/local/include'
        loclibpth='/usr/local/lib'
index e8175f2..0bf5bab 100644 (file)
@@ -1,35 +1,48 @@
 # hints/solaris_2.sh
-# Last modified:  Tue Apr 13 13:12:49 EDT 1999
+# Last modified: Tue Jan  2 10:16:35 2001
+# Lupe Christoph <lupe@lupe-christoph.de>
+# Based on version by:
 # Andy Dougherty  <doughera@lafayette.edu>
-# Based on input from lots of folks, especially
+# Which was based on input from lots of folks, especially
 # Dean Roehrich <roehrich@ironwood-fddi.cray.com>
+# Additional input from Alan Burlison, Jarkko Hietaniemi,
+# and Richard Soderberg.
+#
+# See README.solaris for additional information.
+#
+# For consistency with gcc, we do not adopt Sun Marketing's
+# removal of the '2.' prefix from the Solaris version number.
+# (Configure tries to detect an old fixincludes and needs
+# this information.)
 
 # If perl fails tests that involve dynamic loading of extensions, and
 # you are using gcc, be sure that you are NOT using GNU as and ld.  One
 # way to do that is to invoke Configure with
-# 
+#
 #     sh Configure -Dcc='gcc -B/usr/ccs/bin/'
 #
 #  (Note that the trailing slash is *required*.)
 #  gcc will occasionally emit warnings about "unused prefix", but
 #  these ought to be harmless.  See below for more details.
+
 # See man vfork.
 usevfork=false
 
 d_suidsafe=define
 
 # Avoid all libraries in /usr/ucblib.
-set `echo $glibpth | sed -e 's@/usr/ucblib@@'`
+# /lib is just a symlink to /usr/lib
+set `echo $glibpth | sed -e 's@/usr/ucblib@@' -e 's@ /lib @ @'`
 glibpth="$*"
 
-# Remove bad libraries.  -lucb contains incompatible routines.
-# -lld doesn't do anything useful.
+# Remove unwanted libraries.  -lucb contains incompatible routines.
+# -lld and -lsec don't do anything useful. -lcrypt does not
+# really provide anything we need over -lc, so we drop it, too.
 # -lmalloc can cause a problem with GNU CC & Solaris.  Specifically,
 # libmalloc.a may allocate memory that is only 4 byte aligned, but
 # GNU CC on the Sparc assumes that doubles are 8 byte aligned.
 # Thanks to  Hallvard B. Furuseth <h.b.furuseth@usit.uio.no>
-set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ malloc @ @' -e 's@ ucb @ @'`
+set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ malloc @ @' -e 's@ ucb @ @' -e 's@ sec @ @' -e 's@ crypt @ @'`
 libswanted="$*"
 
 # Look for architecture name.  We want to suggest a useful default.
@@ -45,47 +58,35 @@ case "$archname" in
     ;;
 esac
 
-cc=${cc:-cc}
-
-ccversion="`$cc -V 2>&1|head -1|sed 's/^cc: //'`"
-case "$ccversion" in
-*WorkShop*) ccname=workshop ;;
-*) ccversion='' ;;
-esac
-
-cat >UU/workshoplibpth.cbu<<'EOCBU'
+cat > UU/workshoplibpth.cbu << 'EOCBU'
+# This script UU/workshoplibpth.cbu will get 'called-back'
+# by other CBUs this script creates.
 case "$workshoplibpth_done" in
-'')    case "$use64bitall" in
-       "$define"|true|[yY]*)
-            loclibpth="$loclibpth /usr/lib/sparcv9"
-            if test -n "$workshoplibs"; then
-                loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" `
-                for lib in $workshoplibs; do
-                    # Logically, it should be sparcv9.
-                    # But the reality fights back, it's v9.
-                    loclibpth="$loclibpth $lib/sparcv9 $lib/v9"
-                done
-            fi 
+    '')        if test `uname -p` = "sparc"; then
+       case "$use64bitall" in
+           "$define"|true|[yY]*)
+               # add SPARC-specific 64 bit libraries
+               loclibpth="$loclibpth /usr/lib/sparcv9"
+               if test -n "$workshoplibs"; then
+                   loclibpth=`echo $loclibpth | sed -e "s% $workshoplibs%%" `
+                   for lib in $workshoplibs; do
+                       # Logically, it should be sparcv9.
+                       # But the reality fights back, it's v9.
+                       loclibpth="$loclibpth $lib/sparcv9 $lib/v9"
+                   done
+               fi
            ;;
-       *)  loclibpth="$loclibpth $workshoplibs"  
+       *)  loclibpth="$loclibpth $workshoplibs"
            ;;
        esac
+       else
+           loclibpth="$loclibpth $workshoplibs"
+       fi
        workshoplibpth_done="$define"
        ;;
 esac
 EOCBU
 
-case "$ccname" in
-workshop)
-       cat >try.c <<EOF
-#include <sunmath.h>
-int main() { return(0); }
-EOF
-       workshoplibs=`cc -### try.c -lsunmath -o try 2>&1|grep " -Y "|sed 's%.* -Y "P,\(.*\)".*%\1%'|tr ':' '\n'|grep '/SUNWspro/'`
-       . ./UU/workshoplibpth.cbu
-       ;;
-esac
-
 ######################################################
 # General sanity testing.  See below for excerpts from the Solaris FAQ.
 #
@@ -95,12 +96,12 @@ esac
 # To: perl5-porters@africa.nicoh.com
 # Subject: Re: On perl5/solaris/gcc
 #
-# Here's another draft of the perl5/solaris/gcc sanity-checker. 
+# Here's another draft of the perl5/solaris/gcc sanity-checker.
 
 case `type ${cc:-cc}` in
 */usr/ucb/cc*) cat <<END >&4
 
-NOTE:  Some people have reported problems with /usr/ucb/cc.  
+NOTE:  Some people have reported problems with /usr/ucb/cc.
 If you have difficulties, please make sure the directory
 containing your C compiler is before /usr/ucb in your PATH.
 
@@ -158,7 +159,7 @@ if grep GNU make.vers > /dev/null 2>&1; then
     case "`/usr/bin/ls -lL $tmp`" in
     ??????s*)
            cat <<END >&2
-       
+
 NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id
 bit set.  You must either rearrange your PATH to put /usr/ccs/bin before the
 GNU utilities or you must ask your system administrator to disable the
@@ -170,31 +171,33 @@ END
 fi
 rm -f make.vers
 
-# XXX EXPERIMENTAL  A.D.  2/27/1998
-# XXX This script UU/cc.cbu will get 'called-back' by Configure after it
-# XXX has prompted the user for the C compiler to use.
-cat > UU/cc.cbu <<'EOSH'
+cat > UU/cc.cbu <<'EOCBU'
+# This script UU/cc.cbu will get 'called-back' by Configure after it
+# has prompted the user for the C compiler to use.
+
 # If the C compiler is gcc:
 #   - check the fixed-includes
 #   - check as(1) and ld(1), they should not be GNU
 #      (GNU as and ld 2.8.1 and later are reportedly ok, however.)
 # If the C compiler is not gcc:
+#   - Check if it is the Workshop/Forte compiler.
+#     If it is, prepare for 64 bit and long doubles.
 #   - check as(1) and ld(1), they should not be GNU
 #      (GNU as and ld 2.8.1 and later are reportedly ok, however.)
 #
 # Watch out in case they have not set $cc.
 
-# Perl compiled with some combinations of GNU as and ld may not 
+# Perl compiled with some combinations of GNU as and ld may not
 # be able to perform dynamic loading of extensions.  If you have a
 # problem with dynamic loading, be sure that you are using the Solaris
 # /usr/ccs/bin/as and /usr/ccs/bin/ld.  You can do that with
 #              sh Configure -Dcc='gcc -B/usr/ccs/bin/'
-# (note the trailing slash is required). 
+# (note the trailing slash is required).
 # Combinations that are known to work with the following hints:
 #
 #  gcc-2.7.2, GNU as 2.7, GNU ld 2.7
 #  egcs-1.0.3, GNU as 2.9.1 and GNU ld 2.9.1
-#      --Andy Dougherty  <doughera@lafayette.edu>  
+#      --Andy Dougherty  <doughera@lafayette.edu>
 #      Tue Apr 13 17:19:43 EDT 1999
 
 # Get gcc to share its secrets.
@@ -207,12 +210,6 @@ if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then
        # Using gcc.
        #
 
-       tmp=`echo "$verbose" | grep '^Reading' |
-               awk '{print $NF}'  | sed 's/specs$/include/'`
-
-       # Determine if the fixed-includes look like they'll work.
-       # Doesn't work anymore for gcc-2.7.2.
-
        # See if as(1) is GNU as(1).  GNU as(1) might not work for this job.
        if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then
            :
@@ -277,6 +274,23 @@ else
        # Not using gcc.
        #
 
+       ccversion="`${cc:-cc} -V 2>&1|sed -n -e '1s/^cc: //p'`"
+       case "$ccversion" in
+       *WorkShop*) ccname=workshop ;;
+       *) ccversion='' ;;
+       esac
+
+       case "$ccname" in
+       workshop)
+               cat >try.c <<EOM
+#include <sunmath.h>
+int main() { return(0); }
+EOM
+               workshoplibs=`cc -### try.c -lsunmath -o try 2>&1|sed -n '/ -Y /s%.* -Y "P,\(.*\)".*%\1%p'|tr ':' '\n'|grep '/SUNWspro/'`
+               . ./workshoplibpth.cbu
+       ;;
+       esac
+
        # See if as(1) is GNU as(1).  GNU might not work for this job.
        case `as --version < /dev/null 2>&1` in
        *GNU*)
@@ -293,22 +307,12 @@ END
        # See if ld(1) is GNU ld(1).  GNU ld(1) might not work for this job.
        # ld --version doesn't properly report itself as a GNU tool,
        # as of ld version 2.6, so we need to be more strict. TWP 9/5/96
-       gnu_ld=false
-       case `ld --version < /dev/null 2>&1` in
-       *GNU*|ld\ version\ 2*)
-               gnu_ld=true ;;
-       *) ;;
-       esac
-       if $gnu_ld ; then :
+       # Sun's ld always emits the "Software Generation Utilities" string.
+       if ld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then
+           # Ok, ld is /usr/ccs/bin/ld.
+           :
        else
-               # Try to guess from path
-               case `type ld | awk '{print $NF}'` in
-               *gnu*|*GNU*|*FSF*)
-                       gnu_ld=true ;;
-               esac
-       fi
-       if $gnu_ld ; then
-               cat <<END >&2
+           cat <<END >&2
 
 NOTE: You are apparently using GNU ld(1).  GNU ld(1) might not build Perl.
 You should arrange to use /usr/ccs/bin/ld, perhaps by adding /usr/ccs/bin
@@ -324,16 +328,16 @@ rm -f try try.c
 rm -f core
 
 # XXX
-EOSH
+EOCBU
 
 cat > UU/usethreads.cbu <<'EOCBU'
-# This script UU/usethreads.cbu will get 'called-back' by Configure 
+# This script UU/usethreads.cbu will get 'called-back' by Configure
 # after it has prompted the user for whether to use threads.
 case "$usethreads" in
 $define|true|[yY]*)
         ccflags="-D_REENTRANT $ccflags"
 
-        # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 7
+        # sched_yield is in -lposix4 up to Solaris 2.6, in -lrt starting with Solaris 2.7
        case `uname -r` in
        5.[0-6] | 5.5.1) sched_yield_lib="posix4" ;;
        *) sched_yield_lib="rt";
@@ -352,12 +356,12 @@ $define|true|[yY]*)
         cat >try.c <<'EOM'
        /* Test for sig(set|long)jmp bug. */
        #include <setjmp.h>
-        
+
        main()
        {
            sigjmp_buf env;
            int ret;
-       
+
            ret = sigsetjmp(env, 1);
            if (ret) { return ret == 2; }
            siglongjmp(env, 2);
@@ -379,7 +383,7 @@ esac
 EOCBU
 
 cat > UU/uselargefiles.cbu <<'EOCBU'
-# This script UU/uselargefiles.cbu will get 'called-back' by Configure 
+# This script UU/uselargefiles.cbu will get 'called-back' by Configure
 # after it has prompted the user for whether to use large files.
 case "$uselargefiles" in
 ''|$define|true|[yY]*)
@@ -399,21 +403,40 @@ EOCBU
 # This is truly a mess.
 case "$usemorebits" in
 "$define"|true|[yY]*)
-       use64bitint="$define"    
-       uselongdouble="$define"    
+       use64bitint="$define"
+       uselongdouble="$define"
        ;;
 esac
 
-cat > UU/use64bitall.cbu <<'EOCBU'
-# This script UU/use64bitall.cbu will get 'called-back' by Configure 
+if test `uname -p` = "sparc"; then
+    cat > UU/use64bitint.cbu <<'EOCBU'
+# This script UU/use64bitint.cbu will get 'called-back' by Configure
+# after it has prompted the user for whether to use 64 bit integers.
+case "$use64bitint" in
+"$define"|true|[yY]*)
+           case "`uname -r`" in
+           5.[0-4])
+               cat >&4 <<EOM
+Solaris `uname -r|sed -e 's/^5\./2./'` does not support 64-bit integers.
+You should upgrade to at least Solaris 2.5.
+EOM
+               exit 1
+               ;;
+           esac
+           ;;
+esac
+EOCBU
+
+    cat > UU/use64bitall.cbu <<'EOCBU'
+# This script UU/use64bitall.cbu will get 'called-back' by Configure
 # after it has prompted the user for whether to be maximally 64 bitty.
 case "$use64bitall-$use64bitall_done" in
 "$define-"|true-|[yY]*-)
            case "`uname -r`" in
-           5.[1-6])
+           5.[0-6])
                cat >&4 <<EOM
-Solaris `uname -r|sed -e 's/^5\.\([789]\)$/\1/'` does not support 64-bit pointers.
-You should upgrade to at least Solaris 7.
+Solaris `uname -r|sed -e 's/^5\./2./'` does not support 64-bit pointers.
+You should upgrade to at least Solaris 2.7.
 EOM
                exit 1
                ;;
@@ -423,13 +446,12 @@ EOM
                cat >&4 <<EOM
 
 I do not see the 64-bit libc, $libc.
-(You are either in an old sparc or in an x86.)
 Cannot continue, aborting.
 
 EOM
                exit 1
-           fi 
-           . ./UU/workshoplibpth.cbu
+           fi
+           . ./workshoplibpth.cbu
            case "$cc -v 2>/dev/null" in
            *gcc*)
                echo 'main() { return 0; }' > try.c
@@ -437,13 +459,16 @@ EOM
                *"m64 is not supported"*)
                    cat >&4 <<EOM
 
-Full 64-bit build not supported by this gcc configuration.
+Full 64-bit build is not supported by this gcc configuration.
+Check http://gcc.gnu.org/ for the latest news of availability
+of gcc for 64-bit Sparc.
+
 Cannot continue, aborting.
 
 EOM
                    exit 1
                    ;;
-               esac    
+               esac
                ccflags="$ccflags -mcpu=v9 -m64"
                if test X`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null` != X; then
                    ccflags="$ccflags -Wa,`getconf XBS5_LP64_OFF64_CFLAGS 2>/dev/null`"
@@ -460,234 +485,47 @@ EOM
                ldflags="$ldflags `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`"
                lddlflags="$lddlflags -G `getconf XBS5_LP64_OFF64_LDFLAGS 2>/dev/null`"
                ;;
-           esac        
+           esac
            libscheck='case "`/usr/bin/file $xxx`" in
 *64-bit*|*SPARCV9*) ;;
 *) xxx=/no/64-bit$xxx ;;
 esac'
+
            use64bitall_done=yes
            ;;
 esac
 EOCBU
-# Actually, we want to run this already now, if so requested,
-# because we need to fix up things right now.
-case "$use64bitall" in
-"$define"|true|[yY]*)
-       . ./UU/use64bitall.cbu
+
+    # Actually, we want to run this already now, if so requested,
+    # because we need to fix up things right now.
+    case "$use64bitall" in
+    "$define"|true|[yY]*)
+       # CBUs expect to be run in UU
+       cd UU; . ./use64bitall.cbu; cd ..
        ;;
-esac
+    esac
+fi
 
 cat > UU/uselongdouble.cbu <<'EOCBU'
-# This script UU/uselongdouble.cbu will get 'called-back' by Configure 
+# This script UU/uselongdouble.cbu will get 'called-back' by Configure
 # after it has prompted the user for whether to use long doubles.
-case "$uselongdouble-$uselongdouble_done" in
-"$define-"|true-|[yY]*-)
-       case "$ccname" in
-       workshop)
-               libswanted="$libswanted sunmath"
-               loclibpth="$loclibpth /opt/SUNWspro/lib"
-               ;;
-       *)      cat >&4 <<EOM
+case "$uselongdouble" in
+"$define"|true|[yY]*)
+       if test -f /opt/SUNWspro/lib/libsunmath.so; then
+               libs="$libs -lsunmath"
+               ldflags="$ldflags -L/opt/SUNWspro/lib -R/opt/SUNWspro/lib"
+               d_sqrtl=define
+       else
+               cat >&4 <<EOM
 
-The Sun Workshop compiler is not being used; therefore I do not see
-the libsunmath; therefore I do not know how to do long doubles, sorry.
-I'm disabling the use of long doubles.
+The Sun Workshop math library is not installed; therefore I do not
+know how to do long doubles, sorry.  I'm disabling the use of long
+doubles.
 EOM
                uselongdouble="$undef"
-               ;;
-       esac
-       uselongdouble_done=yes
+       fi
        ;;
 esac
 EOCBU
 
-# Actually, we want to run this already now, if so requested,
-# because we need to fix up things right now.
-case "$uselongdouble" in
-"$define"|true|[yY]*)
-       . ./UU/uselongdouble.cbu
-       ;;
-esac
-
-rm -f try.c try.o try
-
-# This is just a trick to include some useful notes.
-cat > /dev/null <<'End_of_Solaris_Notes'
-
-Here are some notes kindly contributed by Dean Roehrich.
-
------
-Generic notes about building Perl5 on Solaris:
-- Use /usr/ccs/bin/make.
-- If you use GNU make, remove its setgid bit.
-- Remove all instances of *ucb* from your path.
-- Make sure libucb is not in /usr/lib (it should be in /usr/ucblib).
-- Do not use GNU as or GNU ld, or any of GNU binutils or GNU libc.
-- Do not use /usr/ucb/cc.
-- Do not change Configure's default answers, except for the path names.
-- Do not use -lmalloc.
-- Do not build on SunOS 4 and expect it to work properly on SunOS 5.
-- /dev/fd must be mounted if you want set-uid scripts to work.
-
-
-Here are the gcc-related questions and answers from the Solaris 2 FAQ.  Note
-the themes:
-       - run fixincludes
-       - run fixincludes correctly
-       - don't use GNU as or GNU ld
-
-Question 5.7 covers the __builtin_va_alist problem people are always seeing.
-Question 6.1.3 covers the GNU as and GNU ld issues which are always biting
-people.
-Question 6.9 is for those who are still trying to compile Perl4.
-
-The latest Solaris 2 FAQ can be found in the following locations:
-       rtfm.mit.edu:/pub/usenet-by-group/comp.sys.sun.admin
-       ftp.fwi.uva.nl:/pub/solaris
-
-Perl5 comes with a script in the top-level directory called "myconfig" which
-will print a summary of the configuration in your config.sh.  My summary for
-Solaris 2.4 and gcc 2.6.3 follows.  I have also built with gcc 2.7.0 and the
-results are identical.  This configuration was generated with Configure's -d
-option (take all defaults, don't bother prompting me).  All tests pass for
-Perl5.001, patch.1m.
-
-Summary of my perl5 (patchlevel 1) configuration:
-  Platform:
-    osname=solaris, osver=2.4, archname=sun4-solaris
-    uname='sunos poplar 5.4 generic_101945-27 sun4d sparc '
-    hint=recommended
-  Compiler:
-    cc='gcc', optimize='-O', ld='gcc'
-    cppflags=''
-    ccflags =''
-    ldflags =''
-    stdchar='unsigned char', d_stdstdio=define, usevfork=false
-    voidflags=15, castflags=0, d_casti32=define, d_castneg=define
-    intsize=4, alignbytes=8, usemymalloc=y, randbits=15
-  Libraries:
-    so=so
-    libpth=/lib /usr/lib /usr/ccs/lib /usr/local/lib
-    libs=-lsocket -lnsl -ldl -lm -lc -lcrypt
-    libc=/usr/lib/libc.so
-  Dynamic Linking:
-    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef
-    cccdlflags='-fpic', ccdlflags=' ', lddlflags='-G'
-
-
-Dean
-roehrich@cray.com
-9/7/95
-
------------
-
-From: Casper.Dik@Holland.Sun.COM (Casper H.S. Dik - Network Security Engineer)
-Subject: Solaris 2 Frequently Asked Questions (FAQ) 1.48
-Date: 25 Jul 1995 12:20:18 GMT
-
-5.7) Why do I get __builtin_va_alist or __builtin_va_arg_incr undefined?
-
-    You're using gcc without properly installing the gcc fixed
-    include files.  Or you ran fixincludes after installing gcc
-    w/o moving the gcc supplied varargs.h and stdarg.h files
-    out of the way and moving them back again later.  This often
-    happens when people install gcc from a binary distribution.
-    If there's a tmp directory in gcc's include directory, fixincludes
-    didn't complete.  You should have run "just-fixinc" instead.
-
-    Another possible cause is using ``gcc -I/usr/include.''
-
-6.1) Where is the C compiler or where can I get one?
-
-    [...]
-
-    3) Gcc.
-
-    Gcc is available from the GNU archives in source and binary
-    form.  Look in a directory called sparc-sun-solaris2 for
-    binaries.  You need gcc 2.3.3 or later.  You should not use
-    GNU as or GNU ld.  Make sure you run just-fixinc if you use
-    a binary distribution.  Better is to get a binary version and
-    use that to bootstrap gcc from source.
-
-    [...]
-
-    When you install gcc, don't make the mistake of installing
-    GNU binutils or GNU libc, they are not as capable as their
-    counterparts you get with Solaris 2.x.
-
-6.9) I can't get perl 4.036 to compile or run.
-
-    Run Configure, and use the solaris_2_0 hints, *don't* use
-    the solaris_2_1 hints and don't use the config.sh you may
-    already have.  First you must make sure Configure and make
-    don't find /usr/ucb/cc.  (It must use gcc or the native C
-    compiler: /opt/SUNWspro/bin/cc)
-
-    Some questions need a special answer.
-
-    Are your system (especially dbm) libraries compiled with gcc? [y] y
-
-    yes: gcc 2.3.3 or later uses the standard calling
-    conventions, same as Sun's C.
-
-    Any additional cc flags? [ -traditional -Dvolatile=__volatile__
-    -I/usr/ucbinclude] -traditional -Dvolatile=__volatile__
-    Remove /usr/ucbinclude.
-
-    Any additional libraries? [-lsocket -lnsl -ldbm -lmalloc -lm
-    -lucb] -lsocket -lnsl  -lm
-
-    Don't include -ldbm, -lmalloc and -lucb.
-
-    Perl 5 compiled out of the box.
-
-7.0) 64-bitness, from Alan Burlison (added by jhi 2000-02-21)
-
-  You need a machine running Solaris 2.7 or above.
-
-  Here's some rules:
-  
-  1. Solaris 2.7 and above will run in either 32 bit or 64 bit mode,
-     via a reboot.
-  2. You can build 64 bit apps whilst running 32 bit mode and vice-versa.
-  3. 32 bit apps will run under Solaris running in either 32 or 64 bit mode.
-  4. 64 bit apps require Solaris to be running 64 bit mode
-  5. It is possible to select the appropriate 32 or 64 bit version of an
-     app at run-time using isaexec(3).
-  6. You can detect the OS mode using "isainfo -v", e.g.
-      fubar$ isainfo -v   # Ultra 30 in 64 bit mode
-      64-bit sparcv9 applications
-      32-bit sparc applications
-  7. To compile 64 bit you need to use the flag "-xarch=v9".
-     getconf(1) will tell you this, e.g.
-      fubar$ getconf -a | grep v9
-      XBS5_LP64_OFF64_CFLAGS:         -xarch=v9
-      XBS5_LP64_OFF64_LDFLAGS:        -xarch=v9
-      XBS5_LP64_OFF64_LINTFLAGS:      -xarch=v9
-      XBS5_LPBIG_OFFBIG_CFLAGS:       -xarch=v9
-      XBS5_LPBIG_OFFBIG_LDFLAGS:      -xarch=v9
-      XBS5_LPBIG_OFFBIG_LINTFLAGS:    -xarch=v9
-      _XBS5_LP64_OFF64_CFLAGS:        -xarch=v9
-      _XBS5_LP64_OFF64_LDFLAGS:       -xarch=v9
-      _XBS5_LP64_OFF64_LINTFLAGS:     -xarch=v9
-      _XBS5_LPBIG_OFFBIG_CFLAGS:      -xarch=v9
-      _XBS5_LPBIG_OFFBIG_LDFLAGS:     -xarch=v9
-      _XBS5_LPBIG_OFFBIG_LINTFLAGS:   -xarch=v9
-
-  > > Now, what should we do, then?  Should -Duse64bits in a v9 box cause
-  > > Perl to compiled in v9 mode?  Or should we for compatibility stick
-  > > with 32 bit builds and let the people in the know to add the -xarch=v9
-  > > to ccflags (and ldflags?)?
-
-  > I think the second (explicit) mechanism should be the default.  Unless
-  > you want to allocate more than ~ 4Gb of memory inside Perl, you don't
-  > need Perl to be a 64-bit app.  Put it this way, on a machine running
-  > Solaris 8, there are 463 executables under /usr/bin, but only 15 of
-  > those require 64 bit versions - mainly because they invade the kernel
-  > address space, e.g. adb, kgmon etc.  Certainly we don't recommend users
-  > to build 64 bit apps unless they need the address space.
-
-End_of_Solaris_Notes
-
+rm -f try.c try.o try a.out
index 8109b39..69af6fd 100644 (file)
@@ -135,6 +135,22 @@ case "`uname -sm`" in
     ;;
 esac
 
+# NCR MP-RAS.  Thanks to Doug Hendricks for this info.
+# The output of uname -a looks like this
+#      foo foo 4.0 3.0 3441 Pentium III(TM)-ISA/PCI
+# Configure sets osname=svr4.0, osvers=3.0, archname='3441-svr4.0'
+case "$myuname" in
+*3441*)
+    # With the NCR High Performance C Compiler R3.0c, miniperl fails 
+    # t/op/regexp.t test 461 unless we compile with optimizie=-g.
+    # The whole O/S is being phased out, so more detailed probing
+    # is probably not warranted.
+    case "$optimize" in 
+    '') optimize='-g' ;;
+    esac
+    ;;
+esac
+
 # Configure may fail to find lstat() since it's a static/inline function
 # in <sys/stat.h> on Unisys U6000 SVR4, UnixWare 2.x, and possibly other
 # SVR4 derivatives.  (Though UnixWare has it in /usr/ccs/lib/libc.so.)
index 74698db..2bae4b0 100644 (file)
@@ -1,4 +1,18 @@
-ccflags="$ccflags -DCRIPPLED_CC"
-d_lstat='define'
-usedl='undef'
-
+archname='s390'
+cc='cc -Xa'
+cccdlflags='-pic'
+d_bincompat3='undef'        
+d_csh='undef'       
+d_lstat='define'    
+d_suidsafe='define'                 
+dlsrc='dl_dlopen.xs'
+ld='ld'             
+lddlflags='-G -z text'
+libperl='libperl.so'
+libpth='/lib /usr/lib /usr/ccs/lib' 
+libs='-lsocket -lnsl -ldl -lm'
+optimize='undef'
+prefix='psf_prefix'  
+static_ext='none'    
+dynamic_ext='Fcntl IO Opcode Socket'
+useshrplib='define'  
index 0b2cf9d..9141efc 100644 (file)
@@ -24,7 +24,7 @@ i_utime=undef
 # compile/link flags
 ldflags=-g
 optimize=-g
-static_ext="B Data/Dumper Fcntl IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs"
+static_ext="B Data/Dumper Fcntl Filter::Util::Call IO IPC/SysV Opcode POSIX SDBM_File Socket Storable attrs"
 #static_ext=none
 # dynamic loading needs work
 usedl=undef
index 2b3dd28..81ab6a4 100644 (file)
@@ -218,7 +218,7 @@ dynamic_ext=''
 eagain='EAGAIN'
 ebcdic='define'
 exe_ext=''
-extensions='Fcntl GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Errno Thread attrs re Data/Dumper'
+extensions=' Data/Dumper Errno Fcntl Filter::Util:Call GDBM_File IO NDBM_File Opcode POSIX Socket Storable IPC/SysV Thread attrs re'
 fpostype='fpos_t'
 freetype='void'
 groupstype='gid_t'
diff --git a/hv.c b/hv.c
index 8a43a19..0e50523 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,6 @@
 /*    hv.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -75,20 +75,27 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
 {
     char *k;
     register HEK *hek;
+    bool is_utf8 = FALSE;
+
+    if (len < 0) {
+      len = -len;
+      is_utf8 = TRUE;
+    }
 
     New(54, k, HEK_BASESIZE + len + 1, char);
     hek = (HEK*)k;
     Copy(str, HEK_KEY(hek), len, char);
-    *(HEK_KEY(hek) + len) = '\0';
     HEK_LEN(hek) = len;
     HEK_HASH(hek) = hash;
+    HEK_UTF8(hek) = (char)is_utf8;
     return hek;
 }
 
 void
 Perl_unshare_hek(pTHX_ HEK *hek)
 {
-    unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
+    unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
+               HEK_HASH(hek));
 }
 
 #if defined(USE_ITHREADS)
@@ -112,9 +119,9 @@ Perl_he_dup(pTHX_ HE *e, bool shared)
     if (HeKLEN(e) == HEf_SVKEY)
        HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
     else if (shared)
-       HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+       HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
     else
-       HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+       HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
     return ret;
 }
@@ -138,19 +145,24 @@ information on how to use this function on tied hashes.
 */
 
 SV**
-Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
 {
     register XPVHV* xhv;
     register U32 hash;
     register HE *entry;
     SV *sv;
+    bool is_utf8 = FALSE;
 
     if (!hv)
        return 0;
 
+    if (klen < 0) {
+      klen = -klen;
+      is_utf8 = TRUE;
+    }
+
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
-           dTHR;
            sv = sv_newmortal();
            mg_copy((SV*)hv, sv, key, klen);
            PL_hv_fetch_sv = sv;
@@ -194,6 +206,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        return &HeVAL(entry);
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -209,7 +223,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
 #endif
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
-       return hv_store(hv,key,klen,sv,hash);
+       return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
     }
     return 0;
 }
@@ -241,13 +255,13 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     STRLEN klen;
     register HE *entry;
     SV *sv;
+    bool is_utf8;
 
     if (!hv)
        return 0;
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
-           dTHR;
            sv = sv_newmortal();
            keysv = sv_2mortal(newSVsv(keysv));
            mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
@@ -291,6 +305,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     }
 
     key = SvPV(keysv, klen);
+    is_utf8 = (SvUTF8(keysv)!=0);
 
     if (!hash)
        PERL_HASH(hash, key, klen);
@@ -303,6 +318,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        return entry;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -361,16 +378,22 @@ information on how to use this function on tied hashes.
 */
 
 SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
 {
     register XPVHV* xhv;
     register I32 i;
     register HE *entry;
     register HE **oentry;
+    bool is_utf8 = FALSE;
 
     if (!hv)
        return 0;
 
+    if (klen < 0) {
+      klen = -klen;
+      is_utf8 = TRUE;
+    }
+
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
        bool needs_copy;
@@ -406,6 +429,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
        return &HeVAL(entry);
@@ -413,9 +438,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has
 
     entry = new_HE();
     if (HvSHAREKEYS(hv))
-       HeKEY_hek(entry) = share_hek(key, klen, hash);
+       HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
-       HeKEY_hek(entry) = save_hek(key, klen, hash);
+       HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -458,13 +483,13 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     register I32 i;
     register HE *entry;
     register HE **oentry;
+    bool is_utf8;
 
     if (!hv)
        return 0;
 
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
-       dTHR;
        bool needs_copy;
        bool needs_store;
        hv_magic_check (hv, &needs_copy, &needs_store);
@@ -489,6 +514,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     }
 
     key = SvPV(keysv, klen);
+    is_utf8 = (SvUTF8(keysv) != 0);
 
     if (!hash)
        PERL_HASH(hash, key, klen);
@@ -507,6 +533,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
        return entry;
@@ -514,9 +542,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 
     entry = new_HE();
     if (HvSHAREKEYS(hv))
-       HeKEY_hek(entry) = share_hek(key, klen, hash);
+       HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
-       HeKEY_hek(entry) = save_hek(key, klen, hash);
+       HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -543,7 +571,7 @@ will be returned.
 */
 
 SV *
-Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
+Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 {
     register XPVHV* xhv;
     register I32 i;
@@ -552,9 +580,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
     register HE **oentry;
     SV **svp;
     SV *sv;
+    bool is_utf8 = FALSE;
 
     if (!hv)
        return Nullsv;
+    if (klen < 0) {
+      klen = -klen;
+      is_utf8 = TRUE;
+    }
     if (SvRMAGICAL(hv)) {
        bool needs_copy;
        bool needs_store;
@@ -594,6 +627,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -634,6 +669,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     register HE *entry;
     register HE **oentry;
     SV *sv;
+    bool is_utf8;
 
     if (!hv)
        return Nullsv;
@@ -667,6 +703,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
        return Nullsv;
 
     key = SvPV(keysv, klen);
+    is_utf8 = (SvUTF8(keysv) != 0);
 
     if (!hash)
        PERL_HASH(hash, key, klen);
@@ -681,6 +718,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -710,19 +749,24 @@ C<klen> is the length of the key.
 */
 
 bool
-Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
 {
     register XPVHV* xhv;
     register U32 hash;
     register HE *entry;
     SV *sv;
+    bool is_utf8 = FALSE;
 
     if (!hv)
        return 0;
 
+    if (klen < 0) {
+      klen = -klen;
+      is_utf8 = TRUE;
+    }
+
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
-           dTHR;
            sv = sv_newmortal();
            mg_copy((SV*)hv, sv, key, klen);
            magic_existspack(sv, mg_find(sv, 'p'));
@@ -756,6 +800,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -792,13 +838,13 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
     STRLEN klen;
     register HE *entry;
     SV *sv;
+    bool is_utf8;
 
     if (!hv)
        return 0;
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
-           dTHR;               /* just for SvTRUE */
            sv = sv_newmortal();
            keysv = sv_2mortal(newSVsv(keysv));
            mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
@@ -822,6 +868,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 #endif
 
     key = SvPV(keysv, klen);
+    is_utf8 = (SvUTF8(keysv) != 0);
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -837,6 +884,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -1051,8 +1100,8 @@ Perl_newHVhv(pTHX_ HV *ohv)
        /* Slow way */
        hv_iterinit(ohv);
        while ((entry = hv_iternext(ohv))) {
-           hv_store(hv, HeKEY(entry), HeKLEN(entry),
-                    SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+           hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
+                    newSVsv(HeVAL(entry)), HeHASH(entry));
        }
        HvRITER(ohv) = hv_riter;
        HvEITER(ohv) = hv_eiter;
@@ -1342,10 +1391,9 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry)
 {
     if (HeKLEN(entry) == HEf_SVKEY)
        return sv_mortalcopy(HeKEY_sv(entry));
-    else {
+    else
        return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
-                                 HeKLEN(entry), HeHASH(entry)));
-    }
+                                        HeKLEN_UTF8(entry), HeHASH(entry)));
 }
 
 /*
@@ -1422,6 +1470,12 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     register HE **oentry;
     register I32 i = 1;
     I32 found = 0;
+    bool is_utf8 = FALSE;
+
+    if (len < 0) {
+      len = -len;
+      is_utf8 = TRUE;
+    }
 
     /* what follows is the moral equivalent of:
     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
@@ -1439,6 +1493,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
            continue;
        if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        found = 1;
        if (--HeVAL(entry) == Nullsv) {
            *oentry = HeNEXT(entry);
@@ -1452,11 +1508,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     }
     UNLOCK_STRTAB_MUTEX;
 
-    {
-        dTHR;
-        if (!found && ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
-    }
+    if (!found && ckWARN_d(WARN_INTERNAL))
+       Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
 }
 
 /* get a (constant) string ptr from the global string table
@@ -1471,6 +1524,12 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
     register HE **oentry;
     register I32 i = 1;
     I32 found = 0;
+    bool is_utf8 = FALSE;
+
+    if (len < 0) {
+      len = -len;
+      is_utf8 = TRUE;
+    }
 
     /* what follows is the moral equivalent of:
 
@@ -1488,12 +1547,14 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
            continue;
        if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        found = 1;
        break;
     }
     if (!found) {
        entry = new_HE();
-       HeKEY_hek(entry) = save_hek(str, len, hash);
+       HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
        HeVAL(entry) = Nullsv;
        HeNEXT(entry) = *oentry;
        *oentry = entry;
diff --git a/hv.h b/hv.h
index 08f3bed..5def051 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -1,6 +1,6 @@
 /*    hv.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -151,6 +151,8 @@ C<SV*>.
 #define HeKEY(he)              HEK_KEY(HeKEY_hek(he))
 #define HeKEY_sv(he)           (*(SV**)HeKEY(he))
 #define HeKLEN(he)             HEK_LEN(HeKEY_hek(he))
+#define HeKUTF8(he)  HEK_UTF8(HeKEY_hek(he))
+#define HeKLEN_UTF8(he)  (HeKUTF8(he) ? -HeKLEN(he) : HeKLEN(he))
 #define HeVAL(he)              (he)->hent_val
 #define HeHASH(he)             HEK_HASH(HeKEY_hek(he))
 #define HePV(he,lp)            ((HeKLEN(he) == HEf_SVKEY) ?            \
@@ -175,6 +177,7 @@ C<SV*>.
 #define HEK_HASH(hek)          (hek)->hek_hash
 #define HEK_LEN(hek)           (hek)->hek_len
 #define HEK_KEY(hek)           (hek)->hek_key
+#define HEK_UTF8(hek)  (*(HEK_KEY(hek)+HEK_LEN(hek)))
 
 /* calculate HV array allocation */
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
index bef35e9..b5406c5 100755 (executable)
@@ -1,9 +1,8 @@
-#!./perl -w
+#!./perl -Ilib -w
 
 # This file should really be extracted from a .PL file
 
-use lib 'lib';         # use source library if present
-
+use strict;
 use Config;            # for config options in the makefile
 use Getopt::Long;      # for command-line parsing
 use Cwd;
@@ -110,6 +109,8 @@ Chris Hall E<lt>hallc@cs.colorado.eduE<gt>
 
 =cut
 
+my $usage;
+
 $usage =<<END_OF_USAGE;
 Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name>
          --htmldir=<name> --htmlroot=<name> --norecurse --recurse
@@ -142,6 +143,9 @@ Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name>
 
 END_OF_USAGE
 
+my (@libpods, @podpath, $podroot, $htmldir, $htmlroot, $recurse, @splithead,
+    @splititem, $splitpod, $verbose, $pod2html);
+
 @libpods = ();
 @podpath = ( "." );    # colon-separated list of directories containing .pod
                        # and .pm files to be converted.
@@ -163,8 +167,12 @@ usage("") unless @ARGV;
 # See vms/descrip_mms.template -> descrip.mms for invokation.
 if ( $^O eq 'VMS' ) { @ARGV = split(/\s+/,$ARGV[0]); }
 
+use vars qw($opt_htmldir $opt_htmlroot $opt_podroot $opt_splitpod
+            $opt_verbose $opt_help $opt_podpath $opt_splithead $opt_splititem
+            $opt_libpods $opt_recurse);
+
 # parse the command-line
-$result = GetOptions( qw(
+my $result = GetOptions( qw(
        help
        podpath=s
        podroot=s
@@ -196,8 +204,8 @@ $splitpod = "$podroot/pod" unless $splitpod;
 # ignored in the conversion process.  these are files that have been
 # process by splititem or splithead and should not be converted as a
 # result.
-@ignore = ();
-
+my @ignore = ();
+my @splitdirs;
 
 # split pods.  its important to do this before convert ANY pods because
 #  it may effect some of the links
@@ -209,25 +217,25 @@ split_on_item($podroot,           \@splitdirs, \@ignore, @splititem);
 # convert the pod pages found in @poddirs
 #warn "converting files\n" if $verbose;
 #warn "\@ignore\t= @ignore\n" if $verbose;
-foreach $dir (@podpath) {
+foreach my $dir (@podpath) {
     installdir($dir, $recurse, $podroot, \@splitdirs, \@ignore);
 }
 
 
 # now go through and create master indices for each pod we split
-foreach $dir (@splititem) {
+foreach my $dir (@splititem) {
     print "creating index $htmldir/$dir.html\n" if $verbose;
     create_index("$htmldir/$dir.html", "$htmldir/$dir");
 }
 
-foreach $dir (@splithead) {
+foreach my $dir (@splithead) {
     $dir .= ".pod" unless $dir =~ /(\.pod|\.pm)$/;
     # let pod2html create the file
     runpod2html($dir, 1);
 
     # now go through and truncate after the index
     $dir =~ /^(.*?)(\.pod|\.pm)?$/sm;
-    $file = "$htmldir/$1";
+    my $file = "$htmldir/$1";
     print "creating index $file.html\n" if $verbose;
 
     # read in everything until what would have been the first =head
@@ -235,7 +243,7 @@ foreach $dir (@splithead) {
     open(H, "<$file.html") ||
        die "$0: error opening $file.html for input: $!\n";
     $/ = "";
-    @data = ();
+    my @data = ();
     while (<H>) {
        last if /NAME=/;
        $_ =~ s{HREF="#(.*)">}{
@@ -251,7 +259,7 @@ foreach $dir (@splithead) {
     # now rewrite the file 
     open(H, ">$file.html") ||
        die "$0: error opening $file.html for output: $!\n";
-    print H "@data\n";
+    print H "@data", "\n";
     close(H);
 }
 
@@ -322,6 +330,7 @@ sub create_index {
        close(IN);
 
        # pull out the NAME section
+  my $name;
        ($name) = grep(/NAME=/, @filedata);
        ($lcp1,$lcp2) = ($name =~ m,/H1>\s(\S+)\s[\s-]*(.*?)\s*$,sm);
        if (defined $lcp1 and $lcp1 eq '<P>') { # Uninteresting.  Try again.
@@ -383,7 +392,7 @@ sub split_on_item {
     print "splitting files by item.\n" if $verbose && $#splititem >= 0;
     $pwd = getcwd();
        my $splitter = absolute_path($pwd, "$splitpod/splitpod");
-    foreach $pod (@splititem) {
+    foreach my $pod (@splititem) {
        # figure out the directory to split into
        $pod      =~ s,^([^/]*)$,/$1,;
        $pod      =~ m,(.*?)/(.*?)(\.pod)?$,;
@@ -443,7 +452,7 @@ sub splitpod {
 
     # create list of =head[1-6] sections so that we can rewrite
     #  L<> links as necessary.
-    %heads = ();
+    my %heads = ();
     foreach $i (0..$#poddata) {
        $heads{htmlize($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/;
     }
@@ -451,7 +460,7 @@ sub splitpod {
     # create a directory of a similar name and store all the
     #  files in there
     $pod =~ s,.*/(.*),$1,;     # get the last part of the name
-    $dir = $pod;
+    my $dir = $pod;
     $dir =~ s/\.pod//g;
     push(@$splitdirs, "$poddir/$dir");
     mkdir("$poddir/$dir", 0755) ||
@@ -538,7 +547,7 @@ sub installdir {
     }
 
     # install all the pods we found
-    foreach $pod (@podlist) {
+    foreach my $pod (@podlist) {
        # check if we should ignore it.
        next if grep($_ eq "$podroot/$pod.pod", @$ignore);
 
@@ -552,7 +561,7 @@ sub installdir {
     }
 
     # install all the .pm files we found
-    foreach $pm (@pmlist) {
+    foreach my $pm (@pmlist) {
        # check if we should ignore it.
        next if grep($_ eq "$pm.pm", @ignore);
 
index 72c76fd..06f68f5 100755 (executable)
@@ -23,19 +23,21 @@ die "Patchlevel of perl ($patchlevel)",
 my $usage =
 "Usage:  installman --man1dir=/usr/wherever --man1ext=1
                    --man3dir=/usr/wherever --man3ext=3
+                  --batchlimit=40
                   --notify --verbose --silent --help
        Defaults are:
        man1dir = $Config{'installman1dir'};
        man1ext = $Config{'man1ext'};
        man3dir = $Config{'installman3dir'};
        man3ext = $Config{'man3ext'};
+        batchlimit is maximum number of pod files per invocation of pod2man
        --notify  (or -n) just lists commands that would be executed.
         --verbose (or -V) report all progress.
         --silent  (or -S) be silent. Only report errors.\n";
 
 my %opts;
 GetOptions( \%opts,
-            qw( man1dir=s man1ext=s man3dir=s man3ext=s
+            qw( man1dir=s man1ext=s man3dir=s man3ext=s batchlimit=i
                 notify n help silent S verbose V)) 
        || die $usage;
 die $usage if $opts{help};
@@ -48,6 +50,7 @@ $opts{man3dir} = $Config{'installman3dir'}
     unless defined($opts{man3dir}); 
 $opts{man3ext} = $Config{'man3ext'}
     unless defined($opts{man3ext}); 
+$opts{batchlimit} ||= 40;
 $opts{silent} ||= $opts{S};
 $opts{notify} ||= $opts{n};
 $opts{verbose} ||= $opts{V} || $opts{notify};
@@ -71,24 +74,12 @@ runpod2man('pod', $opts{man1dir}, $opts{man1ext});
 runpod2man('lib', $opts{man3dir}, $opts{man3ext});
 
 # Install the pods embedded in the installed scripts
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2ph');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'h2xs');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlcc');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perldoc');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'perlbug');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pl2pm');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'splain');
-runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'dprofpp');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'a2p.pod');
-runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 'find2perl');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2html');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2text');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2usage');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podchecker');
-runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'podselect');
+runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'c2ph', 'h2ph', 'h2xs',
+          'perlcc', 'perldoc', 'perlbug', 'pl2pm', 'splain', 'dprofpp');
+runpod2man('x2p', $opts{man1dir}, $opts{man1ext}, 's2p', 'a2p.pod',
+          'find2perl');
+runpod2man('pod', $opts{man1dir}, $opts{man1ext}, 'pod2man', 'pod2html',
+          'pod2text', 'pod2usage', 'podchecker', 'podselect');
 
 # It would probably be better to have this page linked
 # to the c2ph man page.  Or, this one could say ".so man1/c2ph.1",
@@ -98,9 +89,9 @@ runpod2man('utils', $opts{man1dir}, $opts{man1ext}, 'pstruct');
 runpod2man('lib/ExtUtils', $opts{man1dir}, $opts{man1ext}, 'xsubpp');
 
 sub runpod2man {
-    # $script is script name if we are installing a manpage embedded 
-    # in a script, undef otherwise
-    my($poddir, $mandir, $manext, $script) = @_;
+    # @script is scripts names if we are installing manpages embedded 
+    # in scripts, () otherwise
+    my($poddir, $mandir, $manext, @script) = @_;
 
     my($downdir); # can't just use .. when installing xsubpp manpage
 
@@ -109,8 +100,12 @@ sub runpod2man {
     my($builddir) = Cwd::getcwd();
 
     if ($mandir eq ' ' or $mandir eq '') {
-       warn "Skipping installation of ",
-           ($script ? "$poddir/$script man page" : "$poddir man pages"), ".\n";
+       if (@script) {
+           warn "Skipping installation of $poddir/$_ man page.\n"
+               foreach @script;
+       } else {
+           warn "Skipping installation of $poddir man pages.\n";
+       }
        return;
     }
 
@@ -134,13 +129,14 @@ sub runpod2man {
     # Make a list of all the .pm and .pod files in the directory.  We will
     # always run pod2man from the lib directory and feed it the full pathname
     # of the pod.  This might be useful for pod2man someday.
-    if ($script) {
-       @modpods = ($script);
+    if (@script) {
+       @modpods = @script;
     }
     else {
        @modpods = ();
        File::Find::find(\&lsmodpods, '.');
     }
+    my @to_process;
     foreach my $mod (@modpods) {
        my $manpage = $mod;
        my $tmp;
@@ -159,15 +155,25 @@ sub runpod2man {
        }
        $tmp = "${mandir}/${manpage}.tmp";
        $manpage = "${mandir}/${manpage}.${manext}";
-       if (&cmd("$pod2man $mod > $tmp") == 0 && !$opts{notify} && -s $tmp) {
-           if (rename($tmp, $manpage)) {
-               $packlist->{$manpage} = { type => 'file' };
-               next;
+       push @to_process, [$mod, $tmp, $manpage];
+    }
+    # Don't do all pods in same command to avoid busting command line limits
+    while (my @this_batch = splice @to_process, 0, $opts{batchlimit}) {
+       my $cmd = join " ", $pod2man, map "$$_[0] $$_[1]", @this_batch;
+       if (&cmd($cmd) == 0 && !$opts{notify}) {
+           foreach (@this_batch) {
+               my (undef, $tmp, $manpage) = @$_;
+               if (-s $tmp) {
+                   if (rename($tmp, $manpage)) {
+                       $packlist->{$manpage} = { type => 'file' };
+                       next;
+                   }
+               }
+               unless ($opts{notify}) {
+                   unlink($tmp);
+               }
            }
        }
-       unless ($opts{notify}) {
-           unlink($tmp);
-       }
     }
     chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n";
     print "  chdir $builddir\n" if $opts{verbose};
index 99d376f..f3788cf 100755 (executable)
@@ -162,8 +162,8 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
 -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
 
 -f 't/rantests'                || $Is_W32
-                       || warn "WARNING: You've never run 'make test'!!!",
-                               "  (Installing anyway.)\n";
+                        || warn "WARNING: You've never run 'make test' or",
+                                " some tests failed! (Installing anyway.)\n";
 
 if ($Is_W32 or $Is_Cygwin) {
   my $perldll;
index 07ec33e..e9c3797 100644 (file)
@@ -97,7 +97,7 @@ C<PL_DBsingle>.
 
 =for apidoc Amn|SV *|PL_DBsingle
 When Perl is run in debugging mode, with the B<-d> switch, this SV is a
-boolean which indicates whether subs are being single-stepped. 
+boolean which indicates whether subs are being single-stepped.
 Single-stepping is automatically turned on after every step.  This is the C
 variable which corresponds to Perl's $DB::single variable.  See
 C<PL_DBsub>.
@@ -169,8 +169,7 @@ PERLVARI(Ilaststype,        I32,    OP_STAT)
 PERLVAR(Imess_sv,      SV *)
 
 /* XXX shouldn't these be per-thread? --GSAR */
-PERLVAR(Iors,          char *)         /* output record separator $\ */
-PERLVAR(Iorslen,       STRLEN)
+PERLVAR(Iors_sv,       SV *)           /* output record separator $\ */
 PERLVAR(Iofmt,         char *)         /* output format for numbers $# */
 
 /* interpreter atexit processing */
@@ -181,10 +180,10 @@ PERLVARI(Iexitlistlen,    I32, 0)         /* length of same */
 /*
 =for apidoc Amn|HV*|PL_modglobal
 
-C<PL_modglobal> is a general purpose, interpreter global HV for use by 
+C<PL_modglobal> is a general purpose, interpreter global HV for use by
 extensions that need to keep information on a per-interpreter basis.
-In a pinch, it can also be used as a symbol table for extensions 
-to share data among each other.  It is a good idea to use keys 
+In a pinch, it can also be used as a symbol table for extensions
+to share data among each other.  It is a good idea to use keys
 prefixed by the package name of the extension that owns the data.
 
 =cut
index 59da474..fe03f5c 100644 (file)
  *
  */
 
-
 /*
-    Interface for perl stdio functions
-*/
-
-
-/* Clean up (or at least document) the various possible #defines.
-   This section attempts to match the 5.003_03 Configure variables
-   onto the 5.003_02 header file values.
-   I can't figure out where USE_STDIO was supposed to be set.
-   --AD
+    Interface for perl stdio functions, or whatever we are Configure-d
+    to use.
 */
-#ifndef USE_PERLIO
-# define PERLIO_IS_STDIO
-#endif
-
-/* Below is the 5.003_02 stuff. */
-#ifdef USE_STDIO
-#  ifndef PERLIO_IS_STDIO
-#      define PERLIO_IS_STDIO
-#  endif
-#else
-extern void PerlIO_init (void);
-#endif
+#include "perlio.h"
 
 #ifndef Sighandler_t
 typedef Signal_t (*Sighandler_t) (int);
@@ -80,60 +61,54 @@ typedef Signal_t (*Sighandler_t) (int);
 
 #if defined(PERL_IMPLICIT_SYS)
 
-#ifndef PerlIO
-typedef struct _PerlIO PerlIO;
-#endif
-
 /* IPerlStdIO          */
 struct IPerlStdIO;
 struct IPerlStdIOInfo;
-typedef PerlIO*                (*LPStdin)(struct IPerlStdIO*);
-typedef PerlIO*                (*LPStdout)(struct IPerlStdIO*);
-typedef PerlIO*                (*LPStderr)(struct IPerlStdIO*);
-typedef PerlIO*                (*LPOpen)(struct IPerlStdIO*, const char*,
+typedef FILE*          (*LPStdin)(struct IPerlStdIO*);
+typedef FILE*          (*LPStdout)(struct IPerlStdIO*);
+typedef FILE*          (*LPStderr)(struct IPerlStdIO*);
+typedef FILE*          (*LPOpen)(struct IPerlStdIO*, const char*,
                            const char*);
-typedef int            (*LPClose)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPEof)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPError)(struct IPerlStdIO*, PerlIO*);
-typedef void           (*LPClearerr)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPGetc)(struct IPerlStdIO*, PerlIO*);
-typedef char*          (*LPGetBase)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPGetBufsiz)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPGetCnt)(struct IPerlStdIO*, PerlIO*);
-typedef char*          (*LPGetPtr)(struct IPerlStdIO*, PerlIO*);
-typedef char*          (*LPGets)(struct IPerlStdIO*, PerlIO*, char*, int);
-typedef int            (*LPPutc)(struct IPerlStdIO*, PerlIO*, int);
-typedef int            (*LPPuts)(struct IPerlStdIO*, PerlIO*, const char*);
-typedef int            (*LPFlush)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPUngetc)(struct IPerlStdIO*, PerlIO*,int);
-typedef int            (*LPFileno)(struct IPerlStdIO*, PerlIO*);
-typedef PerlIO*                (*LPFdopen)(struct IPerlStdIO*, int, const char*);
-typedef PerlIO*                (*LPReopen)(struct IPerlStdIO*, const char*,
-                           const char*, PerlIO*);
-typedef SSize_t                (*LPRead)(struct IPerlStdIO*, PerlIO*, void*, Size_t);
-typedef SSize_t                (*LPWrite)(struct IPerlStdIO*, PerlIO*, const void*,
+typedef int            (*LPClose)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPEof)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPError)(struct IPerlStdIO*, FILE*);
+typedef void           (*LPClearerr)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPGetc)(struct IPerlStdIO*, FILE*);
+typedef char*          (*LPGetBase)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPGetBufsiz)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPGetCnt)(struct IPerlStdIO*, FILE*);
+typedef char*          (*LPGetPtr)(struct IPerlStdIO*, FILE*);
+typedef char*          (*LPGets)(struct IPerlStdIO*, FILE*, char*, int);
+typedef int            (*LPPutc)(struct IPerlStdIO*, FILE*, int);
+typedef int            (*LPPuts)(struct IPerlStdIO*, FILE*, const char*);
+typedef int            (*LPFlush)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPUngetc)(struct IPerlStdIO*, int,FILE*);
+typedef int            (*LPFileno)(struct IPerlStdIO*, FILE*);
+typedef FILE*          (*LPFdopen)(struct IPerlStdIO*, int, const char*);
+typedef FILE*          (*LPReopen)(struct IPerlStdIO*, const char*,
+                           const char*, FILE*);
+typedef SSize_t                (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *);
+typedef SSize_t                (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *);
+typedef void           (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*);
+typedef int            (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int,
                            Size_t);
-typedef void           (*LPSetBuf)(struct IPerlStdIO*, PerlIO*, char*);
-typedef int            (*LPSetVBuf)(struct IPerlStdIO*, PerlIO*, char*, int,
-                           Size_t);
-typedef void           (*LPSetCnt)(struct IPerlStdIO*, PerlIO*, int);
-typedef void           (*LPSetPtrCnt)(struct IPerlStdIO*, PerlIO*, char*,
-                           int);
-typedef void           (*LPSetlinebuf)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPPrintf)(struct IPerlStdIO*, PerlIO*, const char*, 
+typedef void           (*LPSetCnt)(struct IPerlStdIO*, FILE*, int);
+typedef void           (*LPSetPtr)(struct IPerlStdIO*, FILE*, char*);
+typedef void           (*LPSetlinebuf)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*,
                            ...);
-typedef int            (*LPVprintf)(struct IPerlStdIO*, PerlIO*, const char*,
+typedef int            (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*,
                            va_list);
-typedef long           (*LPTell)(struct IPerlStdIO*, PerlIO*);
-typedef int            (*LPSeek)(struct IPerlStdIO*, PerlIO*, Off_t, int);
-typedef void           (*LPRewind)(struct IPerlStdIO*, PerlIO*);
-typedef PerlIO*                (*LPTmpfile)(struct IPerlStdIO*);
-typedef int            (*LPGetpos)(struct IPerlStdIO*, PerlIO*, Fpos_t*);
-typedef int            (*LPSetpos)(struct IPerlStdIO*, PerlIO*,
+typedef long           (*LPTell)(struct IPerlStdIO*, FILE*);
+typedef int            (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int);
+typedef void           (*LPRewind)(struct IPerlStdIO*, FILE*);
+typedef FILE*          (*LPTmpfile)(struct IPerlStdIO*);
+typedef int            (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*);
+typedef int            (*LPSetpos)(struct IPerlStdIO*, FILE*,
                            const Fpos_t*);
 typedef void           (*LPInit)(struct IPerlStdIO*);
 typedef void           (*LPInitOSExtras)(struct IPerlStdIO*);
-typedef PerlIO*                (*LPFdupopen)(struct IPerlStdIO*, PerlIO*);
+typedef FILE*          (*LPFdupopen)(struct IPerlStdIO*, FILE*);
 
 struct IPerlStdIO
 {
@@ -163,7 +138,7 @@ struct IPerlStdIO
     LPSetBuf           pSetBuf;
     LPSetVBuf          pSetVBuf;
     LPSetCnt           pSetCnt;
-    LPSetPtrCnt                pSetPtrCnt;
+    LPSetPtr           pSetPtr;
     LPSetlinebuf       pSetlinebuf;
     LPPrintf           pPrintf;
     LPVprintf          pVprintf;
@@ -184,297 +159,181 @@ struct IPerlStdIOInfo
     struct IPerlStdIO  perlStdIOList;
 };
 
+/* These do not belong here ... NI-S, 14 Nov 2000 */
+
 #ifdef USE_STDIO_PTR
-#  define PerlIO_has_cntptr(f)         1       
-#  ifdef STDIO_CNT_LVALUE
-#    define PerlIO_canset_cnt(f)       1      
-#    ifdef STDIO_PTR_LVALUE
-#      define PerlIO_fast_gets(f)      1        
+#  define PerlSIO_has_cntptr(f)                1
+#  ifdef STDIO_PTR_LVALUE
+#    ifdef  STDIO_CNT_LVALUE
+#      define PerlSIO_canset_cnt(f)    1
+#      ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+#        define PerlSIO_fast_gets(f)   1
+#      endif
+#    else /* STDIO_CNT_LVALUE */
+#      define PerlSIO_canset_cnt(f)    0
+#    endif
+#  else /* STDIO_PTR_LVALUE */
+#    ifdef STDIO_PTR_LVAL_SETS_CNT
+#      define PerlSIO_fast_gets(f)     1
 #    endif
-#  else
-#    define PerlIO_canset_cnt(f)       0      
 #  endif
 #else  /* USE_STDIO_PTR */
-#  define PerlIO_has_cntptr(f)         0
-#  define PerlIO_canset_cnt(f)         0
+#  define PerlSIO_has_cntptr(f)                0
+#  define PerlSIO_canset_cnt(f)                0
 #endif /* USE_STDIO_PTR */
 
-#ifndef PerlIO_fast_gets
-#define PerlIO_fast_gets(f)            0        
+#ifndef PerlSIO_fast_gets
+#define PerlSIO_fast_gets(f)           0
 #endif
 
 #ifdef FILE_base
-#define PerlIO_has_base(f)             1
+#define PerlSIO_has_base(f)            1
 #else
-#define PerlIO_has_base(f)             0
+#define PerlSIO_has_base(f)            0
 #endif
 
-#define PerlIO_stdin()                                                 \
+/* Now take FILE * via function table */
+
+#define PerlSIO_stdin                                                  \
        (*PL_StdIO->pStdin)(PL_StdIO)
-#define PerlIO_stdout()                                                        \
+#define PerlSIO_stdout                                                 \
        (*PL_StdIO->pStdout)(PL_StdIO)
-#define PerlIO_stderr()                                                        \
+#define PerlSIO_stderr                                                 \
        (*PL_StdIO->pStderr)(PL_StdIO)
-#define PerlIO_open(x,y)                                               \
+#define PerlSIO_fopen(x,y)                                             \
        (*PL_StdIO->pOpen)(PL_StdIO, (x),(y))
-#define PerlIO_close(f)                                                        \
+#define PerlSIO_fclose(f)                                              \
        (*PL_StdIO->pClose)(PL_StdIO, (f))
-#define PerlIO_eof(f)                                                  \
+#define PerlSIO_feof(f)                                                        \
        (*PL_StdIO->pEof)(PL_StdIO, (f))
-#define PerlIO_error(f)                                                        \
+#define PerlSIO_ferror(f)                                              \
        (*PL_StdIO->pError)(PL_StdIO, (f))
-#define PerlIO_clearerr(f)                                             \
+#define PerlSIO_clearerr(f)                                            \
        (*PL_StdIO->pClearerr)(PL_StdIO, (f))
-#define PerlIO_getc(f)                                                 \
+#define PerlSIO_fgetc(f)                                               \
        (*PL_StdIO->pGetc)(PL_StdIO, (f))
-#define PerlIO_get_base(f)                                             \
+#define PerlSIO_get_base(f)                                            \
        (*PL_StdIO->pGetBase)(PL_StdIO, (f))
-#define PerlIO_get_bufsiz(f)                                           \
+#define PerlSIO_get_bufsiz(f)                                          \
        (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f))
-#define PerlIO_get_cnt(f)                                              \
+#define PerlSIO_get_cnt(f)                                             \
        (*PL_StdIO->pGetCnt)(PL_StdIO, (f))
-#define PerlIO_get_ptr(f)                                              \
+#define PerlSIO_get_ptr(f)                                             \
        (*PL_StdIO->pGetPtr)(PL_StdIO, (f))
-#define PerlIO_putc(f,c)                                               \
+#define PerlSIO_fputc(f,c)                                             \
        (*PL_StdIO->pPutc)(PL_StdIO, (f),(c))
-#define PerlIO_puts(f,s)                                               \
+#define PerlSIO_fputs(f,s)                                             \
        (*PL_StdIO->pPuts)(PL_StdIO, (f),(s))
-#define PerlIO_flush(f)                                                        \
+#define PerlSIO_fflush(f)                                              \
        (*PL_StdIO->pFlush)(PL_StdIO, (f))
-#define PerlIO_gets(s, n, fp)                                          \
+#define PerlSIO_fgets(s, n, fp)                                                \
        (*PL_StdIO->pGets)(PL_StdIO, (fp), s, n)
-#define PerlIO_ungetc(f,c)                                             \
-       (*PL_StdIO->pUngetc)(PL_StdIO, (f),(c))
-#define PerlIO_fileno(f)                                               \
+#define PerlSIO_ungetc(c,f)                                            \
+       (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f))
+#define PerlSIO_fileno(f)                                              \
        (*PL_StdIO->pFileno)(PL_StdIO, (f))
-#define PerlIO_fdopen(f, s)                                            \
+#define PerlSIO_fdopen(f, s)                                           \
        (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s))
-#define PerlIO_reopen(p, m, f)                                         \
+#define PerlSIO_freopen(p, m, f)                                       \
        (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f))
-#define PerlIO_read(f,buf,count)                                       \
-       (SSize_t)(*PL_StdIO->pRead)(PL_StdIO, (f), (buf), (count))
-#define PerlIO_write(f,buf,count)                                      \
-       (*PL_StdIO->pWrite)(PL_StdIO, (f), (buf), (count))
-#define PerlIO_setbuf(f,b)                                             \
+#define PerlSIO_fread(buf,sz,count,f)                                  \
+       (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f))
+#define PerlSIO_fwrite(buf,sz,count,f)                                 \
+       (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f))
+#define PerlSIO_setbuf(f,b)                                            \
        (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b))
-#define PerlIO_setvbuf(f,b,t,s)                                                \
+#define PerlSIO_setvbuf(f,b,t,s)                                       \
        (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s))
-#define PerlIO_set_cnt(f,c)                                            \
+#define PerlSIO_set_cnt(f,c)                                           \
        (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c))
-#define PerlIO_set_ptrcnt(f,p,c)                                       \
-       (*PL_StdIO->pSetPtrCnt)(PL_StdIO, (f), (p), (c))
-#define PerlIO_setlinebuf(f)                                           \
+#define PerlSIO_set_ptr(f,p)                                           \
+       (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p))
+#define PerlSIO_setlinebuf(f)                                          \
        (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f))
-#define PerlIO_printf          Perl_fprintf_nocontext
-#define PerlIO_stdoutf         *PL_StdIO->pPrintf
-#define PerlIO_vprintf(f,fmt,a)                                                \
-       (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)          
-#define PerlIO_tell(f)                                                 \
+#define PerlSIO_printf         Perl_fprintf_nocontext
+#define PerlSIO_stdoutf                *PL_StdIO->pPrintf
+#define PerlSIO_vprintf(f,fmt,a)                                       \
+       (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)
+#define PerlSIO_ftell(f)                                                       \
        (*PL_StdIO->pTell)(PL_StdIO, (f))
-#define PerlIO_seek(f,o,w)                                             \
+#define PerlSIO_fseek(f,o,w)                                           \
        (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w))
-#define PerlIO_getpos(f,p)                                             \
+#define PerlSIO_fgetpos(f,p)                                           \
        (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p))
-#define PerlIO_setpos(f,p)                                             \
+#define PerlSIO_fsetpos(f,p)                                           \
        (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p))
-#define PerlIO_rewind(f)                                               \
+#define PerlSIO_rewind(f)                                              \
        (*PL_StdIO->pRewind)(PL_StdIO, (f))
-#define PerlIO_tmpfile()                                               \
+#define PerlSIO_tmpfile()                                              \
        (*PL_StdIO->pTmpfile)(PL_StdIO)
-#define PerlIO_init()                                                  \
+#define PerlSIO_init()                                                 \
        (*PL_StdIO->pInit)(PL_StdIO)
 #undef         init_os_extras
 #define init_os_extras()                                               \
        (*PL_StdIO->pInitOSExtras)(PL_StdIO)
-#define PerlIO_fdupopen(f)                                             \
+#define PerlSIO_fdupopen(f)                                            \
        (*PL_StdIO->pFdupopen)(PL_StdIO, (f))
 
 #else  /* PERL_IMPLICIT_SYS */
 
-#include "perlsdio.h"
-#include "perl.h"
-#define PerlIO_fdupopen(f)             (f)
-
-#endif /* PERL_IMPLICIT_SYS */
-
-#ifndef PERLIO_IS_STDIO
-#ifdef USE_SFIO
-#include "perlsfio.h"
-#endif /* USE_SFIO */
-#endif /* PERLIO_IS_STDIO */
-
-#ifndef EOF
-#define EOF (-1)
-#endif
-
-/* This is to catch case with no stdio */
-#ifndef BUFSIZ
-#define BUFSIZ 1024
-#endif
-
-#ifndef SEEK_SET
-#define SEEK_SET 0
-#endif
-
-#ifndef SEEK_CUR
-#define SEEK_CUR 1
-#endif
-
-#ifndef SEEK_END
-#define SEEK_END 2
-#endif
-
-#ifndef PerlIO
-struct _PerlIO;
-#define PerlIO struct _PerlIO
-#endif /* No PerlIO */
-
-#ifndef Fpos_t
-#define Fpos_t long
-#endif
-
-#ifndef NEXT30_NO_ATTRIBUTE
-#ifndef HASATTRIBUTE       /* disable GNU-cc attribute checking? */
-#ifdef  __attribute__      /* Avoid possible redefinition errors */
-#undef  __attribute__
-#endif
-#define __attribute__(attr)
-#endif
-#endif
-
-#ifndef PerlIO_stdoutf
-extern int     PerlIO_stdoutf          (const char *,...)
-                                       __attribute__((__format__ (__printf__, 1, 2)));
-#endif
-#ifndef PerlIO_puts
-extern int     PerlIO_puts             (PerlIO *,const char *);
-#endif
-#ifndef PerlIO_open
-extern PerlIO *        PerlIO_open             (const char *,const char *);
-#endif
-#ifndef PerlIO_close
-extern int     PerlIO_close            (PerlIO *);
-#endif
-#ifndef PerlIO_eof
-extern int     PerlIO_eof              (PerlIO *);
-#endif
-#ifndef PerlIO_error
-extern int     PerlIO_error            (PerlIO *);
-#endif
-#ifndef PerlIO_clearerr
-extern void    PerlIO_clearerr         (PerlIO *);
-#endif
-#ifndef PerlIO_getc
-extern int     PerlIO_getc             (PerlIO *);
-#endif
-#ifndef PerlIO_putc
-extern int     PerlIO_putc             (PerlIO *,int);
-#endif
-#ifndef PerlIO_flush
-extern int     PerlIO_flush            (PerlIO *);
-#endif
-#ifndef PerlIO_ungetc
-extern int     PerlIO_ungetc           (PerlIO *,int);
-#endif
-#ifndef PerlIO_fileno
-extern int     PerlIO_fileno           (PerlIO *);
-#endif
-#ifndef PerlIO_fdopen
-extern PerlIO *        PerlIO_fdopen           (int, const char *);
-#endif
-#ifndef PerlIO_importFILE
-extern PerlIO *        PerlIO_importFILE       (FILE *,int);
-#endif
-#ifndef PerlIO_exportFILE
-extern FILE *  PerlIO_exportFILE       (PerlIO *,int);
-#endif
-#ifndef PerlIO_findFILE
-extern FILE *  PerlIO_findFILE         (PerlIO *);
-#endif
-#ifndef PerlIO_releaseFILE
-extern void    PerlIO_releaseFILE      (PerlIO *,FILE *);
-#endif
-#ifndef PerlIO_read
-extern SSize_t PerlIO_read             (PerlIO *,void *,Size_t);
-#endif
-#ifndef PerlIO_write
-extern SSize_t PerlIO_write            (PerlIO *,const void *,Size_t);
-#endif
-#ifndef PerlIO_setlinebuf
-extern void    PerlIO_setlinebuf       (PerlIO *);
-#endif
-#ifndef PerlIO_printf
-extern int     PerlIO_printf           (PerlIO *, const char *,...)
-                                       __attribute__((__format__ (__printf__, 2, 3)));
-#endif
-#ifndef PerlIO_sprintf
-extern int     PerlIO_sprintf          (char *, int, const char *,...)
-                                       __attribute__((__format__ (__printf__, 3, 4)));
-#endif
-#ifndef PerlIO_vprintf
-extern int     PerlIO_vprintf          (PerlIO *, const char *, va_list);
-#endif
-#ifndef PerlIO_tell
-extern Off_t   PerlIO_tell             (PerlIO *);
-#endif
-#ifndef PerlIO_seek
-extern int     PerlIO_seek             (PerlIO *, Off_t, int);
-#endif
-#ifndef PerlIO_rewind
-extern void    PerlIO_rewind           (PerlIO *);
-#endif
-#ifndef PerlIO_has_base
-extern int     PerlIO_has_base         (PerlIO *);
-#endif
-#ifndef PerlIO_has_cntptr
-extern int     PerlIO_has_cntptr       (PerlIO *);
-#endif
-#ifndef PerlIO_fast_gets
-extern int     PerlIO_fast_gets        (PerlIO *);
-#endif
-#ifndef PerlIO_canset_cnt
-extern int     PerlIO_canset_cnt       (PerlIO *);
-#endif
-#ifndef PerlIO_get_ptr
-extern STDCHAR * PerlIO_get_ptr                (PerlIO *);
-#endif
-#ifndef PerlIO_get_cnt
-extern int     PerlIO_get_cnt          (PerlIO *);
-#endif
-#ifndef PerlIO_set_cnt
-extern void    PerlIO_set_cnt          (PerlIO *,int);
-#endif
-#ifndef PerlIO_set_ptrcnt
-extern void    PerlIO_set_ptrcnt       (PerlIO *,STDCHAR *,int);
-#endif
-#ifndef PerlIO_get_base
-extern STDCHAR * PerlIO_get_base       (PerlIO *);
-#endif
-#ifndef PerlIO_get_bufsiz
-extern int     PerlIO_get_bufsiz       (PerlIO *);
-#endif
-#ifndef PerlIO_tmpfile
-extern PerlIO *        PerlIO_tmpfile          (void);
-#endif
-#ifndef PerlIO_stdin
-extern PerlIO *        PerlIO_stdin    (void);
-#endif
-#ifndef PerlIO_stdout
-extern PerlIO *        PerlIO_stdout   (void);
-#endif
-#ifndef PerlIO_stderr
-extern PerlIO *        PerlIO_stderr   (void);
-#endif
-#ifndef PerlIO_getpos
-extern int     PerlIO_getpos           (PerlIO *,Fpos_t *);
-#endif
-#ifndef PerlIO_setpos
-extern int     PerlIO_setpos           (PerlIO *,const Fpos_t *);
+#define PerlSIO_stdin                  stdin
+#define PerlSIO_stdout                 stdout
+#define PerlSIO_stderr                 stderr
+#define PerlSIO_fopen(x,y)             fopen(x,y)
+#define PerlSIO_fclose(f)              fclose(f)
+#define PerlSIO_feof(f)                        feof(f)
+#define PerlSIO_ferror(f)              ferror(f)
+#define PerlSIO_clearerr(f)            clearerr(f)
+#define PerlSIO_fgetc(f)                       fgetc(f)
+#if PerlSIO_has_base
+#define PerlSIO_get_base(f)            FILE_base(f)
+#define PerlSIO_get_bufsiz(f)          FILE_bufsiz(f)
+#else
+#define PerlSIO_get_base(f)            NULL
+#define PerlSIO_get_bufsiz(f)          0
 #endif
-#ifndef PerlIO_fdupopen
-extern PerlIO *        PerlIO_fdupopen         (PerlIO *);
+#ifdef USE_STDIO_PTR
+#define PerlSIO_get_cnt(f)             FILE_cnt(f)
+#define PerlSIO_get_ptr(f)             FILE_ptr(f)
+#else
+#define PerlSIO_get_cnt(f)             0
+#define PerlSIO_get_ptr(f)             NULL
+#endif
+#define PerlSIO_fputc(f,c)             fputc(c,f)
+#define PerlSIO_fputs(f,s)             fputs(s,f)
+#define PerlSIO_fflush(f)              Fflush(f)
+#define PerlSIO_fgets(s, n, fp)                fgets(s,n,fp)
+#define PerlSIO_ungetc(c,f)            ungetc(c,f)
+#define PerlSIO_fileno(f)              fileno(f)
+#define PerlSIO_fdopen(f, s)           fdopen(f,s)
+#define PerlSIO_freopen(p, m, f)       freopen(p,m,f)
+#define PerlSIO_fread(buf,sz,count,f)  fread(buf,sz,count,f)
+#define PerlSIO_fwrite(buf,sz,count,f) fwrite(buf,sz,count,f)
+#define PerlSIO_setbuf(f,b)            setbuf(f,b)
+#define PerlSIO_setvbuf(f,b,t,s)       setvbuf(f,b,t,s)
+#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
+#define PerlSIO_set_cnt(f,c)           FILE_cnt(f) = (c)
+#else
+#define PerlSIO_set_cnt(f,c)           PerlIOProc_abort()
 #endif
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
+#define PerlSIO_set_ptr(f,p)           FILE_ptr(f) = (p)
+#else
+#define PerlSIO_set_ptr(f,p)           PerlIOProc_abort()
+#endif
+#define PerlSIO_setlinebuf(f)          setlinebuf(f)
+#define PerlSIO_printf                 Perl_fprintf_nocontext
+#define PerlSIO_stdoutf                        *PL_StdIO->pPrintf
+#define PerlSIO_vprintf(f,fmt,a)       
+#define PerlSIO_ftell(f)               ftell(f)
+#define PerlSIO_fseek(f,o,w)           fseek(f,o,w)
+#define PerlSIO_fgetpos(f,p)           fgetpos(f,p)
+#define PerlSIO_fsetpos(f,p)           fsetpos(f,p)
+#define PerlSIO_rewind(f)              rewind(f)
+#define PerlSIO_tmpfile()              tmpfile()
+#define PerlSIO_fdupopen(f)            (f)
 
+#endif /* PERL_IMPLICIT_SYS */
 
 /*
  *   Interface for directory functions
@@ -552,7 +411,7 @@ struct IPerlDirInfo
 #define PerlDir_mkdir(name, mode)      Mkdir((name), (mode))
 #ifdef VMS
 #  define PerlDir_chdir(n)             Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN")
-#else 
+#else
 #  define PerlDir_chdir(name)          chdir((name))
 #endif
 #define PerlDir_rmdir(name)            rmdir((name))
@@ -922,36 +781,36 @@ struct IPerlMemInfo
 
 /* Shared memory macros */
 #define PerlMemShared_malloc(size)                         \
-       (*PL_MemShared->pMalloc)(PL_Mem, (size))
+       (*PL_MemShared->pMalloc)(PL_MemShared, (size))
 #define PerlMemShared_realloc(buf, size)                   \
-       (*PL_MemShared->pRealloc)(PL_Mem, (buf), (size))
+       (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size))
 #define PerlMemShared_free(buf)                                    \
-       (*PL_MemShared->pFree)(PL_Mem, (buf))
+       (*PL_MemShared->pFree)(PL_MemShared, (buf))
 #define PerlMemShared_calloc(num, size)                            \
-       (*PL_MemShared->pCalloc)(PL_Mem, (num), (size))
+       (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size))
 #define PerlMemShared_get_lock()                           \
-       (*PL_MemShared->pGetLock)(PL_Mem)
+       (*PL_MemShared->pGetLock)(PL_MemShared)
 #define PerlMemShared_free_lock()                          \
-       (*PL_MemShared->pFreeLock)(PL_Mem)
+       (*PL_MemShared->pFreeLock)(PL_MemShared)
 #define PerlMemShared_is_locked()                          \
-       (*PL_MemShared->pIsLocked)(PL_Mem)
+       (*PL_MemShared->pIsLocked)(PL_MemShared)
 
 
 /* Parse tree memory macros */
 #define PerlMemParse_malloc(size)                          \
-       (*PL_MemParse->pMalloc)(PL_Mem, (size))
+       (*PL_MemParse->pMalloc)(PL_MemParse, (size))
 #define PerlMemParse_realloc(buf, size)                            \
-       (*PL_MemParse->pRealloc)(PL_Mem, (buf), (size))
+       (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size))
 #define PerlMemParse_free(buf)                             \
-       (*PL_MemParse->pFree)(PL_Mem, (buf))
+       (*PL_MemParse->pFree)(PL_MemParse, (buf))
 #define PerlMemParse_calloc(num, size)                     \
-       (*PL_MemParse->pCalloc)(PL_Mem, (num), (size))
+       (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size))
 #define PerlMemParse_get_lock()                                    \
-       (*PL_MemParse->pGetLock)(PL_Mem)
+       (*PL_MemParse->pGetLock)(PL_MemParse)
 #define PerlMemParse_free_lock()                           \
-       (*PL_MemParse->pFreeLock)(PL_Mem)
+       (*PL_MemParse->pFreeLock)(PL_MemParse)
 #define PerlMemParse_is_locked()                           \
-       (*PL_MemParse->pIsLocked)(PL_Mem)
+       (*PL_MemParse->pIsLocked)(PL_MemParse)
 
 
 #else  /* PERL_IMPLICIT_SYS */
@@ -1043,6 +902,7 @@ typedef int                (*LPProcSpawnvp)(struct IPerlProc*, int, const char*,
                            const char*const*);
 typedef int            (*LPProcASpawn)(struct IPerlProc*, void*, void**, void**);
 #endif
+typedef int            (*LPProcLastHost)(struct IPerlProc*);
 
 struct IPerlProc
 {
@@ -1081,6 +941,7 @@ struct IPerlProc
     LPProcSpawnvp      pSpawnvp;
     LPProcASpawn       pASpawn;
 #endif
+    LPProcLastHost      pLastHost;
 };
 
 struct IPerlProcInfo
@@ -1160,6 +1021,8 @@ struct IPerlProcInfo
 #define PerlProc_aspawn(m,c,a)                                         \
        (*PL_Proc->pASpawn)(PL_Proc, (m), (c), (a))
 #endif
+#define PerlProc_lasthost()                                            \
+       (*PL_Proc->pLastHost)(PL_Proc)
 
 #else  /* PERL_IMPLICIT_SYS */
 
@@ -1256,7 +1119,7 @@ typedef int               (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int,
 typedef int            (*LPSelect)(struct IPerlSock*, int, char*, char*,
                            char*, const struct timeval*);
 typedef int            (*LPSend)(struct IPerlSock*, SOCKET, const char*, int,
-                           int); 
+                           int);
 typedef int            (*LPSendto)(struct IPerlSock*, SOCKET, const char*,
                            int, int, const struct sockaddr*, int);
 typedef void           (*LPSethostent)(struct IPerlSock*, int);
index 58ffda7..ce85049 100644 (file)
@@ -1,6 +1,7 @@
 package AnyDBM_File;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
 
 my $mod;
index fd06f64..6b87054 100644 (file)
@@ -107,18 +107,18 @@ unless ($OS) {
        $OS = $Config::Config{'osname'};
     }
 }
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
   $OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
   $OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
-  $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
   $OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
     $OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
     $OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+    $OS = 'EPOC';
 } else {
     $OS = 'UNIX';
 }
@@ -135,7 +135,7 @@ $AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
 # The path separator is a slash, backslash or semicolon, depending
 # on the paltform.
 $SL = {
-    UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
+    UNIX=>'/', EPOC=>'/', OS2=>'\\', WINDOWS=>'\\', DOS=>'\\', MACINTOSH=>':', VMS=>'/'
     }->{$OS};
 
 # This no longer seems to be necessary
@@ -3274,7 +3274,7 @@ unless ($TMPDIRECTORY) {
     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
           "C:${SL}temp","${SL}tmp","${SL}temp",
           "${vol}${SL}Temporary Items",
-           "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH");
+           "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH", "C:${SL}system${SL}temp");
     unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
 
     # this feature was supposed to provide per-user tmpfiles, but
@@ -3530,12 +3530,18 @@ have several choices:
 
 =over 4
 
-=item 1. Use another name for the argument, if one is available.  For
-example, -value is an alias for -values.
+=item 1.
+
+Use another name for the argument, if one is available. 
+For example, -value is an alias for -values.
 
-=item 2. Change the capitalization, e.g. -Values
+=item 2.
 
-=item 3. Put quotes around the argument name, e.g. '-values'
+Change the capitalization, e.g. -Values
+
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
 
 =back
 
@@ -5669,6 +5675,7 @@ field.
 The second argument (-src) is also required and specifies the URL
 
 =item 3.
+
 The third option (-align, optional) is an alignment type, and may be
 TOP, BOTTOM or MIDDLE
 
@@ -6102,6 +6109,7 @@ Returns either the remote host name or IP address.
 if the former is unavailable.
 
 =item B<script_name()>
+
 Return the script name as a partial URL, for self-refering
 scripts.
 
@@ -6220,7 +6228,9 @@ Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your
 
       CGI->nph(1)
 
-=item By using B<-nph> parameters in the B<header()> and B<redirect()>  statements:
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()>  statements:
 
       print $q->header(-nph=>1);
 
index dced866..550c6e4 100644 (file)
@@ -1,4 +1,7 @@
 use CGI;
+
+our $VERSION = '1.00';
+
 1;
 __END__
 
index b16b9c0..e754fde 100644 (file)
@@ -1,4 +1,7 @@
 use CGI;
+
+our $VERSION = '1.00';
+
 1;
 
 __END__
index aeb6a57..fce7dc4 100644 (file)
@@ -1,12 +1,11 @@
 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 package CPAN;
-$VERSION = '1.57_68RC';
-
-# $Id: CPAN.pm,v 1.354 2000/10/08 14:20:57 k Exp $
+$VERSION = '1.59_51';
+# $Id: CPAN.pm,v 1.381 2000/12/01 08:13:05 k Exp $
 
 # only used during development:
 $Revision = "";
-# $Revision = "[".substr(q$Revision: 1.354 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.381 $, 10)."]";
 
 use Carp ();
 use Config ();
@@ -56,7 +55,7 @@ package CPAN;
 use strict qw(vars);
 
 use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
-            $Revision $Signal $Cwd $End $Suppress_readline $Frontend
+            $Revision $Signal $End $Suppress_readline $Frontend
             $Defaultsite $Have_warned);
 
 @CPAN::ISA = qw(CPAN::Debug Exporter);
@@ -88,24 +87,24 @@ sub shell {
     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
     CPAN::Config->load unless $CPAN::Config_loaded++;
 
-    CPAN::Index->read_metadata_cache;
+    my $oprompt = shift || "cpan> ";
+    my $prompt = $oprompt;
+    my $commandline = shift || "";
 
-    my $prompt = "cpan> ";
     local($^W) = 1;
     unless ($Suppress_readline) {
        require Term::ReadLine;
-#      import Term::ReadLine;
-       $term = Term::ReadLine->new('CPAN Monitor');
+        if (! $term
+            or
+            $term->ReadLine eq "Term::ReadLine::Stub"
+           ) {
+            $term = Term::ReadLine->new('CPAN Monitor');
+        }
        if ($term->ReadLine eq "Term::ReadLine::Gnu") {
            my $attribs = $term->Attribs;
-#           $attribs->{completion_entry_function} =
-#               $attribs->{'list_completion_function'};
             $attribs->{attempted_completion_function} = sub {
                 &CPAN::Complete::gnu_cpl;
             }
-#          $attribs->{completion_word} =
-#              [qw(help me somebody to find out how
-#                    to use completion with GNU)];
        } else {
            $readline::rl_completion_function =
                $readline::rl_completion_function = 'CPAN::Complete::cpl';
@@ -120,9 +119,7 @@ sub shell {
 
     # no strict; # I do not recall why no strict was here (2000-09-03)
     $META->checklock();
-    my $getcwd;
-    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
-    my $cwd = CPAN->$getcwd();
+    my $cwd = CPAN::anycwd();
     my $try_detect_readline;
     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
     my $rl_avail = $Suppress_readline ? "suppressed" :
@@ -141,20 +138,21 @@ ReadLine support %s
                             )
         unless $CPAN::Config->{'inhibit_startup_message'} ;
     my($continuation) = "";
-    while () {
+  SHELLCOMMAND: while () {
        if ($Suppress_readline) {
            print $prompt;
-           last unless defined ($_ = <> );
+           last SHELLCOMMAND unless defined ($_ = <> );
            chomp;
        } else {
-           last unless defined ($_ = $term->readline($prompt));
+           last SHELLCOMMAND unless
+                defined ($_ = $term->readline($prompt, $commandline));
        }
        $_ = "$continuation$_" if $continuation;
        s/^\s+//;
-       next if /^$/;
+       next SHELLCOMMAND if /^$/;
        $_ = 'h' if /^\s*\?/;
        if (/^(?:q(?:uit)?|bye|exit)$/i) {
-           last;
+           last SHELLCOMMAND;
        } elsif (s/\\$//s) {
            chomp;
            $continuation = $_;
@@ -169,14 +167,16 @@ ReadLine support %s
            eval($eval);
            warn $@ if $@;
            $continuation = "";
-           $prompt = "cpan> ";
+           $prompt = $oprompt;
        } elsif (/./) {
            my(@line);
            if ($] < 5.00322) { # parsewords had a bug until recently
                @line = split;
            } else {
                eval { @line = Text::ParseWords::shellwords($_) };
-               warn($@), next if $@;
+               warn($@), next SHELLCOMMAND if $@;
+                warn("Text::Parsewords could not parse the line [$_]"),
+                    next SHELLCOMMAND unless @line;
            }
            $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
            my $command = shift @line;
@@ -185,9 +185,12 @@ ReadLine support %s
            chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
            $CPAN::Frontend->myprint("\n");
            $continuation = "";
-           $prompt = "cpan> ";
+           $prompt = $oprompt;
        }
     } continue {
+      $commandline = ""; # I do want to be able to pass a default to
+                         # shell, but on the second command I see no
+                         # use in that
       $Signal=0;
       CPAN::Queue->nullify_queue;
       if ($try_detect_readline) {
@@ -201,10 +204,12 @@ ReadLine support %s
            require Term::ReadLine;
            $CPAN::Frontend->myprint("\n$redef subroutines in ".
                                     "Term::ReadLine redefined\n");
+            @_ = ($oprompt,"");
            goto &shell;
        }
       }
     }
+    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
 }
 
 package CPAN::CacheMgr;
@@ -226,6 +231,11 @@ use vars qw($Ua $Thesite $Themethod);
 
 package CPAN::Complete;
 @CPAN::Complete::ISA = qw(CPAN::Debug);
+@CPAN::Complete::COMMANDS = sort qw(
+                      ! a b d h i m o q r u autobundle clean dump
+                      make test install force readme reload look
+                       cvs_import ls
+) unless @CPAN::Complete::COMMANDS;
 
 package CPAN::Index;
 use vars qw($last_time $date_of_03);
@@ -251,8 +261,10 @@ package CPAN::Module;
 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 
 package CPAN::Shell;
-use vars qw($AUTOLOAD @ISA);
+use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
 @CPAN::Shell::ISA = qw(CPAN::Debug);
+$COLOR_REGISTERED ||= 0;
+$PRINT_ORNAMENTING ||= 0;
 
 #-> sub CPAN::Shell::AUTOLOAD ;
 sub AUTOLOAD {
@@ -279,8 +291,9 @@ For this you just need to type
 }
 
 package CPAN::Tarzip;
-use vars qw($AUTOLOAD @ISA);
+use vars qw($AUTOLOAD @ISA $BUGHUNTING);
 @CPAN::Tarzip::ISA = qw(CPAN::Debug);
+$BUGHUNTING = 0; # released code must have turned off
 
 package CPAN::Queue;
 
@@ -583,6 +596,13 @@ sub DESTROY {
     &cleanup; # need an eval?
 }
 
+#-> sub CPAN::anycwd ;
+sub anycwd () {
+    my $getcwd;
+    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+    CPAN->$getcwd();
+}
+
 #-> sub CPAN::cwd ;
 sub cwd {Cwd::cwd();}
 
@@ -592,6 +612,7 @@ sub getcwd {Cwd::getcwd();}
 #-> sub CPAN::exists ;
 sub exists {
     my($mgr,$class,$id) = @_;
+    CPAN::Config->load unless $CPAN::Config_loaded++;
     CPAN::Index->reload;
     ### Carp::croak "exists called without class argument" unless $class;
     $id ||= "";
@@ -788,9 +809,7 @@ sub entries {
     return unless defined $dir;
     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
     $dir ||= $self->{ID};
-    my $getcwd;
-    $getcwd  = $CPAN::Config->{'getcwd'} || 'cwd';
-    my($cwd) = CPAN->$getcwd();
+    my($cwd) = CPAN::anycwd();
     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
     my $dh = DirHandle->new(File::Spec->curdir)
         or Carp::croak("Couldn't opendir $dir: $!");
@@ -1030,7 +1049,7 @@ EOF
     my($fh) = FileHandle->new;
     rename $configpm, "$configpm~" if -f $configpm;
     open $fh, ">$configpm" or
-        $CPAN::Frontend->mywarn("Couldn't open >$configpm: $!");
+        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
     foreach (sort keys %$CPAN::Config) {
        $fh->print(
@@ -1267,21 +1286,40 @@ sub a {
   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
 }
 
-#-> sub CPAN::Shell::local_bundles ;
+#-> sub CPAN::Shell::ls ;
+sub ls      {
+    my($self,@arg) = @_;
+    for (@arg) {
+        $_ = uc $_;
+    }
+    for my $a (@arg){
+        my $author = $self->expand('Author',$a) or die "No author found for $a";
+        $author->ls;
+    }
+}
 
+#-> sub CPAN::Shell::local_bundles ;
 sub local_bundles {
     my($self,@which) = @_;
     my($incdir,$bdir,$dh);
     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
-       $bdir = MM->catdir($incdir,"Bundle");
-       if ($dh = DirHandle->new($bdir)) { # may fail
-           my($entry);
-           for $entry ($dh->read) {
-               next if -d MM->catdir($bdir,$entry);
-               next unless $entry =~ s/\.pm(?!\n)\Z//;
-               $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
-           }
-       }
+        my @bbase = "Bundle";
+        while (my $bbase = shift @bbase) {
+            $bdir = MM->catdir($incdir,split /::/, $bbase);
+            CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
+            if ($dh = DirHandle->new($bdir)) { # may fail
+                my($entry);
+                for $entry ($dh->read) {
+                    next if $entry =~ /^\./; # 
+                    if (-d MM->catdir($bdir,$entry)){
+                        push @bbase, "$bbase\::$entry";
+                    } else {
+                        next unless $entry =~ s/\.pm(?!\n)\Z//;
+                        $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
+                    }
+                }
+            }
+        }
     }
 }
 
@@ -1312,10 +1350,14 @@ sub i {
     for $type (@type) {
        push @result, $self->expand($type,@args);
     }
-    my $result =  @result == 1 ?
+    my $result = @result == 1 ?
        $result[0]->as_string :
-           join "", map {$_->as_glimpse} @result;
-    $result ||= "No objects found of any type for argument @args\n";
+            @result == 0 ?
+                "No objects found of any type for argument @args\n" :
+                    join("",
+                         (map {$_->as_glimpse} @result),
+                         scalar @result, " items found\n",
+                        );
     $CPAN::Frontend->myprint($result);
 }
 
@@ -1358,6 +1400,10 @@ sub o {
        if (@o_what) {
            while (@o_what) {
                my($what) = shift @o_what;
+                if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
+                    $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
+                    next;
+                }
                if ( exists $CPAN::DEBUG{$what} ) {
                    $CPAN::DEBUG |= $CPAN::DEBUG{$what};
                } elsif ($what =~ /^\d/) {
@@ -1499,7 +1545,7 @@ sub _u_r_common {
     my(@result,$module,%seen,%need,$headerdone,
        $version_undefs,$version_zeroes);
     $version_undefs = $version_zeroes = 0;
-    my $sprintf = "%-25s %9s %9s  %s\n";
+    my $sprintf = "%s%-25s%s %9s %9s  %s\n";
     my @expand = $self->expand('Module',@args);
     my $expand = scalar @expand;
     if (0) { # Looks like noise to me, was very useful for debugging
@@ -1555,15 +1601,31 @@ sub _u_r_common {
        unless ($headerdone++){
            $CPAN::Frontend->myprint("\n");
            $CPAN::Frontend->myprint(sprintf(
-                  $sprintf,
-                  "Package namespace",
-                  "installed",
-                  "latest",
-                  "in CPAN file"
-                  ));
+                                             $sprintf,
+                                             "",
+                                             "Package namespace",
+                                             "",
+                                             "installed",
+                                             "latest",
+                                             "in CPAN file"
+                                            ));
        }
+        my $color_on = "";
+        my $color_off = "";
+        if (
+            $COLOR_REGISTERED
+            &&
+            $CPAN::META->has_inst("Term::ANSIColor")
+            &&
+            $module->{RO}{description}
+           ) {
+            $color_on = Term::ANSIColor::color("green");
+            $color_off = Term::ANSIColor::color("reset");
+        }
        $CPAN::Frontend->myprint(sprintf $sprintf,
+                                 $color_on,
                                  $module->id,
+                                 $color_off,
                                  $have,
                                  $latest,
                                  $file);
@@ -1653,6 +1715,7 @@ sub expandany {
     my($self,$s) = @_;
     CPAN->debug("s[$s]") if $CPAN::DEBUG;
     if ($s =~ m|/|) { # looks like a file
+        $s = CPAN::Distribution->normalize($s);
         return $CPAN::META->instance('CPAN::Distribution',$s);
         # Distributions spring into existence, not expand
     } elsif ($s =~ m|^Bundle::|) {
@@ -1673,15 +1736,21 @@ sub expand {
     shift;
     my($type,@args) = @_;
     my($arg,@m);
+    CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
     for $arg (@args) {
        my($regex,$command);
        if ($arg =~ m|^/(.*)/$|) {
            $regex = $1;
-       } elsif ($arg =~ m/^=/) {
-            $command = substr($arg,1);
+       } elsif ($arg =~ m/=/) {
+            $command = 1;
         }
        my $class = "CPAN::$type";
        my $obj;
+        CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
+                    $class,
+                    defined $regex ? $regex : "UNDEFINED",
+                    $command || "UNDEFINED",
+                   ) if $CPAN::DEBUG;
        if (defined $regex) {
             for $obj (
                       sort
@@ -1690,10 +1759,11 @@ sub expand {
                      ) {
                 unless ($obj->id){
                     # BUG, we got an empty object somewhere
+                    require Data::Dumper;
                     CPAN->debug(sprintf(
-                                        "Empty id on obj[%s]%%[%s]",
+                                        "Bug in CPAN: Empty id on obj[%s][%s]",
                                         $obj,
-                                        join(":", %$obj)
+                                        Data::Dumper::Dumper($obj)
                                        )) if $CPAN::DEBUG;
                     next;
                 }
@@ -1712,21 +1782,33 @@ sub expand {
                             );
             }
         } elsif ($command) {
-            die "leading equal sign in command disabled, ".
-                "please edit CPAN.pm to enable eval() or ".
-                    "do not use = on argument list";
+            die "equal sign in command disabled (immature interface), ".
+                "you can set
+ ! \$CPAN::Shell::ADVANCED_QUERY=1
+to enable it. But please note, this is HIGHLY EXPERIMENTAL code
+that may go away anytime.\n"
+                    unless $ADVANCED_QUERY;
+            my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
+            my($matchcrit) = $criterion =~ m/^~(.+)/;
             for my $self (
                           sort
                           {$a->id cmp $b->id}
                           $CPAN::META->all_objects($class)
                          ) {
-                push @m, $self if eval $command;
+                my $lhs = $self->$method() or next; # () for 5.00503
+                if ($matchcrit) {
+                    push @m, $self if $lhs =~ m/$matchcrit/;
+                } else {
+                    push @m, $self if $lhs eq $criterion;
+                }
             }
        } else {
            my($xarg) = $arg;
            if ( $type eq 'Bundle' ) {
                $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
-           }
+           } elsif ($type eq "Distribution") {
+                $xarg = CPAN::Distribution->normalize($arg);
+            }
            if ($CPAN::META->exists($class,$xarg)) {
                $obj = $CPAN::META->instance($class,$xarg);
            } elsif ($CPAN::META->exists($class,$arg)) {
@@ -1746,22 +1828,33 @@ sub format_result {
     my($type,@args) = @_;
     @args = '/./' unless @args;
     my(@result) = $self->expand($type,@args);
-    my $result =  @result == 1 ?
+    my $result = @result == 1 ?
        $result[0]->as_string :
-           join "", map {$_->as_glimpse} @result;
-    $result ||= "No objects of type $type found for argument @args\n";
+            @result == 0 ?
+                "No objects of type $type found for argument @args\n" :
+                    join("",
+                         (map {$_->as_glimpse} @result),
+                         scalar @result, " items found\n",
+                        );
     $result;
 }
 
 # The only reason for this method is currently to have a reliable
 # debugging utility that reveals which output is going through which
 # channel. No, I don't like the colors ;-)
+
+#-> sub CPAN::Shell::print_ornameted ;
 sub print_ornamented {
     my($self,$what,$ornament) = @_;
     my $longest = 0;
-    my $ornamenting = 0; # turn the colors on
+    return unless defined $what;
 
-    if ($ornamenting) {
+    if ($CPAN::Config->{term_is_latin}){
+        # courtesy jhi:
+        $what
+            =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
+    }
+    if ($PRINT_ORNAMENTING) {
        unless (defined &color) {
            if ($CPAN::META->has_inst("Term::ANSIColor")) {
                import Term::ANSIColor "color";
@@ -1789,6 +1882,7 @@ sub print_ornamented {
 
 sub myprint {
     my($self,$what) = @_;
+
     $self->print_ornamented($what, 'bold blue on_yellow');
 }
 
@@ -1873,13 +1967,17 @@ sub rematein {
             push @qcopy, $obj;
        } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
            $obj = $CPAN::META->instance('CPAN::Author',$s);
-           $CPAN::Frontend->myprint(
-                                    join "",
-                                    "Don't be silly, you can't $meth ",
-                                    $obj->fullname,
-                                    " ;-)\n"
-                                   );
-            sleep 2;
+            if ($meth eq "dump") {
+                $obj->dump;
+            } else {
+                $CPAN::Frontend->myprint(
+                                         join "",
+                                         "Don't be silly, you can't $meth ",
+                                         $obj->fullname,
+                                         " ;-)\n"
+                                        );
+                sleep 2;
+            }
        } else {
            $CPAN::Frontend
                ->myprint(qq{Warning: Cannot $meth $s, }.
@@ -2065,14 +2163,19 @@ sub localize {
     # Inheritance is not easier to manage than a few if/else branches
     if ($CPAN::META->has_usable('LWP::UserAgent')) {
        unless ($Ua) {
-           $Ua = LWP::UserAgent->new;
-           my($var);
-           $Ua->proxy('ftp',  $var)
-               if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
-           $Ua->proxy('http', $var)
-               if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
-           $Ua->no_proxy($var)
-               if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+           eval {$Ua = LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
+            if ($@) {
+                $CPAN::Frontent->mywarn("LWP::UserAgent->new dies with $@")
+                    if $CPAN::DEBUG;
+            } else {
+                my($var);
+                $Ua->proxy('ftp',  $var)
+                    if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
+                $Ua->proxy('http', $var)
+                    if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+                $Ua->no_proxy($var)
+                    if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+            }
        }
     }
     $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
@@ -2137,7 +2240,7 @@ sub localize {
                         qq{E.g. with 'o conf urllist push ftp://myurl/'};
         $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
         sleep 2;
-        $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
+        $CPAN::Frontend->myprint("Could not fetch $file\n");
     }
     if ($restore) {
        rename "$aslocal.bak", $aslocal;
@@ -2291,7 +2394,7 @@ sub hosthard {
 
        $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
        my($f,$funkyftp);
-       for $f ('lynx','ncftpget','ncftp') {
+       for $f ('lynx','ncftpget','ncftp','wget') {
          next unless exists $CPAN::Config->{$f};
          $funkyftp = $CPAN::Config->{$f};
          next unless defined $funkyftp;
@@ -2304,6 +2407,8 @@ sub hosthard {
            $src_switch = " -source";
          } elsif ($f eq "ncftp"){
            $src_switch = " -c";
+          } elsif ($f eq "wget"){
+              $src_switch = " -O -";
          }
          my($chdir) = "";
          my($stdout_redir) = " > $asl_ungz";
@@ -2609,6 +2714,7 @@ sub new {
          }, $class;
 }
 
+# CPAN::FTP::hasdefault;
 sub hasdefault { shift->{'hasdefault'} }
 sub netrc      { shift->{'netrc'}      }
 sub protected  { shift->{'protected'}  }
@@ -2656,24 +2762,22 @@ sub cpl {
     }
     my @return;
     if ($pos == 0) {
-       @return = grep(
-                      /^$word/,
-                      sort qw(
-                              ! a b d h i m o q r u autobundle clean dump
-                              make test install force readme reload look cvs_import
-                             )
-                     );
+       @return = grep /^$word/, @CPAN::Complete::COMMANDS;
     } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
        @return = ();
-    } elsif ($line =~ /^a\s/) {
-       @return = cplx('CPAN::Author',$word);
+    } elsif ($line =~ /^(a|ls)\s/) {
+       @return = cplx('CPAN::Author',uc($word));
     } elsif ($line =~ /^b\s/) {
+        CPAN::Shell->local_bundles;
        @return = cplx('CPAN::Bundle',$word);
     } elsif ($line =~ /^d\s/) {
        @return = cplx('CPAN::Distribution',$word);
     } elsif ($line =~ m/^(
                           [mru]|make|clean|dump|test|install|readme|look|cvs_import
                          )\s/x ) {
+        if ($word =~ /^Bundle::/) {
+            CPAN::Shell->local_bundles;
+        }
        @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
     } elsif ($line =~ /^i\s/) {
        @return = cpl_any($word);
@@ -2681,6 +2785,9 @@ sub cpl {
        @return = cpl_reload($word,$line,$pos);
     } elsif ($line =~ /^o\s/) {
        @return = cpl_option($word,$line,$pos);
+    } elsif ($line =~ m/^\S+\s/ ) {
+        # fallback for future commands and what we have forgotten above
+       @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
     } else {
        @return = ();
     }
@@ -2757,7 +2864,15 @@ sub reload {
     for ($CPAN::Config->{index_expire}) {
        $_ = 0.001 unless $_ && $_ > 0.001;
     }
-    $CPAN::META->{PROTOCOL} ||= "1.0";
+    unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
+        # debug here when CPAN doesn't seem to read the Metadata
+        require Carp;
+        Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
+    }
+    unless ($CPAN::META->{PROTOCOL}) {
+        $cl->read_metadata_cache;
+        $CPAN::META->{PROTOCOL} ||= "1.0";
+    }
     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
         # warn "Setting last_time to 0";
         $last_time = 0; # No warning necessary
@@ -2846,9 +2961,6 @@ sub rd_authindex {
     my @lines;
     return unless defined $index_target;
     $CPAN::Frontend->myprint("Going to read $index_target\n");
-#    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
-#    while ($_ = $fh->READLINE) {
-    # no strict 'refs';
     local(*FH);
     tie *FH, CPAN::Tarzip, $index_target;
     local($/) = "\n";
@@ -3047,7 +3159,7 @@ sub rd_modlist {
     Carp::confess($@) if $@;
     return if $CPAN::Signal;
     for (keys %$ret) {
-       my $obj = $CPAN::META->instance(CPAN::Module,$_);
+       my $obj = $CPAN::META->instance("CPAN::Module",$_);
         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
        $obj->set(%{$ret->{$_}});
        return if $CPAN::Signal;
@@ -3158,6 +3270,10 @@ sub set {
     # because of a typo, we do not like it that they are written into
     # the readonly area and made permanent (at least for a while) and
     # that is why we do not "allow" other places to call ->set.
+    unless ($self->id) {
+        CPAN->debug("Bug? Empty ID, rejecting");
+        return;
+    }
     my $ro = $self->{RO} =
         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
 
@@ -3187,17 +3303,20 @@ sub as_string {
        # next if m/^(ID|RO)$/;
        my $extra = "";
        if ($_ eq "CPAN_USERID") {
-         $extra .= " (".$self->author;
-         my $email; # old perls!
-         if ($email = $CPAN::META->instance(CPAN::Author,
-                                             $self->cpan_userid
-                                            )->email) {
-           $extra .= " <$email>";
-         } else {
-           $extra .= " <no email>";
-         }
-         $extra .= ")";
-       }
+            $extra .= " (".$self->author;
+            my $email; # old perls!
+            if ($email = $CPAN::META->instance("CPAN::Author",
+                                               $self->cpan_userid
+                                              )->email) {
+                $extra .= " <$email>";
+            } else {
+                $extra .= " <no email>";
+            }
+            $extra .= ")";
+        } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
+            push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
+            next;
+        }
         next unless defined $self->{RO}{$_};
         push @m, sprintf "    %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
     }
@@ -3221,7 +3340,7 @@ sub as_string {
 #-> sub CPAN::InfoObj::author ;
 sub author {
     my($self) = @_;
-    $CPAN::META->instance(CPAN::Author,$self->cpan_userid)->fullname;
+    $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
 }
 
 #-> sub CPAN::InfoObj::dump ;
@@ -3244,11 +3363,89 @@ sub as_glimpse {
 }
 
 #-> sub CPAN::Author::fullname ;
-sub fullname { shift->{RO}{FULLNAME} }
+sub fullname {
+    shift->{RO}{FULLNAME};
+}
 *name = \&fullname;
 
 #-> sub CPAN::Author::email ;
-sub email    { shift->{RO}{EMAIL} }
+sub email    { shift->{RO}{EMAIL}; }
+
+#-> sub CPAN::Author::ls ;
+sub ls {
+    my $self = shift;
+    my $id = $self->id;
+
+    # adapted from CPAN::Distribution::verifyMD5 ;
+    my(@chksumfile);
+    @chksumfile = $self->id =~ /(.)(.)(.*)/;
+    $chksumfile[1] = join "", @chksumfile[0,1];
+    $chksumfile[2] = join "", @chksumfile[1,2];
+    push @chksumfile, "CHECKSUMS";
+    print join "", map {
+        sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
+    } sort { $a->[2] cmp $b->[2] } $self->dir_listing(\@chksumfile);
+}
+
+#-> sub CPAN::Author::dir_listing ;
+sub dir_listing {
+    my $self = shift;
+    my $chksumfile = shift;
+    my $lc_want =
+       MM->catfile($CPAN::Config->{keep_source_where},
+                    "authors", "id", @$chksumfile);
+    local($") = "/";
+    my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
+                                      $lc_want,1);
+    unless ($lc_file) {
+        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+       $chksumfile->[-1] .= ".gz";
+       $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
+                                      "$lc_want.gz",1);
+       if ($lc_file) {
+           $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
+           CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
+       } else {
+           return;
+       }
+    }
+
+    # adapted from CPAN::Distribution::MD5_check_file ;
+    my $fh = FileHandle->new;
+    my($cksum);
+    if (open $fh, $lc_file){
+       local($/);
+       my $eval = <$fh>;
+       $eval =~ s/\015?\012/\n/g;
+       close $fh;
+       my($comp) = Safe->new();
+       $cksum = $comp->reval($eval);
+       if ($@) {
+           rename $lc_file, "$lc_file.bad";
+           Carp::confess($@) if $@;
+       }
+    } else {
+       Carp::carp "Could not open $lc_file for reading";
+    }
+    my(@result,$f);
+    for $f (sort keys %$cksum) {
+        if (exists $cksum->{$f}{isdir}) {
+            my(@dir) = @$chksumfile;
+            pop @dir;
+            push @dir, $f, "CHECKSUMS";
+            push @result, map {
+                [$_->[0], $_->[1], "$f/$_->[2]"]
+            } $self->dir_listing(\@dir);
+        } else {
+            push @result, [
+                           ($cksum->{$f}{"size"}||0),
+                           $cksum->{$f}{"mtime"}||"---",
+                           $f
+                          ];
+        }
+    }
+    @result;
+}
 
 package CPAN::Distribution;
 
@@ -3260,6 +3457,19 @@ sub undelay {
     delete $self->{later};
 }
 
+# CPAN::Distribution::normalize
+sub normalize {
+    my($self,$s) = @_;
+    $s = $self->id unless defined $s;
+    if ($s =~ tr|/|| == 1) {
+        return $s if $s =~ m|^N/A|;
+        $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
+            $CPAN::Frontend->mywarn("Strange distribution name [$s]");
+        CPAN->debug("s[$s]") if $CPAN::DEBUG;
+    }
+    $s;
+}
+
 #-> sub CPAN::Distribution::color_cmd_tmps ;
 sub color_cmd_tmps {
     my($self) = shift;
@@ -3300,15 +3510,27 @@ sub as_string {
 #-> sub CPAN::Distribution::containsmods ;
 sub containsmods {
   my $self = shift;
-  return if exists $self->{CONTAINSMODS};
+  return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
+  my $dist_id = $self->{ID};
   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
     my $mod_file = $mod->cpan_file or next;
-    my $dist_id = $self->{ID} or next;
     my $mod_id = $mod->{ID} or next;
     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
     # sleep 1;
     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
   }
+  keys %{$self->{CONTAINSMODS}};
+}
+
+#-> sub CPAN::Distribution::uptodate ;
+sub uptodate {
+    my($self) = @_;
+    my $c;
+    foreach $c ($self->containsmods) {
+        my $obj = CPAN::Shell->expandany($c);
+        return 0 unless $obj->uptodate;
+    }
+    return 1;
 }
 
 #-> sub CPAN::Distribution::called_for ;
@@ -3318,6 +3540,22 @@ sub called_for {
     return $self->{CALLED_FOR};
 }
 
+#-> sub CPAN::Distribution::my_chdir ;
+sub safe_chdir {
+    my($self,$todir) = @_;
+    # we die if we cannot chdir and we are debuggable
+    Carp::confess("safe_chdir called without todir argument")
+          unless defined $todir and length $todir;
+    if (chdir $todir) {
+        $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+            if $CPAN::DEBUG;
+    } else {
+        my $cwd = CPAN::anycwd();
+        $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+                               qq{to todir[$todir]: $!});
+    }
+}
+
 #-> sub CPAN::Distribution::get ;
 sub get {
     my($self) = @_;
@@ -3327,6 +3565,12 @@ sub get {
            "Is already unwrapped into directory $self->{'build_dir'}";
        $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
     }
+    my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
+
+    #
+    # Get the file on local disk
+    #
+
     my($local_file);
     my($local_wanted) =
         MM->catfile(
@@ -3339,31 +3583,41 @@ sub get {
     $self->debug("Doing localize") if $CPAN::DEBUG;
     $local_file =
        CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
-           or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
-    return if $CPAN::Signal;
+              or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
+    $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
     $self->{localfile} = $local_file;
-    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
-    my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
-    $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
-    chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
-    my $packagedir;
+    return if $CPAN::Signal;
 
-    $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
+    #
+    # Check integrity
+    #
     if ($CPAN::META->has_inst("MD5")) {
        $self->debug("MD5 is installed, verifying");
        $self->verifyMD5;
     } else {
        $self->debug("MD5 is NOT installed");
     }
+    return if $CPAN::Signal;
+
+    #
+    # Create a clean room and go there
+    #
+    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
+    my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
+    $self->safe_chdir($builddir);
     $self->debug("Removing tmp") if $CPAN::DEBUG;
     File::Path::rmtree("tmp");
     mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
-    chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
-    $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
-    return if $CPAN::Signal;
-    if (! $local_file) {
-       Carp::croak "bad download, can't do anything :-(\n";
-    } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
+    if ($CPAN::Signal){
+        $self->safe_chdir($sub_wd);
+        return;
+    }
+    $self->safe_chdir("tmp");
+
+    #
+    # Unpack the goods
+    #
+    if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
         $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
        $self->untar_me($local_file);
     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
@@ -3373,81 +3627,106 @@ sub get {
        $self->pm2dir_me($local_file);
     } else {
        $self->{archived} = "NO";
+        $self->safe_chdir($sub_wd);
+        return;
     }
-    my $cwd = File::Spec->updir;
-    chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
-    if ($self->{archived} ne 'NO') {
-      $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
-      chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
-      # Let's check if the package has its own directory.
-      my $dh = DirHandle->new(File::Spec->curdir)
-          or Carp::croak("Couldn't opendir .: $!");
-      my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
-      $dh->close;
-      my ($distdir,$packagedir);
-      if (@readdir == 1 && -d $readdir[0]) {
+
+    # we are still in the tmp directory!
+    # Let's check if the package has its own directory.
+    my $dh = DirHandle->new(File::Spec->curdir)
+        or Carp::croak("Couldn't opendir .: $!");
+    my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+    $dh->close;
+    my ($distdir,$packagedir);
+    if (@readdir == 1 && -d $readdir[0]) {
         $distdir = $readdir[0];
         $packagedir = MM->catdir($builddir,$distdir);
+        $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
+            if $CPAN::DEBUG;
         -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
                                                     "$packagedir\n");
         File::Path::rmtree($packagedir);
         rename($distdir,$packagedir) or
             Carp::confess("Couldn't rename $distdir to $packagedir: $!");
-      } else {
-          my $userid = $self->cpan_userid;
-          unless ($userid) {
-              CPAN->debug("no userid? self[$self]");
-              $userid = "anon";
-          }
-          my $pragmatic_dir = $userid . '000';
-          $pragmatic_dir =~ s/\W_//g;
-          $pragmatic_dir++ while -d "../$pragmatic_dir";
-          $packagedir = MM->catdir($builddir,$pragmatic_dir);
-          File::Path::mkpath($packagedir);
-          my($f);
-          for $f (@readdir) { # is already without "." and ".."
-              my $to = MM->catdir($packagedir,$f);
-              rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
-          }
-      }
-      $self->{'build_dir'} = $packagedir;
-      $cwd = File::Spec->updir;
-      chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
-
-      $self->debug("Changed directory to .. (self[$self]=[".
-                   $self->as_string."])") if $CPAN::DEBUG;
-      File::Path::rmtree("tmp");
-      if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
-        $CPAN::Frontend->myprint("Going to unlink $local_file\n");
-        unlink $local_file or Carp::carp "Couldn't unlink $local_file";
-      }
-      my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
-      unless (-f $makefilepl) {
+        $self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
+                             $distdir,
+                             $packagedir,
+                             -e $packagedir,
+                             -d $packagedir,
+                            )) if $CPAN::DEBUG;
+    } else {
+        my $userid = $self->cpan_userid;
+        unless ($userid) {
+            CPAN->debug("no userid? self[$self]");
+            $userid = "anon";
+        }
+        my $pragmatic_dir = $userid . '000';
+        $pragmatic_dir =~ s/\W_//g;
+        $pragmatic_dir++ while -d "../$pragmatic_dir";
+        $packagedir = MM->catdir($builddir,$pragmatic_dir);
+        $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
+        File::Path::mkpath($packagedir);
+        my($f);
+        for $f (@readdir) { # is already without "." and ".."
+            my $to = MM->catdir($packagedir,$f);
+            rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+        }
+    }
+    if ($CPAN::Signal){
+        $self->safe_chdir($sub_wd);
+        return;
+    }
+
+    $self->{'build_dir'} = $packagedir;
+    $self->safe_chdir(File::Spec->updir);
+    File::Path::rmtree("tmp");
+
+    my($mpl) = MM->catfile($packagedir,"Makefile.PL");
+    my($mpl_exists) = -f $mpl;
+    unless ($mpl_exists) {
+        # Steffen's stupid NFS has problems to see an existing
+        # Makefile.PL such a short time after the directory was
+        # renamed. Maybe this trick helps
+        $dh = DirHandle->new($packagedir)
+            or Carp::croak("Couldn't opendir $packagedir: $!");
+        $mpl_exists = grep /^Makefile\.PL$/, $dh->read;
+    }
+    unless ($mpl_exists) {
+        $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
+                             $mpl,
+                             CPAN::anycwd(),
+                            )) if $CPAN::DEBUG;
         my($configure) = MM->catfile($packagedir,"Configure");
         if (-f $configure) {
-          # do we have anything to do?
-          $self->{'configure'} = $configure;
+            # do we have anything to do?
+            $self->{'configure'} = $configure;
         } elsif (-f MM->catfile($packagedir,"Makefile")) {
-          $CPAN::Frontend->myprint(qq{
+            $CPAN::Frontend->myprint(qq{
 Package comes with a Makefile and without a Makefile.PL.
 We\'ll try to build it with that Makefile then.
 });
-          $self->{writemakefile} = "YES";
-          sleep 2;
+            $self->{writemakefile} = "YES";
+            sleep 2;
         } else {
-          my $cf = $self->called_for || "unknown";
-          if ($cf =~ m|/|) {
-              $cf =~ s|.*/||;
-              $cf =~ s|\W.*||;
-          }
-          $cf =~ s|[/\\:]||g; # risk of filesystem damage
-          $cf = "unknown" unless length($cf);
-          $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
-  Writing one on our own (calling it $cf)\n});
-          $self->{had_no_makefile_pl}++;
-          my $fh = FileHandle->new(">$makefilepl")
-              or Carp::croak("Could not open >$makefilepl");
-          $fh->print(
+            my $cf = $self->called_for || "unknown";
+            if ($cf =~ m|/|) {
+                $cf =~ s|.*/||;
+                $cf =~ s|\W.*||;
+            }
+            $cf =~ s|[/\\:]||g; # risk of filesystem damage
+            $cf = "unknown" unless length($cf);
+            $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
+  (The test -f "$mpl" returned false.)
+  Writing one on our own (setting NAME to $cf)\a\n});
+            $self->{had_no_makefile_pl}++;
+            sleep 3;
+
+            # Writing our own Makefile.PL
+
+            my $fh = FileHandle->new;
+            $fh->open(">$mpl")
+                or Carp::croak("Could not open >$mpl: $!");
+            $fh->print(
 qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
 # because there was no Makefile.PL supplied.
 # Autogenerated on: }.scalar localtime().qq{
@@ -3456,10 +3735,10 @@ use ExtUtils::MakeMaker;
 WriteMakefile(NAME => q[$cf]);
 
 });
-          $fh->close;
+            $fh->close;
         }
-      }
     }
+
     return $self;
 }
 
@@ -3531,9 +3810,7 @@ Please define it with "o conf shell <your shell>"
     my $dist = $self->id;
     my $dir  = $self->dir or $self->get;
     $dir = $self->dir;
-    my $getcwd;
-    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
-    my $pwd  = CPAN->$getcwd();
+    my $pwd  = CPAN::anycwd();
     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
     system($CPAN::Config->{'shell'}) == 0
@@ -3567,9 +3844,7 @@ sub cvs_import {
     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
               "$cvs_dir", $userid, "v$version");
 
-    my $getcwd;
-    $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
-    my $pwd  = CPAN->$getcwd();
+    my $pwd  = CPAN::anycwd();
     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
 
     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
@@ -3630,7 +3905,7 @@ sub verifyMD5 {
        $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
     }
     my($lc_want,$lc_file,@local,$basename);
-    @local = split("/",$self->{ID});
+    @local = split("/",$self->id);
     pop @local;
     push @local, "CHECKSUMS";
     $lc_want =
@@ -3647,6 +3922,7 @@ sub verifyMD5 {
     $lc_file = CPAN::FTP->localize("authors/id/@local",
                                   $lc_want,1);
     unless ($lc_file) {
+        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
        $local[-1] .= ".gz";
        $lc_file = CPAN::FTP->localize("authors/id/@local",
                                       "$lc_want.gz",1);
@@ -3824,8 +4100,7 @@ sub isa_perl {
 sub perl {
     my($self) = @_;
     my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
-    my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
-    my $pwd  = CPAN->$getcwd();
+    my $pwd  = CPAN::anycwd();
     my $candidate = MM->catfile($pwd,$^X);
     $perl ||= $candidate if MM->maybe_command($candidate);
     unless ($perl) {
@@ -4339,7 +4614,7 @@ sub as_string {
 #-> sub CPAN::Bundle::contains ;
 sub contains {
   my($self) = @_;
-  my($parsefile) = $self->inst_file;
+  my($parsefile) = $self->inst_file || "";
   my($id) = $self->id;
   $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
   unless ($parsefile) {
@@ -4403,8 +4678,7 @@ sub find_bundle_file {
     my $manifest = MM->catfile($where,"MANIFEST");
     unless (-f $manifest) {
        require ExtUtils::Manifest;
-       my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
-       my $cwd = CPAN->$getcwd();
+       my $cwd = CPAN::anycwd();
        chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
        ExtUtils::Manifest::mkmanifest();
        chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
@@ -4439,21 +4713,37 @@ sub find_bundle_file {
     Carp::croak("Couldn't find a Bundle file in $where");
 }
 
-# needs to work slightly different from Module::inst_file because of
-# cpan_home/Bundle/ directory.
+# needs to work quite differently from Module::inst_file because of
+# cpan_home/Bundle/ directory and the possibility that we have
+# shadowing effect. As it makes no sense to take the first in @INC for
+# Bundles, we parse them all for $VERSION and take the newest.
 
 #-> sub CPAN::Bundle::inst_file ;
 sub inst_file {
     my($self) = @_;
-    return $self->{INST_FILE} if
-        exists $self->{INST_FILE} && $self->{INST_FILE};
     my($inst_file);
     my(@me);
     @me = split /::/, $self->id;
     $me[-1] .= ".pm";
-    $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, @me);
-    return $self->{INST_FILE} = $inst_file if -f $inst_file;
-    $self->SUPER::inst_file;
+    my($incdir,$bestv);
+    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+        my $bfile = MM->catfile($incdir, @me);
+        CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
+        next unless -f $bfile;
+        my $foundv = MM->parse_version($bfile);
+        if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
+            $self->{INST_FILE} = $bfile;
+            $self->{INST_VERSION} = $bestv = $foundv;
+        }
+    }
+    $self->{INST_FILE};
+}
+
+#-> sub CPAN::Bundle::inst_version ;
+sub inst_version {
+    my($self) = @_;
+    $self->inst_file; # finds INST_VERSION as side effect
+    $self->{INST_VERSION};
 }
 
 #-> sub CPAN::Bundle::rematein ;
@@ -4564,6 +4854,18 @@ sub install {
 #-> sub CPAN::Bundle::clean ;
 sub clean   { shift->rematein('clean',@_); }
 
+#-> sub CPAN::Bundle::uptodate ;
+sub uptodate {
+    my($self) = @_;
+    return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
+    my $c;
+    foreach $c ($self->contains) {
+        my $obj = CPAN::Shell->expandany($c);
+        return 0 unless $obj->uptodate;
+    }
+    return 1;
+}
+
 #-> sub CPAN::Bundle::readme ;
 sub readme  {
     my($self) = @_;
@@ -4579,8 +4881,8 @@ package CPAN::Module;
 # sub cpan_userid { shift->{RO}{CPAN_USERID} }
 sub userid {
     my $self = shift;
-    return unless exists $self->{RO}{userid};
-    $self->{RO}{userid};
+    return unless exists $self->{RO}; # should never happen
+    return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
 }
 sub description { shift->{RO}{description} }
 
@@ -4624,7 +4926,23 @@ sub as_glimpse {
     my(@m);
     my $class = ref($self);
     $class =~ s/^CPAN:://;
-    push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
+    my $color_on = "";
+    my $color_off = "";
+    if (
+        $CPAN::Shell::COLOR_REGISTERED
+        &&
+        $CPAN::META->has_inst("Term::ANSIColor")
+        &&
+        $self->{RO}{description}
+       ) {
+        $color_on = Term::ANSIColor::color("green");
+        $color_off = Term::ANSIColor::color("reset");
+    }
+    push @m, sprintf("%-15s %s%-15s%s (%s)\n",
+                     $class,
+                     $color_on,
+                     $self->id,
+                     $color_off,
                     $self->cpan_file);
     join "", @m;
 }
@@ -4689,8 +5007,45 @@ sub as_string {
                     $stati{$self->{RO}{stati}}
                    ) if $self->{RO}{statd};
     my $local_file = $self->inst_file;
-    if ($local_file) {
-      $self->{MANPAGE} ||= $self->manpage_headline($local_file);
+    unless ($self->{MANPAGE}) {
+        if ($local_file) {
+            $self->{MANPAGE} = $self->manpage_headline($local_file);
+        } else {
+            # If we have already untarred it, we should look there
+            my $dist = $CPAN::META->instance('CPAN::Distribution',
+                                             $self->cpan_file);
+            # warn "dist[$dist]";
+            # mff=manifest file; mfh=manifest handle
+            my($mff,$mfh);
+            if ($dist->{build_dir} and
+                -f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")) and
+                $mfh = FileHandle->new($mff)
+               ) {
+                CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
+                my $lfre = $self->id; # local file RE
+                $lfre =~ s/::/./g;
+                $lfre .= "\\.pm\$";
+                my($lfl); # local file file
+                local $/ = "\n";
+                my(@mflines) = <$mfh>;
+                for (@mflines) {
+                    s/^\s+//;
+                    s/\s.*//s;
+                }
+                while (length($lfre)>5 and !$lfl) {
+                    ($lfl) = grep /$lfre/, @mflines;
+                    CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
+                    $lfre =~ s/.+?\.//;
+                }
+                $lfl =~ s/\s.*//; # remove comments
+                $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
+                my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
+                # warn "lfl_abs[$lfl_abs]";
+                if (-f $lfl_abs) {
+                    $self->{MANPAGE} = $self->manpage_headline($lfl_abs);
+                }
+            }
+        }
     }
     my($item);
     for $item (qw/MANPAGE/) {
@@ -4744,26 +5099,29 @@ sub cpan_file    {
     }
     if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
        return $self->{RO}{CPAN_FILE};
-    } elsif ( defined $self->userid ) {
-       my $fullname = $CPAN::META->instance("CPAN::Author",
-                                             $self->userid)->fullname;
-       my $email = $CPAN::META->instance("CPAN::Author",
-                                          $self->userid)->email;
-       unless (defined $fullname && defined $email) {
-            my $userid = $self->userid;
-           return sprintf("Contact Author %s (Try 'a %s')",
-                           $userid,
-                           $userid,
-                          );
-       }
-       return "Contact Author $fullname <$email>";
     } else {
-       return "N/A";
+        my $userid = $self->userid;
+        if ( $userid ) {
+            if ($CPAN::META->exists("CPAN::Author",$userid)) {
+                my $author = $CPAN::META->instance("CPAN::Author",
+                                                   $userid);
+                my $fullname = $author->fullname;
+                my $email = $author->email;
+                unless (defined $fullname && defined $email) {
+                    return sprintf("Contact Author %s",
+                                   $userid,
+                                  );
+                }
+                return "Contact Author $fullname <$email>";
+            } else {
+                return "UserID $userid";
+            }
+        } else {
+            return "N/A";
+        }
     }
 }
 
-*name = \&cpan_file;
-
 #-> sub CPAN::Module::cpan_version ;
 sub cpan_version {
     my $self = shift;
@@ -5087,10 +5445,29 @@ sub DESTROY {
 # CPAN::Tarzip::untar
 sub untar {
   my($class,$file) = @_;
+  my($prefer) = 0;
+
   if (0) { # makes changing order easier
+  } elsif ($BUGHUNTING){
+      $prefer=2;
   } elsif (MM->maybe_command($CPAN::Config->{gzip})
-      &&
-      MM->maybe_command($CPAN::Config->{'tar'})) {
+           &&
+           MM->maybe_command($CPAN::Config->{'tar'})) {
+      # should be default until Archive::Tar is fixed
+      $prefer = 1;
+  } elsif (
+           $CPAN::META->has_inst("Archive::Tar")
+           &&
+           $CPAN::META->has_inst("Compress::Zlib") ) {
+      $prefer = 2;
+  } else {
+    $CPAN::Frontend->mydie(qq{
+CPAN.pm needs either both external programs tar and gzip installed or
+both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
+is available. Can\'t continue.
+});
+  }
+  if ($prefer==1) { # 1 => external gzip+tar
     my($system);
     my $is_compressed = $class->gtest($file);
     if ($is_compressed) {
@@ -5122,33 +5499,43 @@ sub untar {
     } else {
         return 1;
     }
-  } elsif ($CPAN::META->has_inst("Archive::Tar")
-      &&
-      $CPAN::META->has_inst("Compress::Zlib") ) {
+  } elsif ($prefer==2) { # 2 => modules
     my $tar = Archive::Tar->new($file,1);
     my $af; # archive file
     my @af;
-    for $af ($tar->list_files) {
-        if ($af =~ m!^(/|\.\./)!) {
-            $CPAN::Frontend->mydie("ALERT: Archive contains ".
-                                   "illegal member [$af]");
+    if ($BUGHUNTING) {
+        # RCS 1.337 had this code, it turned out unacceptable slow but
+        # it revealed a bug in Archive::Tar. Code is only here to hunt
+        # the bug again. It should never be enabled in published code.
+        # GDGraph3d-0.53 was an interesting case according to Larry
+        # Virden.
+        warn(">>>Bughunting code enabled<<< " x 20);
+        for $af ($tar->list_files) {
+            if ($af =~ m!^(/|\.\./)!) {
+                $CPAN::Frontend->mydie("ALERT: Archive contains ".
+                                       "illegal member [$af]");
+            }
+            $CPAN::Frontend->myprint("$af\n");
+            $tar->extract($af); # slow but effective for finding the bug
+            return if $CPAN::Signal;
         }
-        $CPAN::Frontend->myprint("$af\n");
-        push @af, $af;
-        return if $CPAN::Signal;
+    } else {
+        for $af ($tar->list_files) {
+            if ($af =~ m!^(/|\.\./)!) {
+                $CPAN::Frontend->mydie("ALERT: Archive contains ".
+                                       "illegal member [$af]");
+            }
+            $CPAN::Frontend->myprint("$af\n");
+            push @af, $af;
+            return if $CPAN::Signal;
+        }
+        $tar->extract(@af);
     }
-    $tar->extract(@af);
 
     ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
         if ($^O eq 'MacOS');
 
     return 1;
-  } else {
-    $CPAN::Frontend->mydie(qq{
-CPAN.pm needs either both external programs tar and gzip installed or
-both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
-is available. Can\'t continue.
-});
   }
 }
 
@@ -5226,9 +5613,8 @@ sub float2vv {
     my($self,$n) = @_;
     my($rev) = int($n);
     $rev ||= 0;
-    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits so that
-                                          # architecture cannot
-                                          # influnce
+    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+                                          # architecture influence
     $mantissa ||= 0;
     $mantissa .= "0" while length($mantissa)%3;
     my $ret = "v" . $rev;
@@ -5310,11 +5696,11 @@ the make processes and deletes excess space according to a simple FIFO
 mechanism.
 
 For extended searching capabilities there's a plugin for CPAN available,
-L<CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine that indexes
-all documents available in CPAN authors directories. If C<CPAN::WAIT>
-is installed on your system, the interactive shell of <CPAN.pm> will
-enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands which send
-queries to the WAIT server that has been configured for your
+L<C<CPAN::WAIT>|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
+that indexes all documents available in CPAN authors directories. If
+C<CPAN::WAIT> is installed on your system, the interactive shell of
+CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
+which send queries to the WAIT server that has been configured for your
 installation.
 
 All other methods provided are accessible in a programmer style and in an
@@ -5333,6 +5719,10 @@ command completion.
 Once you are on the command line, type 'h' and the rest should be
 self-explanatory.
 
+The function call C<shell> takes two optional arguments, one is the
+prompt, the second is the default initial command line (the latter
+only works if a real ReadLine interface module is installed).
+
 The most common uses of the interactive modes are
 
 =over 2
@@ -5519,6 +5909,12 @@ list of CPAN::Module objects according to the C<@things> arguments
 given. In scalar context it only returns the first element of the
 list.
 
+=item expandany(@things)
+
+Like expand, but returns objects of the appropriate type, i.e.
+CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
+CPAN::Distribution objects fro distributions.
+
 =item Programming Examples
 
 This enables the programmer to do operations that combine
@@ -5549,13 +5945,13 @@ all modules that need updating. First a quick and dirty way:
 
     perl -e 'use CPAN; CPAN::Shell->r;'
 
-If you don't want to get any output if all modules are up to date, you
-can parse the output of above command for the regular expression
-//modules are up to date// and decide to mail the output only if it
-doesn't match. Ick?
+If you don't want to get any output in the case that all modules are
+up to date, you can parse the output of above command for the regular
+expression //modules are up to date// and decide to mail the output
+only if it doesn't match. Ick?
 
 If you prefer to do it more in a programmer style in one single
-process, maybe something like this suites you better:
+process, maybe something like this suits you better:
 
   # list all modules on my disk that have newer versions on CPAN
   for $mod (CPAN::Shell->expand("Module","/./")){
@@ -5581,7 +5977,299 @@ tricks:
 
 =back
 
-=head2 Methods in the four Classes
+=head2 Methods in the other Classes
+
+The programming interface for the classes CPAN::Module,
+CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
+beta and partially even alpha. In the following paragraphs only those
+methods are documented that have proven useful over a longer time and
+thus are unlikely to change.
+
+=over
+
+=item CPAN::Author::as_glimpse()
+
+Returns a one-line description of the author
+
+=item CPAN::Author::as_string()
+
+Returns a multi-line description of the author
+
+=item CPAN::Author::email()
+
+Returns the author's email address
+
+=item CPAN::Author::fullname()
+
+Returns the author's name
+
+=item CPAN::Author::name()
+
+An alias for fullname
+
+=item CPAN::Bundle::as_glimpse()
+
+Returns a one-line description of the bundle
+
+=item CPAN::Bundle::as_string()
+
+Returns a multi-line description of the bundle
+
+=item CPAN::Bundle::clean()
+
+Recursively runs the C<clean> method on all items contained in the bundle.
+
+=item CPAN::Bundle::contains()
+
+Returns a list of objects' IDs contained in a bundle. The associated
+objects may be bundles, modules or distributions.
+
+=item CPAN::Bundle::force($method,@args)
+
+Forces CPAN to perform a task that normally would have failed. Force
+takes as arguments a method name to be called and any number of
+additional arguments that should be passed to the called method. The
+internals of the object get the needed changes so that CPAN.pm does
+not refuse to take the action. The C<force> is passed recursively to
+all contained objects.
+
+=item CPAN::Bundle::get()
+
+Recursively runs the C<get> method on all items contained in the bundle
+
+=item CPAN::Bundle::inst_file()
+
+Returns the highest installed version of the bundle in either @INC or
+C<$CPAN::Config->{cpan_home}>. Note that this is different from
+CPAN::Module::inst_file.
+
+=item CPAN::Bundle::inst_version()
+
+Like CPAN::Bundle::inst_file, but returns the $VERSION
+
+=item CPAN::Bundle::uptodate()
+
+Returns 1 if the bundle itself and all its members are uptodate.
+
+=item CPAN::Bundle::install()
+
+Recursively runs the C<install> method on all items contained in the bundle
+
+=item CPAN::Bundle::make()
+
+Recursively runs the C<make> method on all items contained in the bundle
+
+=item CPAN::Bundle::readme()
+
+Recursively runs the C<readme> method on all items contained in the bundle
+
+=item CPAN::Bundle::test()
+
+Recursively runs the C<test> method on all items contained in the bundle
+
+=item CPAN::Distribution::as_glimpse()
+
+Returns a one-line description of the distribution
+
+=item CPAN::Distribution::as_string()
+
+Returns a multi-line description of the distribution
+
+=item CPAN::Distribution::clean()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make clean> there.
+
+=item CPAN::Distribution::containsmods()
+
+Returns a list of IDs of modules contained in a distribution file.
+Only works for distributions listed in the 02packages.details.txt.gz
+file. This typically means that only the most recent version of a
+distribution is covered.
+
+=item CPAN::Distribution::cvs_import()
+
+Changes to the directory where the distribution has been unpacked and
+runs something like
+
+    cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
+
+there.
+
+=item CPAN::Distribution::dir()
+
+Returns the directory into which this distribution has been unpacked.
+
+=item CPAN::Distribution::force($method,@args)
+
+Forces CPAN to perform a task that normally would have failed. Force
+takes as arguments a method name to be called and any number of
+additional arguments that should be passed to the called method. The
+internals of the object get the needed changes so that CPAN.pm does
+not refuse to take the action.
+
+=item CPAN::Distribution::get()
+
+Downloads the distribution from CPAN and unpacks it. Does nothing if
+the distribution has already been downloaded and unpacked within the
+current session.
+
+=item CPAN::Distribution::install()
+
+Changes to the directory where the distribution has been unpacked and
+runs the external command C<make install> there. If C<make> has not
+yet been run, it will be run first. A C<make test> will be issued in
+any case and if this fails, the install will be cancelled. The
+cancellation can be avoided by letting C<force> run the C<install> for
+you.
+
+=item CPAN::Distribution::isa_perl()
+
+Returns 1 if this distribution file seems to be a perl distribution.
+Normally this is derived from the file name only, but the index from
+CPAN can contain a hint to achieve a return value of true for other
+filenames too.
+
+=item CPAN::Distribution::look()
+
+Changes to the directory where the distribution has been unpacked and
+opens a subshell there. Exiting the subshell returns.
+
+=item CPAN::Distribution::make()
+
+First runs the C<get> method to make sure the distribution is
+downloaded and unpacked. Changes to the directory where the
+distribution has been unpacked and runs the external commands C<perl
+Makefile.PL> and C<make> there.
+
+=item CPAN::Distribution::prereq_pm()
+
+Returns the hash reference that has been announced by a distribution
+as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
+attempt has been made to C<make> the distribution. Returns undef
+otherwise.
+
+=item CPAN::Distribution::readme()
+
+Downloads the README file associated with a distribution and runs it
+through the pager specified in C<$CPAN::Config->{pager}>.
+
+=item CPAN::Distribution::test()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make test> there.
+
+=item CPAN::Distribution::uptodate()
+
+Returns 1 if all the modules contained in the distribution are
+uptodate. Relies on containsmods.
+
+=item CPAN::Index::force_reload()
+
+Forces a reload of all indices.
+
+=item CPAN::Index::reload()
+
+Reloads all indices if they have been read more than
+C<$CPAN::Config->{index_expire}> days.
+
+=item CPAN::InfoObj::dump()
+
+CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
+inherit this method. It prints the data structure associated with an
+object. Useful for debugging. Note: the data structure is considered
+internal and thus subject to change without notice.
+
+=item CPAN::Module::as_glimpse()
+
+Returns a one-line description of the module
+
+=item CPAN::Module::as_string()
+
+Returns a multi-line description of the module
+
+=item CPAN::Module::clean()
+
+Runs a clean on the distribution associated with this module.
+
+=item CPAN::Module::cpan_file()
+
+Returns the filename on CPAN that is associated with the module.
+
+=item CPAN::Module::cpan_version()
+
+Returns the latest version of this module available on CPAN.
+
+=item CPAN::Module::cvs_import()
+
+Runs a cvs_import on the distribution associated with this module.
+
+=item CPAN::Module::description()
+
+Returns a 44 chracter description of this module. Only available for
+modules listed in The Module List (CPAN/modules/00modlist.long.html
+or 00modlist.long.txt.gz)
+
+=item CPAN::Module::force($method,@args)
+
+Forces CPAN to perform a task that normally would have failed. Force
+takes as arguments a method name to be called and any number of
+additional arguments that should be passed to the called method. The
+internals of the object get the needed changes so that CPAN.pm does
+not refuse to take the action.
+
+=item CPAN::Module::get()
+
+Runs a get on the distribution associated with this module.
+
+=item CPAN::Module::inst_file()
+
+Returns the filename of the module found in @INC. The first file found
+is reported just like perl itself stops searching @INC when it finds a
+module.
+
+=item CPAN::Module::inst_version()
+
+Returns the version number of the module in readable format.
+
+=item CPAN::Module::install()
+
+Runs an C<install> on the distribution associated with this module.
+
+=item CPAN::Module::look()
+
+Changes to the directory where the distribution assoicated with this
+module has been unpacked and opens a subshell there. Exiting the
+subshell returns.
+
+=item CPAN::Module::make()
+
+Runs a C<make> on the distribution associated with this module.
+
+=item CPAN::Module::manpage_headline()
+
+If module is installed, peeks into the module's manpage, reads the
+headline and returns it. Moreover, if the module has been downloaded
+within this session, does the equivalent on the downloaded module even
+if it is not installed.
+
+=item CPAN::Module::readme()
+
+Runs a C<readme> on the distribution associated with this module.
+
+=item CPAN::Module::test()
+
+Runs a C<test> on the distribution associated with this module.
+
+=item CPAN::Module::uptodate()
+
+Returns 1 if the module is installed and up-to-date.
+
+=item CPAN::Module::userid()
+
+Returns the author's ID of the module.
+
+=back
 
 =head2 Cache Manager
 
@@ -5734,6 +6422,8 @@ defined:
                      ('follow' automatically, 'ask' me, or 'ignore')
   scan_cache        controls scanning of cache ('atstart' or 'never')
   tar                location of external program tar
+  term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
+                     (and nonsense for characters outside latin range)
   unzip              location of external program unzip
   urllist           arrayref to nearby CPAN sites (or equivalent locations)
   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
@@ -5821,8 +6511,8 @@ oneliners.
 
 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
 
-To populate a freshly installed perl with my favorite modules is pretty
-easiest by maintaining a private bundle definition file. To get a useful
+Populating a freshly installed perl with my favorite modules is pretty
+easy if you maintain a private bundle definition file. To get a useful
 blueprint of a bundle definition file, the command autobundle can be used
 on the CPAN shell command line. This command writes a bundle definition
 file for all modules that are installed for the currently running perl
@@ -5834,7 +6524,7 @@ Bundle/my_bundle.pm. With a clever bundle file you can then simply say
 
 then answer a few questions and then go out for a coffee.
 
-Maintaining a bundle definition file means to keep track of two
+Maintaining a bundle definition file means keeping track of two
 things: dependencies and interactivity. CPAN.pm sometimes fails on
 calculating dependencies because not all modules define all MakeMaker
 attributes correctly, so a bundle definition file should specify
@@ -5843,7 +6533,7 @@ annoying that many distributions need some interactive configuring. So
 what I try to accomplish in my private bundle file is to have the
 packages that need to be configured early in the file and the gentle
 ones later, so I can go out after a few minutes and leave CPAN.pm
-unattained.
+untended.
 
 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
 
@@ -5905,7 +6595,7 @@ the firewall as if it is not there.
 
 This is the firewall implemented in the Linux kernel, it allows you to
 hide a complete network behind one IP address. With this firewall no
-special compiling is need as you can access hosts directly.
+special compiling is needed as you can access hosts directly.
 
 =back
 
@@ -5933,8 +6623,10 @@ Your milage may vary...
 
 =over
 
-=item 1) I installed a new version of module X but CPAN keeps saying,
-      I have the old version installed
+=item 1)
+
+I installed a new version of module X but CPAN keeps saying,
+I have the old version installed
 
 Most probably you B<do> have the old version installed. This can
 happen if a module installs itself into a different directory in the
@@ -5946,14 +6638,35 @@ many people add this argument permanently by configuring
 
   o conf make_install_arg UNINST=1
 
-=item 2) So why is UNINST=1 not the default?
+=item 2)
+
+So why is UNINST=1 not the default?
 
 Because there are people who have their precise expectations about who
 may install where in the @INC path and who uses which @INC array. In
 fine tuned environments C<UNINST=1> can cause damage.
 
-=item 3) When I install bundles or multiple modules with one command
-      there is too much output to keep track of
+=item 3)
+
+I want to clean up my mess, and install a new perl along with
+all modules I have. How do I go about it?
+
+Run the autobundle command for your old perl and optionally rename the
+resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
+with the Configure option prefix, e.g.
+
+    ./Configure -Dprefix=/usr/local/perl-5.6.78.9
+
+Install the bundle file you produced in the first step with something like
+
+    cpan> install Bundle::mybundle
+
+and you're done.
+
+=item 4)
+
+When I install bundles or multiple modules with one command
+there is too much output to keep track of.
 
 You may want to configure something like
 
@@ -5963,8 +6676,9 @@ You may want to configure something like
 so that STDOUT is captured in a file for later inspection.
 
 
-=item 4) I am not root, how can I install a module in a personal
-      directory?
+=item 5)
+
+I am not root, how can I install a module in a personal directory?
 
 You will most probably like something like this:
 
@@ -5987,14 +6701,17 @@ or setting the PERL5LIB environment variable.
 Another thing you should bear in mind is that the UNINST parameter
 should never be set if you are not root.
 
-=item 5) How to get a package, unwrap it, and make a change before
-      building it?
+=item 6)
+
+How to get a package, unwrap it, and make a change before building it?
 
   look Sybase::Sybperl
 
-=item 6) I installed a Bundle and had a couple of fails. When I
-      retried, everything resolved nicely. Can this be fixed to work
-      on first try?
+=item 7)
+
+I installed a Bundle and had a couple of fails. When I
+retried, everything resolved nicely. Can this be fixed to work
+on first try?
 
 The reason for this is that CPAN does not know the dependencies of all
 modules when it starts out. To decide about the additional items to
@@ -6011,12 +6728,38 @@ definition file manually. It is planned to improve the metadata
 situation for dependencies on CPAN in general, but this will still
 take some time.
 
-=item 7) In our intranet we have many modules for internal use. How
-      can I integrate these modules with CPAN.pm but without uploading
-      the modules to CPAN?
+=item 8)
+
+In our intranet we have many modules for internal use. How
+can I integrate these modules with CPAN.pm but without uploading
+the modules to CPAN?
 
 Have a look at the CPAN::Site module.
 
+=item 9)
+
+When I run CPAN's shell, I get error msg about line 1 to 4,
+setting meta input/output via the /etc/inputrc file.
+
+Some versions of readline are picky about capitalization in the
+/etc/inputrc file and specifically RedHat 6.2 comes with a
+/etc/inputrc that contains the word C<on> in lowercase. Change the
+occurrences of C<on> to C<On> and the bug should disappear.
+
+=item 10)
+
+Some authors have strange characters in their names.
+
+Internally CPAN.pm uses the UTF-8 charset. If your terminal is
+expecting ISO-8859-1 charset, a converter can be activated by setting
+term_is_latin to a true value in your config file. One way of doing so
+would be
+
+    cpan> ! $CPAN::Config->{term_is_latin}=1
+
+Extended support for converters will be made available as soon as perl
+becomes stable with regard to charset issues.
+
 =back
 
 =head1 BUGS
index 9f8366e..7cf01cd 100644 (file)
@@ -1,3 +1,4 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 package CPAN::Mirrored::By;
 
 sub new { 
@@ -16,7 +17,7 @@ use FileHandle ();
 use File::Basename ();
 use File::Path ();
 use vars qw($VERSION);
-$VERSION = substr q$Revision: 1.46 $, 10;
+$VERSION = substr q$Revision: 1.51 $, 10;
 
 =head1 NAME
 
@@ -174,6 +175,9 @@ disable the cache scanning with 'never'.
     } while ($ans ne 'atstart' && $ans ne 'never');
     $CPAN::Config->{scan_cache} = $ans;
 
+    #
+    # cache_metadata
+    #
     print qq{
 
 To considerably speed up the initial CPAN shell startup, it is
@@ -189,6 +193,30 @@ is not available, the normal index mechanism will be used.
     $CPAN::Config->{cache_metadata} = ($ans =~ /^\s*y/i ? 1 : 0);
 
     #
+    # term_is_latin
+    #
+    print qq{
+
+The next option deals with the charset your terminal supports. In
+general CPAN is English speaking territory, thus the charset does not
+matter much, but some of the aliens out there who upload their
+software to CPAN bear names that are outside the ASCII range. If your
+terminal supports UTF-8, you say no to the next question, if it
+supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it
+supports neither nor, your answer does not matter, you will not be
+able to read the names of some authors anyway. If you answer no, nmes
+will be output in UTF-8.
+
+};
+
+    defined($default = $CPAN::Config->{term_is_latin}) or $default = 1;
+    do {
+        $ans = prompt("Your terminal expects ISO-8859-1 (yes/no)?",
+                      ($default ? 'yes' : 'no'));
+    } while ($ans !~ /^\s*[yn]/i);
+    $CPAN::Config->{term_is_latin} = ($ans =~ /^\s*y/i ? 1 : 0);
+
+    #
     # prerequisites_policy
     # Do we follow PREREQ_PM?
     #
@@ -216,10 +244,11 @@ policy to one of the three values.
 
     print qq{
 
-The CPAN module will need a few external programs to work
-properly. Please correct me, if I guess the wrong path for a program.
-Don\'t panic if you do not have some of them, just press ENTER for
-those.
+The CPAN module will need a few external programs to work properly.
+Please correct me, if I guess the wrong path for a program. Don\'t
+panic if you do not have some of them, just press ENTER for those. To
+disable the use of a download program, you can type a space followed
+by ENTER.
 
 };
 
@@ -228,7 +257,7 @@ those.
     my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
     local $^W = $old_warn;
     my $progname;
-    for $progname (qw/gzip tar unzip make lynx ncftpget ncftp ftp/){
+    for $progname (qw/gzip tar unzip make lynx wget ncftpget ncftp ftp/){
       if ($^O eq 'MacOS') {
           $CPAN::Config->{$progname} = 'not_here';
           next;
@@ -286,9 +315,9 @@ those.
     print qq{
 
 Every Makefile.PL is run by perl in a separate process. Likewise we
-run \'make\' and \'make install\' in processes. If you have any parameters
-\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to
-the calls, please specify them here.
+run \'make\' and \'make install\' in processes. If you have any
+parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to pass
+to the calls, please specify them here.
 
 If you don\'t understand this question, just press ENTER.
 
@@ -296,13 +325,29 @@ If you don\'t understand this question, just press ENTER.
 
     $default = $CPAN::Config->{makepl_arg} || "";
     $CPAN::Config->{makepl_arg} =
-       prompt("Parameters for the 'perl Makefile.PL' command?",$default);
+       prompt("Parameters for the 'perl Makefile.PL' command?
+Typical frequently used settings:
+
+    POLLUTE=1        increasing backwards compatibility
+    LIB=~/perl       non-root users (please see manual for more hints)
+
+Your choice: ",$default);
     $default = $CPAN::Config->{make_arg} || "";
-    $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default);
+    $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?
+Typical frequently used setting:
+
+    -j3              dual processor system
+
+Your choice: ",$default);
 
     $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || "";
     $CPAN::Config->{make_install_arg} =
-       prompt("Parameters for the 'make install' command?",$default);
+       prompt("Parameters for the 'make install' command?
+Typical frequently used setting:
+
+    UNINST=1         to always uninstall potentially conflicting files
+
+Your choice: ",$default);
 
     #
     # Alarm period
@@ -376,8 +421,26 @@ sub conf_sites {
   }
   my $loopcount = 0;
   local $^T = time;
+  my $overwrite_local = 0;
+  if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) {
+      my $mtime = localtime((stat _)[9]);
+      my $prompt = qq{Found $mby as of $mtime
+
+  I\'d use that as a database of CPAN sites. If that is OK for you,
+  please answer 'y', but if you want me to get a new database now,
+  please answer 'n' to the following question.
+
+  Shall I use the local database in $mby?};
+      my $ans = prompt($prompt,"y");
+      $overwrite_local = 1 unless $ans =~ /^y/i;
+  }
   while ($mby) {
-    if ( ! -f $mby ){
+    if ($overwrite_local) {
+      print qq{Trying to overwrite $mby
+};
+      $mby = CPAN::FTP->localize($m,$mby,3);
+      $overwrite_local = 0;
+    } elsif ( ! -f $mby ){
       print qq{You have no $mby
   I\'m trying to fetch one
 };
@@ -519,7 +582,8 @@ http: -- that host a CPAN mirror.
         }
     }
     push (@urls, map ("$_ (previous pick)", @previous_urls));
-    my $prompt = "Select as many URLs as you like";
+    my $prompt = "Select as many URLs as you like,
+put them on one line, separated by blanks";
     if (@previous_urls) {
        $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
                              (scalar @urls));
@@ -547,11 +611,15 @@ Please enter your CPAN site:};
             $ans =~ s|/?\z|/|; # has to end with one slash
             $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
             if ($ans =~ /^\w+:\/./) {
-               push @urls, $ans unless $seen{$ans}++;
+                push @urls, $ans unless $seen{$ans}++;
             } else {
-                print qq{"$ans" doesn\'t look like an URL at first sight.
-I\'ll ignore it for now.  You can add it to $INC{'CPAN/MyConfig.pm'}
-later if you\'re sure it\'s right.\n};
+                printf(qq{"%s" doesn\'t look like an URL at first sight.
+I\'ll ignore it for now.
+You can add it to your %s
+later if you\'re sure it\'s right.\n},
+                       $ans,
+                       $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'} || "configuration file",
+                      );
             }
         }
     } while $ans || !%seen;
index 43524dd..69d477b 100644 (file)
@@ -1,5 +1,7 @@
 package Carp;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 carp    - warn of errors (from perspective of caller)
@@ -68,6 +70,8 @@ $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
 $Verbose = 0;          # If true then make shortmess call longmess instead
 
+$CarpInternal{Carp}++;
+
 require Exporter;
 @ISA = ('Exporter');
 @EXPORT = qw(confess croak carp);
index 8cfdcb4..b551560 100644 (file)
+# Carp::Heavy uses some variables in common with Carp.
 package Carp;
 
 =head1 NAME
 
-Carp::Heavy - Carp guts
+Carp heavy machinery - no user serviceable parts inside
 
-=head1 SYNOPIS
+=cut
 
-(internal use only)
+# use strict; # not yet
+
+# On one line so MakeMaker will see it.
+use Carp;  our $VERSION = $Carp::VERSION;
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose);
+
+sub caller_info {
+  my $i = shift(@_) + 1;
+  package DB;
+  my %call_info;
+  @call_info{
+    qw(pack file line sub has_args wantarray evaltext is_require)
+  } = caller($i);
+  
+  unless (defined $call_info{pack}) {
+    return ();
+  }
+
+  my $sub_name = Carp::get_subname(\%call_info);
+  if ($call_info{has_args}) {
+    # Reuse the @args array to avoid warnings. :-)
+    local @args = map {Carp::format_arg($_)} @args;
+    if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
+      $#args = $MaxArgNums;
+      push @args, '...';
+    }
+    # Push the args onto the subroutine
+    $sub_name .= '(' . join (',', @args) . ')';
+  }
+  $call_info{sub_name} = $sub_name;
+  return wantarray() ? %call_info : \%call_info;
+}
 
-=head1 DESCRIPTION
+# Transform an argument to a function into a string.
+sub format_arg {
+  my $arg = shift;
+  if (not defined($arg)) {
+    $arg = 'undef';
+  }
+  elsif (ref($arg)) {
+    $arg .= ''; # Make it a string;
+  }
+  $arg =~ s/'/\\'/g;
+  $arg = str_len_trim($arg, $MaxLenArg);
+  
+  # Quote it?
+  $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
+
+  # The following handling of "control chars" is direct from
+  # the original code - I think it is broken on Unicode though.
+  # Suggestions?
+  $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+  return $arg;
+}
 
-No user-serviceable parts inside.
+# Takes an inheritance cache and a package and returns
+# an anon hash of known inheritances and anon array of
+# inheritances which consequences have not been figured
+# for.
+sub get_status {
+    my $cache = shift;
+    my $pkg = shift;
+    $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
+    return @{$cache->{$pkg}};
+}
 
-=cut
+# Takes the info from caller() and figures out the name of
+# the sub/require/eval
+sub get_subname {
+  my $info = shift;
+  if (defined($info->{eval})) {
+    my $eval = $info->{eval};
+    if ($info->{is_require}) {
+      return "require $eval";
+    }
+    else {
+      $eval =~ s/([\\\'])/\\$1/g;
+      return str_len_trim($eval, $MaxEvalLen);
+    }
+  }
 
-# This package is heavily used. Be small. Be fast. Be good.
+  return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
+}
 
-# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
-# _almost_ complete understanding of the package.  Corrections and
-# comments are welcome.
+# Figures out what call (from the point of view of the caller)
+# the long error backtrace should start at.
+sub long_error_loc {
+  my $i;
+  my $lvl = $CarpLevel;
+  {
+    my $pkg = caller(++$i);
+    unless(defined($pkg)) {
+      # This *shouldn't* happen.
+      if (%Internal) {
+        local %Internal;
+        $i = long_error_loc();
+        last;
+      }
+      else {
+        # OK, now I am irritated.
+        return 2;
+      }
+    }
+    redo if $CarpInternal{$pkg};
+    redo unless 0 > --$lvl;
+    redo if $Internal{$pkg};
+  }
+  return $i - 1;
+}
 
-# longmess() crawls all the way up the stack reporting on all the function
-# calls made.  The error string, $error, is originally constructed from the
-# arguments passed into longmess() via confess(), cluck() or shortmess().
-# This gets appended with the stack trace messages which are generated for
-# each function call on the stack.
 
 sub longmess_heavy {
-    return @_ if ref $_[0];
-    my $error = join '', @_;
-    my $mess = "";
-    my $i = 1 + $CarpLevel;
-    my ($pack,$file,$line,$sub,$hargs,$eval,$require);
-    my (@a);
-    #
-    # crawl up the stack....
-    #
-    while (do { { package DB; @a = caller($i++) } } ) {
-       # get copies of the variables returned from caller()
-       ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
-       #
-       # if the $error error string is newline terminated then it
-       # is copied into $mess.  Otherwise, $mess gets set (at the end of
-       # the 'else' section below) to one of two things.  The first time
-       # through, it is set to the "$error at $file line $line" message.
-       # $error is then set to 'called' which triggers subsequent loop
-       # iterations to append $sub to $mess before appending the "$error
-       # at $file line $line" which now actually reads "called at $file line
-       # $line".  Thus, the stack trace message is constructed:
-       #
-       #        first time: $mess  = $error at $file line $line
-       #  subsequent times: $mess .= $sub $error at $file line $line
-       #                                  ^^^^^^
-       #                                 "called"
-       if ($error =~ m/\n$/) {
-           $mess .= $error;
-       } else {
-           # Build a string, $sub, which names the sub-routine called.
-           # This may also be "require ...", "eval '...' or "eval {...}"
-           if (defined $eval) {
-               if ($require) {
-                   $sub = "require $eval";
-               } else {
-                   $eval =~ s/([\\\'])/\\$1/g;
-                   if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
-                       substr($eval,$MaxEvalLen) = '...';
-                   }
-                   $sub = "eval '$eval'";
-               }
-           } elsif ($sub eq '(eval)') {
-               $sub = 'eval {...}';
-           }
-           # if there are any arguments in the sub-routine call, format
-           # them according to the format variables defined earlier in
-           # this file and join them onto the $sub sub-routine string
-           if ($hargs) {
-               # we may trash some of the args so we take a copy
-               @a = @DB::args; # must get local copy of args
-               # don't print any more than $MaxArgNums
-               if ($MaxArgNums and @a > $MaxArgNums) {
-                   # cap the length of $#a and set the last element to '...'
-                   $#a = $MaxArgNums;
-                   $a[$#a] = "...";
-               }
-               for (@a) {
-                   # set args to the string "undef" if undefined
-                   $_ = "undef", next unless defined $_;
-                   if (ref $_) {
-                       # force reference to string representation
-                       $_ .= '';
-                       s/'/\\'/g;
-                   }
-                   else {
-                       s/'/\\'/g;
-                       # terminate the string early with '...' if too long
-                       substr($_,$MaxArgLen) = '...'
-                           if $MaxArgLen and $MaxArgLen < length;
-                   }
-                   # 'quote' arg unless it looks like a number
-                   $_ = "'$_'" unless /^-?[\d.]+$/;
-                   # print high-end chars as 'M-<char>'
-                   s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
-                   # print remaining control chars as ^<char>
-                   s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
-               }
-               # append ('all', 'the', 'arguments') to the $sub string
-               $sub .= '(' . join(', ', @a) . ')';
-           }
-           # here's where the error message, $mess, gets constructed
-           $mess .= "\t$sub " if $error eq "called";
-           $mess .= "$error at $file line $line";
-           if (defined &Thread::tid) {
-               my $tid = Thread->self->tid;
-               $mess .= " thread $tid" if $tid;
-           }
-           $mess .= "\n";
-       }
-       # we don't need to print the actual error message again so we can
-       # change this to "called" so that the string "$error at $file line
-       # $line" makes sense as "called at $file line $line".
-       $error = "called";
-    }
-    $mess || $error;
+  return @_ if ref($_[0]); # WHAT IS THIS FOR???
+  my $i = long_error_loc();
+  return ret_backtrace($i, @_);
 }
 
+# Returns a full stack backtrace starting from where it is
+# told.
+sub ret_backtrace {
+  my ($i, @error) = @_;
+  my $mess;
+  my $err = join '', @error;
+  $i++;
+
+  my $tid_msg = '';
+  if (defined &Thread::tid) {
+    my $tid = Thread->self->tid;
+    $tid_msg = " thread $tid" if $tid;
+  }
+
+  if ($err =~ /\n$/) {
+    $mess = $err;
+  }
+  else {
+    my %i = caller_info($i);
+    $mess = "$err at $i{file} line $i{line}$tid_msg\n";
+  }
+
+  while (my %i = caller_info(++$i)) {
+      $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
+  }
+  
+  return $mess || $err;
+}
 
-# ancestors() returns the complete set of ancestors of a module
-
-sub ancestors($$);
-
-sub ancestors($$){
-    my( $pack, $href ) = @_;
-    if( @{"${pack}::ISA"} ){
-       my $risa = \@{"${pack}::ISA"};
-       my %tree  = ();
-       @tree{@$risa} = ();
-       foreach my $mod ( @$risa ){
-           # visit ancestors - if not already in the gallery
-           if( ! defined( $$href{$mod} ) ){
-               my @ancs = ancestors( $mod, $href );
-               @tree{@ancs} = ();
-           }
-       }
-       return ( keys( %tree ) );
-    } else {
-       return ();
-    }
+sub ret_summary {
+  my ($i, @error) = @_;
+  my $mess;
+  my $err = join '', @error;
+  $i++;
+
+  my $tid_msg = '';
+  if (defined &Thread::tid) {
+    my $tid = Thread->self->tid;
+    $tid_msg = " thread $tid" if $tid;
+  }
+
+  my %i = caller_info($i);
+  return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+
+sub short_error_loc {
+  my $cache;
+  my $i = 1;
+  my $lvl = $CarpLevel;
+  {
+    my $called = caller($i++);
+    my $caller = caller($i);
+    return 0 unless defined($caller); # What happened?
+    redo if $Internal{$caller};
+    redo if $CarpInternal{$called};
+    redo if trusts($called, $caller, $cache);
+    redo if trusts($caller, $called, $cache);
+    redo unless 0 > --$lvl;
+  }
+  return $i - 1;
+}
+
+sub shortmess_heavy {
+  return longmess_heavy(@_) if $Verbose;
+  return @_ if ref($_[0]); # WHAT IS THIS FOR???
+  my $i = short_error_loc();
+  if ($i) {
+    ret_summary($i, @_);
+  }
+  else {
+    longmess_heavy(@_);
+  }
 }
 
+# If a string is too long, trims it with ...
+sub str_len_trim {
+  my $str = shift;
+  my $max = shift || 0;
+  if (2 < $max and $max < length($str)) {
+    substr($str, $max - 3) = '...';
+  }
+  return $str;
+}
 
-# shortmess() is called by carp() and croak() to skip all the way up to
-# the top-level caller's package and report the error from there.  confess()
-# and cluck() generate a full stack trace so they call longmess() to
-# generate that.  In verbose mode shortmess() calls longmess() so
-# you always get a stack trace
-
-sub shortmess_heavy {  # Short-circuit &longmess if called via multiple packages
-    goto &longmess_heavy if $Verbose;
-    return @_ if ref $_[0];
-    my $error = join '', @_;
-    my ($prevpack) = caller(1);
-    my $extra = $CarpLevel;
-
-    my @Clans = ( $prevpack );
-    my $i = 2;
-    my ($pack,$file,$line);
-    # when reporting an error, we want to report it from the context of the
-    # calling package.  So what is the calling package?  Within a module,
-    # there may be many calls between methods and perhaps between sub-classes
-    # and super-classes, but the user isn't interested in what happens
-    # inside the package.  We start by building a hash array which keeps
-    # track of all the packages to which the calling package belongs.  We
-    # do this by examining its @ISA variable.  Any call from a base class
-    # method (one of our caller's @ISA packages) can be ignored
-    my %isa;
-
-    # merge all the caller's @ISA packages and ancestors into %isa.
-    my @pars = ancestors( $prevpack, \%isa );
-    @isa{@pars} = () if @pars;
-    $isa{$prevpack} = 1;
-
-    # now we crawl up the calling stack and look at all the packages in
-    # there.  For each package, we look to see if it has an @ISA and then
-    # we see if our caller features in that list.  That would imply that
-    # our caller is a derived class of that package and its calls can also
-    # be ignored
-CALLER:
-    while (($pack,$file,$line) = caller($i++)) {
-
-        # Chances are, the caller's caller (or its caller...) is already
-        # in the gallery - if so, ignore this caller.
-        next if exists( $isa{$pack} );
-
-        # no: collect this module's ancestors.
-        my @i = ancestors( $pack, \%isa );
-        my %i;
-        if( @i ){
-           @i{@i} = ();
-            # check whether our representative of one of the clans is
-            # in this family tree.
-           foreach my $cl (@Clans){
-                if( exists( $i{$cl} ) ){
-                   # yes: merge all of the family tree into %isa
-                   @isa{@i,$pack} = ();
-                   # and here's where we do some more ignoring...
-                   # if the package in question is one of our caller's
-                   # base or derived packages then we can ignore it (skip it)
-                   # and go onto the next.
-                   next CALLER if exists( $isa{$pack} );
-                   last;
-               }
-            }
-       }
-
-       # Hey!  We've found a package that isn't one of our caller's
-       # clan....but wait, $extra refers to the number of 'extra' levels
-       # we should skip up.  If $extra > 0 then this is a false alarm.
-       # We must merge the package into the %isa hash (so we can ignore it
-       # if it pops up again), decrement $extra, and continue.
-       if ($extra-- > 0) {
-           push( @Clans, $pack );
-           @isa{@i,$pack} = ();
-       }
-       else {
-           # OK!  We've got a candidate package.  Time to construct the
-           # relevant error message and return it.
-           my $msg;
-           $msg = "$error at $file line $line";
-           if (defined &Thread::tid) {
-               my $tid = Thread->self->tid;
-               $mess .= " thread $tid" if $tid;
-           }
-           $msg .= "\n";
-           return $msg;
-       }
+# Takes two packages and an optional cache.  Says whether the
+# first inherits from the second.
+#
+# Recursive versions of this have to work to avoid certain
+# possible endless loops, and when following long chains of
+# inheritance are less efficient.
+sub trusts {
+    my $child = shift;
+    my $parent = shift;
+    my $cache = shift || {};
+    my ($known, $partial) = get_status($cache, $child);
+    # Figure out consequences until we have an answer
+    while (@$partial and not exists $known->{$parent}) {
+        my $anc = shift @$partial;
+        next if exists $known->{$anc};
+        $known->{$anc}++;
+        my ($anc_knows, $anc_partial) = get_status($cache, $anc);
+        my @found = keys %$anc_knows;
+        @$known{@found} = ();
+        push @$partial, @$anc_partial;
     }
+    return exists $known->{$parent};
+}
 
-    # uh-oh!  It looks like we crawled all the way up the stack and
-    # never found a candidate package.  Oh well, let's call longmess
-    # to generate a full stack trace.  We use the magical form of 'goto'
-    # so that this shortmess() function doesn't appear on the stack
-    # to further confuse longmess() about it's calling package.
-    goto &longmess_heavy;
+# Takes a package and gives a list of those trusted directly
+sub trusts_directly {
+    my $class = shift;
+    return @{"$class\::ISA"};
 }
 
 1;
+
index ac1fb47..185a8ff 100644 (file)
@@ -14,7 +14,7 @@ require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(struct);
 
-$VERSION = '0.58';
+$VERSION = '0.59';
 
 ## Tested on 5.002 and 5.003 without class membership tests:
 my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
@@ -51,6 +51,20 @@ sub printem {
     sub DESTROY { }
 }
 
+sub import {
+    my $self = shift;
+
+    if ( @_ == 0 ) {
+      $self->export_to_level( 1, $self, @EXPORT );
+    } elsif ( @_ == 1 ) {
+       # This is admittedly a little bit silly:
+       # do we ever export anything else than 'struct'...?
+      $self->export_to_level( 1, $self, @_ );
+    } else {
+      &struct;
+    }
+}
+
 sub struct {
 
     # Determine parameter list structure, one of:
@@ -76,6 +90,7 @@ sub struct {
         $class = (caller())[0];
         @decls = @_;
     }
+
     _usage_error() if @decls % 2 == 1;
 
     # Ensure we are not, and will not be, a subclass.
@@ -242,6 +257,9 @@ Class::Struct - declare struct-like datatypes as Perl classes
             # declare struct, based on array, implicit class name:
     struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
 
+    # Declare struct at compile time
+    use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ];
+    use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... };
 
     package Myobj;
     use Class::Struct;
@@ -262,14 +280,13 @@ Class::Struct - declare struct-like datatypes as Perl classes
                                     # hash type accessor:
     $hash_ref = $obj->h;                # reference to whole hash
     $hash_element_value = $obj->h('x'); # hash element value
-    $obj->h('x', 'new value');        # assign to hash element
+    $obj->h('x', 'new value');          # assign to hash element
 
                                     # class type accessor:
     $element_value = $obj->c;           # object reference
     $obj->c->method(...);               # call method of object
     $obj->c(new My_Other_Class);        # assign a new object
 
-
 =head1 DESCRIPTION
 
 C<Class::Struct> exports a single function, C<struct>.
@@ -287,7 +304,6 @@ same name in the package.  (See Example 2.)
 
 Each element's type can be scalar, array, hash, or class.
 
-
 =head2 The C<struct()> function
 
 The C<struct> function has three forms of parameter-list.
@@ -326,6 +342,15 @@ element name will be defined as an accessor method unless a
 method by that name is explicitly defined; in the latter case, a
 warning is issued if the warning flag (B<-w>) is set.
 
+=head2 Class Creation at Compile Time
+
+C<Class::Struct> can create your class at compile time.  The main reason
+for doing this is obvious, so your class acts like every other class in
+Perl.  Creating your class at compile time will make the order of events
+similar to using any other class ( or Perl module ).
+
+There is no significant speed gain between compile time and run time
+class creation, there is just a new, more standard order of events.
 
 =head2 Element Types and Accessor Methods
 
@@ -410,7 +435,6 @@ contents of that hash are passed to the element's own constructor.
 
 See Example 3 below for an example of initialization.
 
-
 =head1 EXAMPLES
 
 =over
@@ -444,7 +468,6 @@ type C<timeval>.
     $t->ru_stime->tv_secs(5);
     $t->ru_stime->tv_usecs(0);
 
-
 =item Example 2
 
 An accessor function can be redefined in order to provide
@@ -492,7 +515,6 @@ Note that the initializer for a nested struct is specified
 as an anonymous hash of initializers, which is passed on to the nested
 struct's constructor.
 
-
     use Class::Struct;
 
     struct Breed =>
@@ -524,6 +546,9 @@ struct's constructor.
 
 =head1 Author and Modification History
 
+Modified by Casey Tweten, 2000-11-08, v0.59.
+
+    Added the ability for compile time class creation.
 
 Modified by Damian Conway, 1999-03-05, v0.58.
 
@@ -541,7 +566,6 @@ Modified by Damian Conway, 1999-03-05, v0.58.
     Previously these were returned as a reference to a reference
     to the element.
 
-
 Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
 
     members() function removed.
@@ -553,7 +577,6 @@ Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
     Class name to struct() made optional.
     Diagnostic checks added.
 
-
 Originally C<Class::Template> by Dean Roehrich.
 
     # Template.pm   --- struct/member template builder
index 7279591..4a263cd 100644 (file)
@@ -70,7 +70,7 @@ use strict;
 
 use Carp;
 
-our $VERSION = '2.03';
+our $VERSION = '2.04';
 
 use base qw/ Exporter /;
 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
@@ -99,6 +99,9 @@ unless(defined &cwd) {
     }
 }
 
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
 
 # By Brandon S. Allbery
 #
@@ -188,7 +191,7 @@ sub chdir_init {
 }
 
 sub chdir {
-    my $newdir = @? ? shift : '';      # allow for no arg (chdir to HOME dir)
+    my $newdir = @_ ? shift : '';      # allow for no arg (chdir to HOME dir)
     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
     chdir_init() unless $chdir_init;
     return 0 unless CORE::chdir $newdir;
@@ -408,7 +411,8 @@ sub _epoc_cwd {
         *abs_path      = \&fast_abs_path;
     }
     elsif ($^O eq 'epoc') {
-        *getcwd        = \&_epoc_cwd;
+        *cwd            = \&_epoc_cwd;
+        *getcwd                = \&_epoc_cwd;
         *fastgetcwd    = \&_epoc_cwd;
         *fastcwd       = \&_epoc_cwd;
         *abs_path      = \&fast_abs_path;
index 047755d..12ee6c6 100644 (file)
@@ -1,5 +1,7 @@
 package DirHandle;
 
+our $VERSION = '1.00';
+
 =head1 NAME 
 
 DirHandle - supply object methods for directory handles
index 475f4ff..c8282cf 100644 (file)
@@ -1,6 +1,7 @@
 use 5.005_64;                  # for (defined ref) and $#$v and our
 package Dumpvalue;
 use strict;
+our $VERSION = '1.00';
 our(%address, $stab, @stab, %stab, %subs);
 
 # translate control chars to ^X - Randal Schwartz
index 1ebc3de..77f27c5 100644 (file)
@@ -1,5 +1,7 @@
 package English;
 
+our $VERSION = '1.00';
+
 require Exporter;
 @ISA = (Exporter);
 
index d1ee071..eb9187f 100644 (file)
@@ -1,5 +1,7 @@
 package Env;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 Env - perl module that imports environment variables as scalars or arrays
index 585109e..ad6cdef 100644 (file)
@@ -2,88 +2,85 @@ package Exporter;
 
 require 5.001;
 
-$ExportLevel = 0;
-$Verbose ||= 0;
-$VERSION = '5.562';
+use strict;
+no strict 'refs';
+
+our $Debug = 0;
+our $ExportLevel = 0;
+our $Verbose ||= 0;
+our $VERSION = '5.562';
 
 sub export_to_level {
   require Exporter::Heavy;
-  goto &heavy_export_to_level;
+  goto &Exporter::Heavy::heavy_export_to_level;
 }
 
 sub export {
   require Exporter::Heavy;
-  goto &heavy_export;
+  goto &Exporter::Heavy::heavy_export;
 }
 
 sub export_tags {
   require Exporter::Heavy;
-  _push_tags((caller)[0], "EXPORT",    \@_);
+  Exporter::Heavy::_push_tags((caller)[0], "EXPORT",    \@_);
 }
 
 sub export_ok_tags {
   require Exporter::Heavy;
-  _push_tags((caller)[0], "EXPORT_OK", \@_);
+  Exporter::Heavy::_push_tags((caller)[0], "EXPORT_OK", \@_);
 }
 
 sub import {
   my $pkg = shift;
   my $callpkg = caller($ExportLevel);
-  *exports = *{"$pkg\::EXPORT"};
+
+  my($exports, $export_cache) = (\@{"$pkg\::EXPORT"},
+                                 \%{"$pkg\::EXPORT"});
   # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
-  *fail = *{"$pkg\::EXPORT_FAIL"};
+  my($fail) = \@{"$pkg\::EXPORT_FAIL"};
   return export $pkg, $callpkg, @_
-    if $Verbose or $Debug or @fail > 1;
-  my $args = @_ or @_ = @exports;
+    if $Verbose or $Debug or @$fail > 1;
+  my $args = @_ or @_ = @$exports;
   
-  if ($args and not %exports) {
-    foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) {
+  if ($args and not %$export_cache) {
+    foreach my $sym (@$exports, @{"$pkg\::EXPORT_OK"}) {
       $sym =~ s/^&//;
-      $exports{$sym} = 1;
+      $export_cache->{$sym} = 1;
     }
   }
   if ($Verbose or $Debug 
-      or grep {/\W/ or $args and not exists $exports{$_}
-              or @fail and $_ eq $fail[0]
+      or grep {/\W/ or $args and not exists $export_cache->{$_}
+              or @$fail and $_ eq $fail->[0]
               or (@{"$pkg\::EXPORT_OK"} 
                   and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) {
     return export $pkg, $callpkg, ($args ? @_ : ());
   }
-  #local $SIG{__WARN__} = sub {require Carp; goto &Carp::carp};
   local $SIG{__WARN__} = 
        sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp};
-  foreach $sym (@_) {
+  foreach my $sym (@_) {
     # shortcut for the common case of no type character
     *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"};
   }
 }
 
-1;
 
-# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
-# package main; eval(join('',<DATA>)) or die $@ unless caller;
-__END__
-package Test;
-$INC{'Exporter.pm'} = 1;
-@ISA = qw(Exporter);
-@EXPORT      = qw(A1 A2 A3 A4 A5);
-@EXPORT_OK   = qw(B1 B2 B3 B4 B5);
-%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]);
-@EXPORT_FAIL = qw(B4);
-Exporter::export_ok_tags('T3', 'unknown_tag');
+# Default methods
+
 sub export_fail {
-    map { "Test::$_" } @_      # edit symbols just as an example
+    my $self = shift;
+    @_;
 }
 
-package main;
-$Exporter::Verbose = 1;
-#import Test;
-#import Test qw(X3);           # export ok via export_ok_tags()
-#import Test qw(:T1 !A2 /5/ !/3/ B5);
-import Test qw(:T2 !B4);
-import Test qw(:T2);           # should fail
+
+sub require_version {
+    require Exporter::Heavy;
+    goto &Exporter::Heavy::require_version;
+}
+
+
 1;
 
+
 =head1 NAME
 
 Exporter - Implements default import method for modules
index 6647f70..39bce2d 100644 (file)
@@ -1,4 +1,12 @@
-package Exporter;
+package Exporter::Heavy;
+
+use strict;
+no strict 'refs';
+
+# On one line so MakeMaker will see it.
+require Exporter;  our $VERSION = $Exporter::VERSION;
+
+our $Verbose;
 
 =head1 NAME
 
@@ -41,16 +49,17 @@ sub heavy_export {
 
     my($pkg, $callpkg, @imports) = @_;
     my($type, $sym, $oops);
-    *exports = *{"${pkg}::EXPORT"};
+    my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
+                                   \%{"${pkg}::EXPORT"});
 
     if (@imports) {
-       if (!%exports) {
-           grep(s/^&//, @exports);
-           @exports{@exports} = (1) x @exports;
+       if (!%$export_cache) {
+           s/^&// foreach @$exports;
+           @{$export_cache}{@$exports} = (1) x @$exports;
            my $ok = \@{"${pkg}::EXPORT_OK"};
            if (@$ok) {
-               grep(s/^&//, @$ok);
-               @exports{@$ok} = (1) x @$ok;
+               s/^&// foreach @$ok;
+               @{$export_cache}{@$ok} = (1) x @$ok;
            }
        }
 
@@ -66,7 +75,7 @@ sub heavy_export {
 
                if ($spec =~ s/^://){
                    if ($spec eq 'DEFAULT'){
-                       @names = @exports;
+                       @names = @$exports;
                    }
                    elsif ($tagdata = $tagsref->{$spec}) {
                        @names = @$tagdata;
@@ -79,7 +88,7 @@ sub heavy_export {
                }
                elsif ($spec =~ m:^/(.*)/$:){
                    my $patn = $1;
-                   @allexports = keys %exports unless @allexports; # only do keys once
+                   @allexports = keys %$export_cache unless @allexports; # only do keys once
                    @names = grep(/$patn/, @allexports); # not anchored by default
                }
                else {
@@ -100,13 +109,13 @@ sub heavy_export {
        }
 
        foreach $sym (@imports) {
-           if (!$exports{$sym}) {
+           if (!$export_cache->{$sym}) {
                if ($sym =~ m/^\d/) {
                    $pkg->require_version($sym);
                    # If the version number was the only thing specified
                    # then we should act as if nothing was specified:
                    if (@imports == 1) {
-                       @imports = @exports;
+                       @imports = @$exports;
                        last;
                    }
                    # We need a way to emulate 'use Foo ()' but still
@@ -115,7 +124,7 @@ sub heavy_export {
                        @imports = ();
                        last;
                    }
-               } elsif ($sym !~ s/^&// || !$exports{$sym}) {
+               } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
                     require Carp;
                    Carp::carp(qq["$sym" is not exported by the $pkg module]);
                    $oops++;
@@ -128,21 +137,23 @@ sub heavy_export {
        }
     }
     else {
-       @imports = @exports;
+       @imports = @$exports;
     }
 
-    *fail = *{"${pkg}::EXPORT_FAIL"};
-    if (@fail) {
-       if (!%fail) {
+    my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
+                              \%{"${pkg}::EXPORT_FAIL"});
+
+    if (@$fail) {
+       if (!%$fail_cache) {
            # Build cache of symbols. Optimise the lookup by adding
            # barewords twice... both with and without a leading &.
-           # (Technique could be applied to %exports cache at cost of memory)
-           my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
+           # (Technique could be applied to $export_cache at cost of memory)
+           my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
            warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
-           @fail{@expanded} = (1) x @expanded;
+           @{$fail_cache}{@expanded} = (1) x @expanded;
        }
        my @failed;
-       foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
+       foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
        if (@failed) {
            @failed = $pkg->export_fail(@failed);
            foreach $sym (@failed) {
@@ -188,24 +199,19 @@ sub heavy_export_to_level
 
 sub _push_tags {
     my($pkg, $var, $syms) = @_;
-    my $nontag;
-    *export_tags = \%{"${pkg}::EXPORT_TAGS"};
+    my @nontag = ();
+    my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
     push(@{"${pkg}::$var"},
-       map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
-               (@$syms) ? @$syms : keys %export_tags);
-    if ($nontag and $^W) {
+       map { $export_tags->{$_} ? @{$export_tags->{$_}} 
+                                 : scalar(push(@nontag,$_),$_) }
+               (@$syms) ? @$syms : keys %$export_tags);
+    if (@nontag and $^W) {
        # This may change to a die one day
        require Carp;
-       Carp::carp("Some names are not tags");
+       Carp::carp(join(", ", @nontag)." are not tags of $pkg");
     }
 }
 
-# Default methods
-
-sub export_fail {
-    my $self = shift;
-    @_;
-}
 
 sub require_version {
     my($self, $wanted) = @_;
index 92db8c9..c496aa0 100644 (file)
@@ -262,8 +262,22 @@ sub inc_uninstall {
     }
 }
 
+sub run_filter {
+    my ($cmd, $src, $dest) = @_;
+    local *SRC, *CMD;
+    open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
+    open(SRC, $src)           || die "Cannot open $src: $!";
+    my $buf;
+    my $sz = 1024;
+    while (my $len = sysread(SRC, $buf, $sz)) {
+       syswrite(CMD, $buf, $len);
+    }
+    close SRC;
+    close CMD or die "Filter command '$cmd' failed for $src";
+}
+
 sub pm_to_blib {
-    my($fromto,$autodir) = @_;
+    my($fromto,$autodir,$pm_filter) = @_;
 
     use File::Basename qw(dirname);
     use File::Copy qw(copy);
@@ -286,23 +300,37 @@ sub pm_to_blib {
 
     mkpath($autodir,0,0755);
     foreach (keys %$fromto) {
-       next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
-       unless (compare($_,$fromto->{$_})){
-           print "Skip $fromto->{$_} (unchanged)\n";
+       my $dest = $fromto->{$_};
+       next if -f $dest && -M $dest < -M $_;
+
+       # When a pm_filter is defined, we need to pre-process the source first
+       # to determine whether it has changed or not.  Therefore, only perform
+       # the comparison check when there's no filter to be ran.
+       #    -- RAM, 03/01/2001
+
+       my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/;
+
+       if (!$need_filtering && 0 == compare($_,$dest)) {
+           print "Skip $dest (unchanged)\n";
            next;
        }
-       if (-f $fromto->{$_}){
-           forceunlink($fromto->{$_});
+       if (-f $dest){
+           forceunlink($dest);
+       } else {
+           mkpath(dirname($dest),0,0755);
+       }
+       if ($need_filtering) {
+           run_filter($pm_filter, $_, $dest);
+           print "$pm_filter <$_ >$dest\n";
        } else {
-           mkpath(dirname($fromto->{$_}),0,0755);
+           copy($_,$dest);
+           print "cp $_ $dest\n";
        }
-       copy($_,$fromto->{$_});
        my($mode,$atime,$mtime) = (stat)[2,8,9];
-       utime($atime,$mtime+$Is_VMS,$fromto->{$_});
-       chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
-       print "cp $_ $fromto->{$_}\n";
-       next unless /\.pm\z/;
-       autosplit($fromto->{$_},$autodir);
+       utime($atime,$mtime+$Is_VMS,$dest);
+       chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
+       next unless /\.pm$/;
+       autosplit($dest,$autodir);
     }
 }
 
@@ -392,6 +420,11 @@ no-don't-really-do-it-now switch.
 pm_to_blib() takes a hashref as the first argument and copies all keys
 of the hash to the corresponding values efficiently. Filenames with
 the extension pm are autosplit. Second argument is the autosplit
-directory.
+directory.  If third argument is not empty, it is taken as a filter command
+to be ran on each .pm file, the output of the command being what is finally
+copied, and the source for auto-splitting.
+
+You can have an environment variable PERL_INSTALL_ROOT set which will
+be prepended as a directory to each installed file (and directory).
 
 =cut
index b22363b..5e2f91d 100644 (file)
@@ -1,9 +1,30 @@
 package ExtUtils::Liblist;
 
+@ISA = qw(ExtUtils::Liblist::Kid File::Spec);
+
+sub lsdir {
+  shift;
+  my $rex = qr/$_[1]/;
+  opendir my $dir, $_[0];
+  grep /$rex/, readdir $dir;
+}
+
+sub file_name_is_absolute {
+  require File::Spec;
+  shift;
+  'File::Spec'->file_name_is_absolute(@_);
+}
+
+
+package ExtUtils::Liblist::Kid;
+
+# This kid package is to be used by MakeMaker.  It will not work if
+# $self is not a Makemaker.
+
 use 5.005_64;
 # Broken out of MakeMaker from version 4.11
 
-our $VERSION = substr q$Revision: 1.25 $, 10;
+our $VERSION = substr q$Revision: 1.26 $, 10;
 
 use Config;
 use Cwd 'cwd';
@@ -16,7 +37,7 @@ sub ext {
 }
 
 sub _unix_os2_ext {
-    my($self,$potential_libs, $verbose) = @_;
+    my($self,$potential_libs, $verbose, $give_libs) = @_;
     if ($^O =~ 'os2' and $Config{perllibs}) { 
        # Dynamic libraries are not transitive, so we may need including
        # the libraries linked against perl.dll again.
@@ -24,7 +45,7 @@ sub _unix_os2_ext {
        $potential_libs .= " " if $potential_libs;
        $potential_libs .= $Config{perllibs};
     }
-    return ("", "", "", "") unless $potential_libs;
+    return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
     warn "Potential libraries are '$potential_libs':\n" if $verbose;
 
     my($so)   = $Config{'so'};
@@ -39,6 +60,7 @@ sub _unix_os2_ext {
     my(@searchpath); # from "-L/path" entries in $potential_libs
     my(@libpath) = split " ", $Config{'libpth'};
     my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen);
+    my(@libs, %libs_seen);
     my($fullname, $thislib, $thispth, @fullname);
     my($pwd) = cwd(); # from Cwd.pm
     my($found) = 0;
@@ -132,6 +154,7 @@ sub _unix_os2_ext {
            warn "'-l$thislib' found at $fullname\n" if $verbose;
            my($fullnamedir) = dirname($fullname);
            push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++;
+           push @libs, $fullname unless $libs_seen{$fullname}++;
            $found++;
            $found_lib++;
 
@@ -179,19 +202,19 @@ sub _unix_os2_ext {
                     ."No library found for -l$thislib\n"
            unless $found_lib>0;
     }
-    return ('','','','') unless $found;
-    ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path));
+    return ('','','','', ($give_libs ? \@libs : ())) unless $found;
+    ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ()));
 }
 
 sub _win32_ext {
 
     require Text::ParseWords;
 
-    my($self, $potential_libs, $verbose) = @_;
+    my($self, $potential_libs, $verbose, $give_libs) = @_;
 
     # If user did not supply a list, we punt.
     # (caller should probably use the list in $Config{libs})
-    return ("", "", "", "") unless $potential_libs;
+    return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
 
     my $cc             = $Config{cc};
     my $VC             = 1 if $cc =~ /^cl/i;
@@ -201,6 +224,7 @@ sub _win32_ext {
     my $libs           = $Config{'perllibs'};
     my $libpth         = $Config{'libpth'};
     my $libext         = $Config{'lib_ext'} || ".lib";
+    my(@libs, %libs_seen);
 
     if ($libs and $potential_libs !~ /:nodefault/i) { 
        # If Config.pm defines a set of default libs, we always
@@ -298,6 +322,7 @@ sub _win32_ext {
            $found++;
            $found_lib++;
            push(@extralibs, $fullname);
+           push @libs, $fullname unless $libs_seen{$fullname}++;
            last;
        }
 
@@ -319,10 +344,11 @@ sub _win32_ext {
 
     }
 
-    return ('','','','') unless $found;
+    return ('','','','', ($give_libs ? \@libs : ())) unless $found;
 
     # make sure paths with spaces are properly quoted
     @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs;
+    @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs;
     $lib = join(' ',@extralibs);
 
     # normalize back to backward slashes (to help braindead tools)
@@ -331,12 +357,12 @@ sub _win32_ext {
     $lib =~ s,/,\\,g;
 
     warn "Result: $lib\n" if $verbose;
-    wantarray ? ($lib, '', $lib, '') : $lib;
+    wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib;
 }
 
 
 sub _vms_ext {
-  my($self, $potential_libs,$verbose) = @_;
+  my($self, $potential_libs,$verbose,$give_libs) = @_;
   my(@crtls,$crtlstr);
   my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} ||
                  $self->{CCFLAS}   || $Config{'ccflags'};
@@ -365,7 +391,7 @@ sub _vms_ext {
 
   unless ($potential_libs) {
     warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
-    return ('', '', $crtlstr, '');
+    return ('', '', $crtlstr, '', ($give_libs ? [] : ()));
   }
 
   my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
@@ -374,6 +400,7 @@ sub _vms_ext {
   # List of common Unix library names and there VMS equivalents
   # (VMS equivalent of '' indicates that the library is automatially
   # searched by the linker, and should be skipped here.)
+  my(@flibs, %libs_seen);
   my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '',
                  'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '',
                  'socket' => '', 'X11' => 'DECW$XLIBSHR',
@@ -478,6 +505,7 @@ sub _vms_ext {
         if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }  
         else                      { push    @{$found{$ctype}}, $cand; }
         warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1;
+       push @flibs, $name unless $libs_seen{$fullname}++;
         next LIB;
       }
     }
@@ -492,7 +520,7 @@ sub _vms_ext {
 
   $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
   warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
-  wantarray ? ($lib, '', $ldlib, '') : $lib;
+  wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib;
 }
 
 1;
@@ -507,20 +535,22 @@ ExtUtils::Liblist - determine libraries to use and how to use them
 
 C<require ExtUtils::Liblist;>
 
-C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);>
+C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose, $need_names);>
 
 =head1 DESCRIPTION
 
 This utility takes a list of libraries in the form C<-llib1 -llib2
--llib3> and prints out lines suitable for inclusion in an extension
+-llib3> and returns lines suitable for inclusion in an extension
 Makefile.  Extra library paths may be included with the form
 C<-L/another/path> this will affect the searches for all subsequent
 libraries.
 
-It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS,
-LDLOADLIBS, and LD_RUN_PATH.  Some of these don't mean anything
-on VMS and Win32.  See the details about those platform specifics
-below.
+It returns an array of four or five scalar values: EXTRALIBS,
+BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
+the array of the filenames of actual libraries.  Some of these don't
+mean anything unless on Unix.  See the details about those platform
+specifics below.  The list of the filenames is returned only if
+$need_names argument is true.
 
 Dependent libraries can be linked in one of three ways:
 
diff --git a/lib/ExtUtils/MANIFEST.SKIP b/lib/ExtUtils/MANIFEST.SKIP
new file mode 100644 (file)
index 0000000..a203d8f
--- /dev/null
@@ -0,0 +1,16 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+
+# Avoid Makemaker generated and utility files.
+^MANIFEST\.
+^Makefile$
+^blib/
+^MakeMaker-\d
+^pm_to_blib$
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
index a5ba410..abb491f 100644 (file)
@@ -1,12 +1,16 @@
 package ExtUtils::MM_Cygwin;
 
+use strict;
+
+our $VERSION = '1.00';
+
 use Config;
 #use Cwd;
 #use File::Basename;
 require Exporter;
 
-Exporter::import('ExtUtils::MakeMaker',
-       qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
 
 unshift @MM::ISA, 'ExtUtils::MM_Cygwin';
 
@@ -71,6 +75,8 @@ q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "],
 
     push(@m,"\n");
     if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) {
+        grep { $self->{MAN1PODS}{$_} =~ s/::/./g } keys %{$self->{MAN1PODS}};
+        grep { $self->{MAN3PODS}{$_} =~ s/::/./g } keys %{$self->{MAN3PODS}};
         push @m, "\t$self->{NOECHO}\$(POD2MAN) \\\n\t";
         push @m, join " \\\n\t", %{$self->{MAN1PODS}}, %{$self->{MAN3PODS}};
     }
index 430235a..c0c5240 100644 (file)
@@ -1,12 +1,16 @@
 package ExtUtils::MM_OS2;
 
+use strict;
+
+our $VERSION = '1.00';
+
 #use Config;
 #use Cwd;
 #use File::Basename;
 require Exporter;
 
-Exporter::import('ExtUtils::MakeMaker',
-       qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
 
 unshift @MM::ISA, 'ExtUtils::MM_OS2';
 
@@ -34,7 +38,7 @@ $self->{BASEEXT}.def: Makefile.PL
      ', "DL_VARS" => ', neatvalue($vars), ');\'
 ');
     }
-    if (%{$self->{IMPORTS}}) {
+    if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
        # Make import files (needed for static build)
        -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
        open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp";
@@ -57,7 +61,7 @@ $self->{BASEEXT}.def: Makefile.PL
 sub static_lib {
     my($self) = @_;
     my $old = $self->ExtUtils::MM_Unix::static_lib();
-    return $old unless %{$self->{IMPORTS}};
+    return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
     
     my @chunks = split /\n{2,}/, $old;
     shift @chunks unless length $chunks[0]; # Empty lines at the start
index 52862c5..d7dd720 100644 (file)
@@ -1,17 +1,19 @@
 package ExtUtils::MM_Unix;
 
+use strict;
+
 use Exporter ();
 use Config;
 use File::Basename qw(basename dirname fileparse);
 use DirHandle;
 use strict;
-use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT
-           $Verbose %pm %static $Xsubpp_Version);
+our ($Is_Mac,$Is_OS2,$Is_VMS,$Is_Win32,$Is_Dos,$Is_PERL_OBJECT,
+           $Verbose,%pm,%static,$Xsubpp_Version);
 
-$VERSION = substr q$Revision: 1.12603 $, 10;
-# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $
+our $VERSION = '1.12603';
 
-Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw($Verbose &neatvalue));
 
 $Is_OS2 = $^O eq 'os2';
 $Is_Mac = $^O eq 'MacOS';
@@ -264,6 +266,14 @@ sub c_o {
     my($self) = shift;
     return '' unless $self->needs_linking();
     my(@m);
+    if (my $cpp = $Config{cpprun}) {
+        my $cpp_cmd = $self->const_cccmd;
+        $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
+        push @m, '
+.c.i:
+       '. $cpp_cmd . ' $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c > $*.i
+';
+    }
     push @m, '
 .c$(OBJ_EXT):
        $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
@@ -580,7 +590,7 @@ MM_VERSION = $ExtUtils::MakeMaker::VERSION
 
     for $tmp (qw/
              FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
-             LDFROM LINKTYPE
+             LDFROM LINKTYPE PM_FILTER
              / ) {
        next unless defined $self->{$tmp};
        push @m, "$tmp = $self->{$tmp}\n";
@@ -628,7 +638,7 @@ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})."
 # work around a famous dec-osf make(1) feature(?):
 makemakerdflt: all
 
-.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT)
+.SUFFIXES: .xs .c .C .cpp .i .cxx .cc \$(OBJ_EXT)
 
 # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
 # some make implementations will delete the Makefile when we rebuild it. Because
@@ -1074,6 +1084,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
     $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
        if ($^O eq 'irix' && $self->{LD_RUN_PATH});
 
+    # For example in AIX the shared objects/libraries from previous builds
+    # linger quite a while in the shared dynalinker cache even when nobody
+    # is using them.  This is painful if one for instance tries to restart
+    # a failed build because the link command will fail unnecessarily 'cos
+    # the shared object/library is 'busy'.
+    push(@m,'  $(RM_F) $@
+');
+
     push(@m,'  LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
                ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
     push @m, '
@@ -1650,7 +1668,7 @@ sub init_main {
 
     unless ($self->{PERL_SRC}){
        my($dir);
-       foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){
+       foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){
            if (
                -f $self->catfile($dir,"config.sh")
                &&
@@ -1702,6 +1720,7 @@ from the perl source tree.
        $self->{PERL_INC}     = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
        my $perl_h;
 
+       no warnings 'uninitialized' ;
        if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
            and not $old){
            # Maybe somebody tries to build an extension with an
@@ -2455,6 +2474,7 @@ MAP_PRELIBS   = $Config::Config{perllibs} $Config::Config{cryptlib}
     }
     unless ($libperl && -f $lperl) { # Ilya's code...
        my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
+       $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
        $libperl ||= "libperl$self->{LIB_EXT}";
        $libperl   = "$dir/$libperl";
        $lperl   ||= "libperl$self->{LIB_EXT}";
@@ -3030,7 +3050,7 @@ sub pm_to_blib {
 pm_to_blib: $(TO_INST_PM)
        }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
        "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
-        -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')"
+        -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')"
        }.$self->{NOECHO}.q{$(TOUCH) $@
 };
 }
@@ -3141,8 +3161,22 @@ realclean purge ::  clean
         push(@m, "     $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n");
         push(@m, "     $self->{RM_F} \$(INST_STATIC)\n");
     }
-    push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n")
-       if keys %{$self->{PM}};
+    # Issue a several little RM_F commands rather than risk creating a
+    # very long command line (useful for extensions such as Encode
+    # that have many files).
+    if (keys %{$self->{PM}}) {
+       my $line = "";
+       foreach (values %{$self->{PM}}) {
+           if (length($line) + length($_) > 80) {
+               push @m, "\t$self->{RM_F} $line\n";
+               $line = $_;
+           }
+           else {
+               $line .= " $_"; 
+           }
+       }
+    push @m, "\t$self->{RM_F} $line\n" if $line;
+    }
     my(@otherfiles) = ($self->{MAKEFILE},
                       "$self->{MAKEFILE}.old"); # Makefiles last
     push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
@@ -3287,8 +3321,9 @@ sub subdir_x {
     my($self, $subdir) = @_;
     my(@m);
     if ($Is_Win32 && Win32::IsWin95()) {
-       # XXX: dmake-specific, like rest of Win95 port
-       return <<EOT;
+       if ($Config{'make'} =~ /dmake/i) {
+           # dmake-specific
+           return <<EOT;
 subdirs ::
 @[
        cd $subdir
@@ -3296,8 +3331,16 @@ subdirs ::
        cd ..
 ]
 EOT
-    }
-    else {
+        } elsif ($Config{'make'} =~ /nmake/i) {
+           # nmake-specific
+           return <<EOT;
+subdirs ::
+       cd $subdir
+       \$(MAKE) all \$(PASTHRU)
+       cd ..
+EOT
+       }
+    } else {
        return <<EOT;
 
 subdirs ::
index 377d5d1..b753e2a 100644 (file)
@@ -7,19 +7,23 @@
 
 package ExtUtils::MM_VMS;
 
+use strict;
+
 use Carp qw( &carp );
 use Config;
 require Exporter;
 use VMS::Filespec;
 use File::Basename;
 use File::Spec;
-our($Revision, @ISA);
-$Revision = '5.56 (27-Apr-1999)';
+our($Revision, @ISA, $VERSION, $Verbose);
+# All on one line so MakeMaker can see it.
+($VERSION) = ($Revision = '5.56 (27-Apr-1999)') =~ /^([\d.]+)/;
 
 @ISA = qw( File::Spec );
 unshift @MM::ISA, 'ExtUtils::MM_VMS';
 
-Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import('$Verbose', '&neatvalue');
 
 =head1 NAME
 
@@ -122,7 +126,7 @@ sub ExtUtils::MM_VMS::makeaperl;
 sub ExtUtils::MM_VMS::ext;
 sub ExtUtils::MM_VMS::nicetext;
 
-#use SelfLoader;
+our $AUTOLOAD;
 sub AUTOLOAD {
     my $code;
     if (defined fileno(DATA)) {
@@ -151,11 +155,12 @@ sub AUTOLOAD {
 
 
 # This isn't really an override.  It's just here because ExtUtils::MM_VMS
-# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext()
+# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
 # in MM_VMS, then AUTOLOAD is called, and bad things happen.  So, we just
-# mimic inheritance here and hand off to ExtUtils::Liblist.
+# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
 sub ext {
-  ExtUtils::Liblist::ext(@_);
+  require ExtUtils::Liblist;
+  ExtUtils::Liblist::Kid::ext(@_);
 }
 
 =back
@@ -557,22 +562,23 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision
 # DLBASE  = Basename part of dynamic library. May be just equal BASEEXT.
 ];
 
-    for $tmp (qw/
+    for my $tmp (qw/
              FULLEXT VERSION_FROM OBJECT LDFROM
              / ) {
        next unless defined $self->{$tmp};
        push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n";
     }
 
-    for $tmp (qw/
+    for my $tmp (qw/
              BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE
              / ) {
        next unless defined $self->{$tmp};
        push @m, "$tmp = $self->{$tmp}\n";
     }
 
-    for $tmp (qw/ XS MAN1PODS MAN3PODS PM /) {
-       next unless defined $self->{$tmp};
+    for my $tmp (qw/ XS MAN1PODS MAN3PODS PM /) {
+       # Where is the space coming from? --jhi
+       next unless $self ne " " && defined $self->{$tmp};
        my(%tmp,$key);
        for $key (keys %{$self->{$tmp}}) {
            $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0);
@@ -580,7 +586,7 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision
        $self->{$tmp} = \%tmp;
     }
 
-    for $tmp (qw/ C O_FILES H /) {
+    for my $tmp (qw/ C O_FILES H /) {
        next unless defined $self->{$tmp};
        my(@tmp,$val);
        for $val (@{$self->{$tmp}}) {
@@ -601,7 +607,7 @@ MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),'
 
 ';
 
-    for $tmp (qw/
+    for my $tmp (qw/
              INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
              /) {
        next unless defined $self->{$tmp};
@@ -700,7 +706,7 @@ sub cflags {
     # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
     # ($self->{DEFINE} has already been VMSified in constants() above)
     if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
-    for $type (qw(Def Undef)) {
+    for my $type (qw(Def Undef)) {
        my(@terms);
        while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
                my $term = $1;
@@ -826,7 +832,7 @@ pm_to_blib.ts : $(TO_INST_PM)
     }
     push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line;
 
-    push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]);
+    push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[','$(PM_FILTER)')" <.MM_tmp]);
     push(@m,qq[
        \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
        \$(NOECHO) \$(TOUCH) pm_to_blib.ts
@@ -1414,7 +1420,7 @@ sub processPL {
         my $list = ref($self->{PL_FILES}->{$plfile})
                ? $self->{PL_FILES}->{$plfile}
                : [$self->{PL_FILES}->{$plfile}];
-       foreach $target (@$list) {
+       foreach my $target (@$list) {
            my $vmsplfile = vmsify($plfile);
            my $vmsfile = vmsify($target);
            push @m, "
@@ -2046,6 +2052,8 @@ Consequently, it hasn't really been tested, and may well be incomplete.
 
 =cut
 
+our %olbs;
+
 sub makeaperl {
     my($self, %attribs) = @_;
     my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = 
@@ -2088,7 +2096,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
     $linkcmd =~ s/\s+/ /g;
 
     # Which *.olb files could we make use of...
-    local(%olbs);
+    local(%olbs);       # XXX can this be lexical?
     $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
     require File::Find;
     File::Find::find(sub {
@@ -2185,6 +2193,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
     push @optlibs, @$extra;
 
     $target = "Perl$Config{'exe_ext'}" unless $target;
+    my $shrtarget;
     ($shrtarget,$targdir) = fileparse($target);
     $shrtarget =~ s/^([^.]*)/$1Shr/;
     $shrtarget = $targdir . $shrtarget;
index 7f40ff7..80e247d 100644 (file)
@@ -1,5 +1,7 @@
 package ExtUtils::MM_Win32;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
@@ -23,8 +25,8 @@ use Config;
 use File::Basename;
 require Exporter;
 
-Exporter::import('ExtUtils::MakeMaker',
-       qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
 
 $ENV{EMXSHELL} = 'sh'; # to run `commands`
 unshift @MM::ISA, 'ExtUtils::MM_Win32';
@@ -596,7 +598,7 @@ pm_to_blib: $(TO_INST_PM)
        ($NMAKE ? 'qw[ <<pmfiles.dat ],'
                : $DMAKE ? 'qw[ $(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n) ],'
                         : '{ qw[$(PM_TO_BLIB)] },'
-        ).q{'}.$autodir.q{')"
+        ).q{'}.$autodir.q{','$(PM_FILTER)')"
        }. ($NMAKE ? q{
 $(PM_TO_BLIB)
 <<
index bef12b5..9680348 100644 (file)
@@ -44,7 +44,7 @@ use vars qw(
 # default routine without having to know under what OS
 # it's running.
 #
-@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker];
+@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist::Kid ExtUtils::MakeMaker];
 
 #
 # Setup dummy package:
@@ -60,7 +60,7 @@ use vars qw(
 
 # "predeclare the package: we only load it via AUTOLOAD
 # but we have already mentioned it in @ISA
-package ExtUtils::Liblist;
+package ExtUtils::Liblist::Kid;
 
 package ExtUtils::MakeMaker;
 #
@@ -200,7 +200,8 @@ sub full_setup {
     PERL_MALLOC_OK
     NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC
     PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX
-    PL_FILES PM PMLIBDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX
+    PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC
+       PPM_INSTALL_SCRIPT PREFIX
     PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
     XS_VERSION clean depend dist dynamic_lib linkext macro realclean
     tool_autosplit
@@ -239,7 +240,6 @@ sub full_setup {
 
  dir_target libscan makeaperl needs_linking perm_rw perm_rwx
  subdir_x test_via_harness test_via_script
-
                         ];
 
     push @MM_Sections, qw[
@@ -982,23 +982,39 @@ be
     perl Makefile.PL LIB=~/lib
 
 This will install the module's architecture-independent files into
-~/lib, the architecture-dependent files into ~/lib/$archname/auto.
+~/lib, the architecture-dependent files into ~/lib/$archname.
 
 Another way to specify many INSTALL directories with a single
 parameter is PREFIX.
 
     perl Makefile.PL PREFIX=~
 
-This will replace the string specified by $Config{prefix} in all
-$Config{install*} values.
+This will replace the string specified by C<$Config{prefix}> in all
+C<$Config{install*}> values.
 
 Note, that in both cases the tilde expansion is done by MakeMaker, not
-by perl by default, nor by make. Conflicts between parameters LIB,
-PREFIX and the various INSTALL* arguments are resolved so that 
-XXX
+by perl by default, nor by make.
+
+Conflicts between parameters LIB,
+PREFIX and the various INSTALL* arguments are resolved so that:
+
+=over 4
+
+=item *
+
+setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB,
+INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX);
+
+=item *
+
+without LIB, setting PREFIX replaces the initial C<$Config{prefix}>
+part of those INSTALL* arguments, even if the latter are explicitly
+set (but are set to still start with C<$Config{prefix}>).
+
+=back
 
 If the user has superuser privileges, and is not working on AFS
-(Andrew File System) or relatives, then the defaults for
+or relatives, then the defaults for
 INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate,
 and this incantation will be the best:
 
@@ -1145,11 +1161,6 @@ or as NAME=VALUE pairs on the command line:
 
 =over 2
 
-=item AUTHOR
-
-String containing name (and email address) of package author(s). Is used
-in PPD (Perl Package Description) files for PPM (Perl Package Manager).
-
 =item ABSTRACT
 
 One line description of the module. Will be included in PPD file.
@@ -1160,6 +1171,11 @@ Name of the file that contains the package description. MakeMaker looks
 for a line in the POD matching /^($package\s-\s)(.*)/. This is typically
 the first line in the "=head1 NAME" section. $2 becomes the abstract.
 
+=item AUTHOR
+
+String containing name (and email address) of package author(s). Is used
+in PPD (Perl Package Description) files for PPM (Perl Package Manager).
+
 =item BINARY_LOCATION
 
 Used when creating PPD files for binary packages.  It can be set to a
@@ -1409,11 +1425,6 @@ to INSTALLBIN during 'make install'
 Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you
 need to use it.
 
-=item INST_LIB
-
-Directory where we put library files of this extension while building
-it.
-
 =item INST_HTMLLIBDIR
 
 Directory to hold the man pages in HTML format at 'make' time
@@ -1422,6 +1433,11 @@ Directory to hold the man pages in HTML format at 'make' time
 
 Directory to hold the man pages in HTML format at 'make' time
 
+=item INST_LIB
+
+Directory where we put library files of this extension while building
+it.
+
 =item INST_MAN1DIR
 
 Directory to hold the man pages at 'make' time
@@ -1437,34 +1453,6 @@ Directory, where executable files should be installed during
 testing. make install will copy the files in INST_SCRIPT to
 INSTALLSCRIPT.
 
-=item PERL_MALLOC_OK
-
-defaults to 0.  Should be set to TRUE if the extension can work with
-the memory allocation routines substituted by the Perl malloc() subsystem.
-This should be applicable to most extensions with exceptions of those
-
-=over
-
-=item *
-
-with bugs in memory allocations which are caught by Perl's malloc();
-
-=item *
-
-which interact with the memory allocator in other ways than via
-malloc(), realloc(), free(), calloc(), sbrk() and brk();
-
-=item *
-
-which rely on special alignment which is not provided by Perl's malloc().
-
-=back
-
-B<NOTE.>  Negligence to set this flag in I<any one> of loaded extension
-nullifies many advantages of Perl's malloc(), such as better usage of
-system resources, error detection, memory usage reporting, catchable failure
-of memory allocations, etc.
-
 =item LDFROM
 
 defaults to "$(OBJECT)" and is used in the ld command to specify
@@ -1473,8 +1461,12 @@ specify ld flags)
 
 =item LIB
 
-LIB can only be set at C<perl Makefile.PL> time. It has the effect of
+LIB should only be set at C<perl Makefile.PL> time but is allowed as a
+MakeMaker argument. It has the effect of
 setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any
+explicit setting of those arguments (or of PREFIX).  
+INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding 
+architecture subdirectory.
 
 =item LIBPERL_A
 
@@ -1527,10 +1519,11 @@ at Configure time.
 
 =item MAN3PODS
 
-Hashref of .pm and .pod files. MakeMaker will default this to all
- .pod and any .pm files that include POD directives. The files listed
-here will be converted to man pages and installed as was requested
-at Configure time.
+Hashref that assigns to *.pm and *.pod files the files into which the
+manpages are to be written. MakeMaker parses all *.pod and *.pm files
+for POD directives. Files that contain POD will be the default keys of
+the MAN3PODS hashref. These will then be converted to man pages during
+C<make> and will be installed during C<make install>.
 
 =item MAP_TARGET
 
@@ -1578,6 +1571,8 @@ List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
 string containing all object files, e.g. "tkpBind.o
 tkpButton.o tkpCanvas.o"
 
+(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.)
+
 =item OPTIMIZE
 
 Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
@@ -1594,12 +1589,40 @@ to $(CC).
 
 =item PERL_ARCHLIB
 
-Same as above for architecture dependent files.
+Same as below, but for architecture dependent files.
 
 =item PERL_LIB
 
 Directory containing the Perl library to use.
 
+=item PERL_MALLOC_OK
+
+defaults to 0.  Should be set to TRUE if the extension can work with
+the memory allocation routines substituted by the Perl malloc() subsystem.
+This should be applicable to most extensions with exceptions of those
+
+=over 4
+
+=item *
+
+with bugs in memory allocations which are caught by Perl's malloc();
+
+=item *
+
+which interact with the memory allocator in other ways than via
+malloc(), realloc(), free(), calloc(), sbrk() and brk();
+
+=item *
+
+which rely on special alignment which is not provided by Perl's malloc().
+
+=back
+
+B<NOTE.>  Negligence to set this flag in I<any one> of loaded extension
+nullifies many advantages of Perl's malloc(), such as better usage of
+system resources, error detection, memory usage reporting, catchable failure
+of memory allocations, etc.
+
 =item PERL_SRC
 
 Directory containing the Perl source code (use of this should be
@@ -1648,6 +1671,31 @@ they contain will be installed in the corresponding location in the
 library.  A libscan() method can be used to alter the behaviour.
 Defining PM in the Makefile.PL will override PMLIBDIRS.
 
+(Where BASEEXT is the last component of NAME.)
+
+=item PM_FILTER
+
+A filter program, in the traditional Unix sense (input from stdin, output
+to stdout) that is passed on each .pm file during the build (in the
+pm_to_blib() phase).  It is empty by default, meaning no filtering is done.
+
+Great care is necessary when defining the command if quoting needs to be
+done.  For instance, you would need to say:
+
+  {'PM_FILTER' => 'grep -v \\"^\\#\\"'}
+
+to remove all the leading coments on the fly during the build.  The
+extra \\ are necessary, unfortunately, because this variable is interpolated
+within the context of a Perl program built on the command line, and double
+quotes are what is used with the -e switch to build that command line.  The
+# is escaped for the Makefile, since what is going to be generated will then
+be:
+
+  PM_FILTER = grep -v \"^\#\"
+
+Without the \\ before the #, we'd have the start of a Makefile comment,
+and the macro would be incorrectly defined.
+
 =item POLLUTE
 
 Release 5.005 grandfathered old global symbol names by providing preprocessor
@@ -1725,6 +1773,7 @@ MakeMaker object. The following lines will be parsed o.k.:
     ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/;
     $FOO::VERSION = '1.10';
     *FOO::VERSION = \'1.11';
+    our $VERSION = 1.2.3;      # new for perl5.6.0 
 
 but these will fail:
 
@@ -1732,6 +1781,8 @@ but these will fail:
     local $VERSION = '1.02';
     local $FOO::VERSION = '1.30';
 
+(Putting C<my> or C<local> on the preceding line will work o.k.)
+
 The file named in VERSION_FROM is not added as a dependency to
 Makefile. This is not really correct, but it would be a major pain
 during development to have to rewrite the Makefile for any smallish
@@ -1786,6 +1837,8 @@ part of the Makefile.
 
   {ANY_TARGET => ANY_DEPENDECY, ...}
 
+(ANY_TARGET must not be given a double-colon rule by MakeMaker.)
+
 =item dist
 
   {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
@@ -2030,10 +2083,10 @@ ExtUtils::Install, ExtUtils::Embed
 =head1 AUTHORS
 
 Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig
-<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>.
-VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>.  OS/2
-support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>.  Contact the
-makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if
-you have any questions.
+<F<andreas.koenig@mind.de>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>.  VMS
+support by Charles Bailey <F<bailey@newman.upenn.edu>>.  OS/2 support
+by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>.
+
+Send patches and bug reports to <F<perlbug@perl.org>>.
 
 =cut
index 28b7053..030eedf 100644 (file)
@@ -4,11 +4,12 @@ require Exporter;
 use Config;
 use File::Find;
 use File::Copy 'copy';
+use File::Spec::Functions qw(splitpath);
 use Carp;
 use strict;
 
-use vars qw($VERSION @ISA @EXPORT_OK
-           $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found);
+our ($VERSION,@ISA,@EXPORT_OK,
+           $Is_VMS,$Debug,$Verbose,$Quiet,$MANIFEST,$found,$DEFAULT_MSKIP);
 
 $VERSION = substr(q$Revision: 1.33 $, 10);
 @ISA=('Exporter');
@@ -18,10 +19,11 @@ $VERSION = substr(q$Revision: 1.33 $, 10);
 $Is_VMS = $^O eq 'VMS';
 if ($Is_VMS) { require File::Basename }
 
-$Debug = 0;
+$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0;
 $Verbose = 1;
 $Quiet = 0;
 $MANIFEST = 'MANIFEST';
+$DEFAULT_MSKIP = (splitpath($INC{"ExtUtils/Manifest.pm"}))[1]."$MANIFEST.SKIP";
 
 # Really cool fix from Ilya :)
 unless (defined $Config{d_link}) {
@@ -160,8 +162,7 @@ sub _maniskip {
     my @skip ;
     $mfile ||= "$MANIFEST.SKIP";
     local *M;
-    return $matches unless -f $mfile;
-    open M, $mfile or return $matches;
+    open M, $mfile or open M, $DEFAULT_MSKIP or return $matches;
     while (<M>){
        chomp;
        next if /^#/;
@@ -187,13 +188,13 @@ sub manicopy {
     require File::Basename;
     my(%dirs,$file);
     $target = VMS::Filespec::unixify($target) if $Is_VMS;
-    File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755);
+    File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755);
     foreach $file (keys %$read){
        $file = VMS::Filespec::unixify($file) if $Is_VMS;
        if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
            my $dir = File::Basename::dirname($file);
            $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
-           File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755);
+           File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755);
        }
        cp_if_diff($file, "$target/$file", $how);
     }
@@ -344,15 +345,27 @@ expressions should appear one on each line. Blank lines and lines
 which start with C<#> are skipped.  Use C<\#> if you need a regular
 expression to start with a sharp character. A typical example:
 
+    # Version control files and dirs.
     \bRCS\b
+    \bCVS\b
+    ,v$
+
+    # Makemaker generated files and dirs.
     ^MANIFEST\.
     ^Makefile$
-    ~$
-    \.html$
-    \.old$
     ^blib/
     ^MakeMaker-\d
 
+    # Temp, old and emacs backup files.
+    ~$
+    \.old$
+    ^#.*#$
+
+If no MANIFEST.SKIP file is found, a default set of skips will be
+used, similar to the example above.  If you want nothing skipped,
+simply make an empty MANIFEST.SKIP file.
+
+
 =head1 EXPORT_OK
 
 C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
@@ -369,6 +382,10 @@ and a developer version including RCS).
 C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
 all functions act silently.
 
+C<$ExtUtils::Manifest::Debug> defaults to 0.  If set to a true value,
+or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be
+produced.
+
 =head1 DIAGNOSTICS
 
 All diagnostic output is sent to C<STDERR>.
@@ -397,12 +414,22 @@ to MANIFEST. $Verbose is set to 1 by default.
 
 =back
 
+=head1 ENVIRONMENT
+
+=over 4
+
+=item B<PERL_MM_MANIFEST_DEBUG>
+
+Turns on debugging
+
+=back
+
 =head1 SEE ALSO
 
 L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
 
 =head1 AUTHOR
 
-Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>>
+Andreas Koenig <F<andreas.koenig@anima.de>>
 
 =cut
index c8f41c7..c06b393 100644 (file)
@@ -49,6 +49,7 @@ sub Mksymlists {
     }
 
     if    ($osname eq 'aix') { _write_aix(\%spec); }
+    elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
     elsif ($osname eq 'VMS') { _write_vms(\%spec) }
     elsif ($osname eq 'os2') { _write_os2(\%spec) }
     elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
index 9961f2d..c59c3dc 100644 (file)
@@ -40,7 +40,8 @@ Boolean                       T_IV
 double                 T_DOUBLE
 SysRet                 T_SYSRET
 SysRetLong             T_SYSRET
-FILE *                 T_IN
+FILE *                 T_STDIO
+PerlIO *               T_INOUT
 FileHandle             T_PTROBJ
 InputStream            T_IN
 InOutStream            T_INOUT
@@ -55,22 +56,22 @@ T_SVREF
        if (sv_isa($arg, \"${ntype}\"))
            $var = (SV*)SvRV($arg);
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_AVREF
        if (sv_isa($arg, \"${ntype}\"))
            $var = (AV*)SvRV($arg);
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_HVREF
        if (sv_isa($arg, \"${ntype}\"))
            $var = (HV*)SvRV($arg);
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_CVREF
        if (sv_isa($arg, \"${ntype}\"))
            $var = (CV*)SvRV($arg);
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_SYSRET
        $var NOT IMPLEMENTED
 T_UV
@@ -113,50 +114,50 @@ T_PTRREF
            $var = INT2PTR($type,tmp);
        }
        else
-           croak(\"$var is not a reference\")
+           Perl_croak(aTHX_ \"$var is not a reference\")
 T_REF_IV_REF
        if (sv_isa($arg, \"${type}\")) {
            IV tmp = SvIV((SV*)SvRV($arg));
            $var = *($type *) tmp;
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_REF_IV_PTR
        if (sv_isa($arg, \"${type}\")) {
            IV tmp = SvIV((SV*)SvRV($arg));
            $var = ($type) tmp;
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_PTROBJ
        if (sv_derived_from($arg, \"${ntype}\")) {
            IV tmp = SvIV((SV*)SvRV($arg));
            $var = INT2PTR($type,tmp);
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_PTRDESC
        if (sv_isa($arg, \"${ntype}\")) {
            IV tmp = SvIV((SV*)SvRV($arg));
-           ${type}_desc = (\U${type}_DESC\E*) tmp; 
+           ${type}_desc = (\U${type}_DESC\E*) tmp;
            $var = ${type}_desc->ptr;
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_REFREF
        if (SvROK($arg)) {
            IV tmp = SvIV((SV*)SvRV($arg));
            $var = *INT2PTR($type,tmp);
        }
        else
-           croak(\"$var is not a reference\")
+           Perl_croak(aTHX_ \"$var is not a reference\")
 T_REFOBJ
        if (sv_isa($arg, \"${ntype}\")) {
            IV tmp = SvIV((SV*)SvRV($arg));
            $var = *INT2PTR($type,tmp);
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 T_OPAQUE
        $var NOT IMPLEMENTED
 T_OPAQUEPTR
@@ -173,6 +174,8 @@ T_ARRAY
        while (items--) {
            DO_ARRAY_ELEM;
        }
+T_STDIO
+       $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
 T_IN
        $var = IoIFP(sv_2io($arg))
 T_INOUT
@@ -267,6 +270,15 @@ T_ARRAY
        DO_ARRAY_ELEM
        }
        SP += $var.size - 1;
+T_STDIO
+       {
+           GV *gv = newGVgen("$Package");
+           PerlIO *fp = PerlIO_importFILE($var,0);
+           if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
+               sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+           else
+               $arg = &PL_sv_undef;
+       }
 T_IN
        {
            GV *gv = newGVgen("$Package");
index 1e9ff45..2093633 100755 (executable)
@@ -109,7 +109,7 @@ sub Q ;
 
 # Global Constants
 
-$XSUBPP_version = "1.9507";
+$XSUBPP_version = "1.9508";
 
 my ($Is_VMS, $SymSet);
 if ($^O eq 'VMS') {
@@ -418,7 +418,7 @@ sub INPUT_handler {
        $var_init =~ s/"/\\"/g;
 
        s/\s+/ /g;
-       my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
+       my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
            or blurt("Error: invalid argument declaration '$line'"), next;
 
        # Check for duplicate definitions
@@ -444,12 +444,9 @@ sub INPUT_handler {
 
         $proto_arg[$var_num] = ProtoString($var_type) 
            if $var_num ;
-       if ($var_addr) {
-           $var_addr{$var_name} = 1;
-           $func_args =~ s/\b($var_name)\b/&$1/;
-       }
+       $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
        if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
-           or $in_out{$var_name} and $in_out{$var_name} eq 'OUTLIST'
+           or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
            and $var_init !~ /\S/) {
          if ($name_printed) {
            print ";\n";
@@ -494,6 +491,8 @@ sub OUTPUT_handler {
        } else {
            &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
        }
+       delete $in_out{$outarg}         # No need to auto-OUTPUT 
+         if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
     }
 }
 
@@ -859,10 +858,21 @@ print("#line 1 \"$filename\"\n")
 firstmodule:
 while (<$FH>) {
     if (/^=/) {
+        my $podstartline = $.;
        do {
-           next firstmodule if /^=cut\s*$/;
+           if (/^=cut\s*$/) {
+               print("/* Skipped embedded POD. */\n");
+               printf("#line %d \"$filename\"\n", $. + 1)
+                 if $WantLineNumbers;
+               next firstmodule
+           }
+
        } while (<$FH>);
-       &Exit;
+       # At this point $. is at end of file so die won't state the start
+       # of the problem, and as we haven't yet read any lines &death won't
+       # show the correct line in the message either.
+       die ("Error: Unterminated pod in $filename, line $podstartline\n")
+         unless $lastline;
     }
     last if ($Module, $Package, $Prefix) =
        /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
@@ -992,7 +1002,6 @@ while (fetch_para()) {
     # initialize info arrays
     undef(%args_match);
     undef(%var_types);
-    undef(%var_addr);
     undef(%defaults);
     undef($class);
     undef($static);
@@ -1004,7 +1013,7 @@ while (fetch_para()) {
     undef(@arg_with_types) ;
     undef($processing_arg_with_types) ;
     undef(%arg_types) ;
-    undef(@in_out) ;
+    undef(@outlist) ;
     undef(%in_out) ;
     undef($proto_in_this_xsub) ;
     undef($scope_in_this_xsub) ;
@@ -1070,7 +1079,7 @@ while (fetch_para()) {
 
     $orig_args =~ s/\\\s*/ /g;         # process line continuations
 
-    my %out_vars;
+    my %only_outlist;
     if ($process_argtypes and $orig_args =~ /\S/) {
        my $args = "$orig_args ,";
        if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
@@ -1085,10 +1094,10 @@ while (fetch_para()) {
                next unless length $pre;
                my $out_type;
                my $inout_var;
-               if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
+               if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
                    my $type = $1;
                    $out_type = $type if $type ne 'IN';
-                   $arg =~ s/^(IN|IN_OUTLIST|OUTLIST)\s+//;
+                   $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
                }
                if (/\W/) {     # Has a type
                    push @arg_with_types, $arg;
@@ -1096,8 +1105,8 @@ while (fetch_para()) {
                    $arg_types{$name} = $arg;
                    $_ = "$name$default";
                }
-               $out_vars{$_} = 1 if $out_type eq 'OUTLIST';
-               push @in_out, $name if $out_type;
+               $only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+               push @outlist, $name if $out_type =~ /OUTLIST$/;
                $in_out{$name} = $out_type if $out_type;
            }
        } else {
@@ -1107,11 +1116,11 @@ while (fetch_para()) {
     } else {
        @args = split(/\s*,\s*/, $orig_args);
        for (@args) {
-           if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
+           if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
                my $out_type = $1;
                next if $out_type eq 'IN';
-               $out_vars{$_} = 1 if $out_type eq 'OUTLIST';
-               push @in_out, $name;
+               $only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+               push @outlist, $name if $out_type =~ /OUTLIST$/;
                $in_out{$_} = $out_type;
            }
        }
@@ -1135,7 +1144,7 @@ while (fetch_para()) {
                        last;
                    }
            }
-           if ($out_vars{$args[$i]}) {
+           if ($only_outlist{$args[$i]}) {
                push @args_num, undef;
            } else {
                push @args_num, ++$num_args;
@@ -1174,6 +1183,7 @@ while (fetch_para()) {
 
     # print function header
     print Q<<"EOF";
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
 #XS(XS_${Full_func_name})
 #[[
 #    dXSARGS;
@@ -1324,6 +1334,9 @@ EOF
        undef %outargs ;
        process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); 
 
+       &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
+         for grep $in_out{$_} =~ /OUT$/, keys %in_out;
+
        # all OUTPUT done, so now push the return value on the stack
        if ($gotRETVAL && $RETVAL_code) {
            print "\t$RETVAL_code\n";
@@ -1360,11 +1373,11 @@ EOF
 
        $xsreturn = 1 if $ret_type ne "void";
        my $num = $xsreturn;
-       my $c = @in_out;
+       my $c = @outlist;
        print "\tXSprePUSH;" if $c and not $prepush_done;
        print "\tEXTEND(SP,$c);\n" if $c;
        $xsreturn += $c;
-       generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out;
+       generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
 
        # do cleanup
        process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;
@@ -1490,6 +1503,7 @@ print Q<<"EOF";
 EOF
 
 print Q<<"EOF";
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
 #XS(boot_$Module_cname)
 EOF
 
index 2432344..75996f2 100644 (file)
@@ -176,7 +176,7 @@ sub fileparse {
       $dirpath ||= '';  # should always be defined
     }
   }
-  if ($fstype =~ /^MS(DOS|Win32)/i) {
+  if ($fstype =~ /^MS(DOS|Win32)|epoc/i) {
     ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
     $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
   }
index ae18777..8b6ae08 100644 (file)
@@ -1,4 +1,7 @@
 package File::CheckTree;
+
+our $VERSION = '4.1';
+
 require 5.000;
 require Exporter;
 
@@ -41,39 +44,8 @@ The routine returns the number of warnings issued.
 
 =cut
 
-@ISA = qw(Exporter);
-@EXPORT = qw(validate);
-
-# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
-
-# The validate routine takes a single multiline string consisting of
-# lines containing a filename plus a file test to try on it.  (The
-# file test may also be a 'cd', causing subsequent relative filenames
-# to be interpreted relative to that directory.)  After the file test
-# you may put '|| die' to make it a fatal error if the file test fails.
-# The default is '|| warn'.  The file test may optionally have a ! prepended
-# to test for the opposite condition.  If you do a cd and then list some
-# relative filenames, you may want to indent them slightly for readability.
-# If you supply your own "die" or "warn" message, you can use $file to
-# interpolate the filename.
-
-# Filetests may be bunched:  -rwx tests for all of -r, -w and -x.
-# Only the first failed test of the bunch will produce a warning.
-
-# The routine returns the number of warnings issued.
-
-# Usage:
-#      use File::CheckTree;
-#      $warnings += validate('
-#      /vmunix                 -e || die
-#      /boot                   -e || die
-#      /bin                    cd
-#          csh                 -ex
-#          csh                 !-ug
-#          sh                  -ex
-#          sh                  !-ug
-#      /usr                    -d || warn "What happened to $file?\n"
-#      ');
+our @ISA = qw(Exporter);
+our @EXPORT = qw(validate);
 
 sub validate {
     local($file,$test,$warnings,$oldwarnings);
@@ -94,7 +66,8 @@ sub validate {
            $this =~ s/(-\w\b)/$1 \$file/g;
            $this =~ s/-Z/-$one/;
            $this .= ' || warn' unless $this =~ /\|\|/;
-           $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/;
+           $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || 
+               valmess('$2','$1')/;
            $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
            eval $this;
            last if $warnings > $oldwarnings;
@@ -103,47 +76,54 @@ sub validate {
     $warnings;
 }
 
+our %Val_Switch = (
+       'r' => sub { "$_[0] is not readable by uid $>." },
+       'w' => sub { "$_[0] is not writable by uid $>." },
+       'x' => sub { "$_[0] is not executable by uid $>." },
+       'o' => sub { "$_[0] is not owned by uid $>." },
+       'R' => sub { "$_[0] is not readable by you." },
+       'W' => sub { "$_[0] is not writable by you." },
+       'X' => sub { "$_[0] is not executable by you." },
+       'O' => sub { "$_[0] is not owned by you." },
+       'e' => sub { "$_[0] does not exist." },
+       'z' => sub { "$_[0] does not have zero size." },
+       's' => sub { "$_[0] does not have non-zero size." },
+       'f' => sub { "$_[0] is not a plain file." },
+       'd' => sub { "$_[0] is not a directory." },
+       'l' => sub { "$_[0] is not a symbolic link." },
+       'p' => sub { "$_[0] is not a named pipe (FIFO)." },
+       'S' => sub { "$_[0] is not a socket." },
+       'b' => sub { "$_[0] is not a block special file." },
+       'c' => sub { "$_[0] is not a character special file." },
+       'u' => sub { "$_[0] does not have the setuid bit set." },
+       'g' => sub { "$_[0] does not have the setgid bit set." },
+       'k' => sub { "$_[0] does not have the sticky bit set." },
+       'T' => sub { "$_[0] is not a text file." },
+       'B' => sub { "$_[0] is not a binary file." },
+);
+
 sub valmess {
-    local($disposition,$this) = @_;
-    $file = $cwd . '/' . $file unless $file =~ m|^/|s;
+    my($disposition,$this) = @_;
+    my $file = $cwd . '/' . $file unless $file =~ m|^/|s;
+    
+    my $ferror;
     if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
-       $neg = $1;
-       $tmp = $2;
-       $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
-       $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
-       $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
-       $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
-       $tmp eq 'R' && ($mess = "$file is not readable by you.");
-       $tmp eq 'W' && ($mess = "$file is not writable by you.");
-       $tmp eq 'X' && ($mess = "$file is not executable by you.");
-       $tmp eq 'O' && ($mess = "$file is not owned by you.");
-       $tmp eq 'e' && ($mess = "$file does not exist.");
-       $tmp eq 'z' && ($mess = "$file does not have zero size.");
-       $tmp eq 's' && ($mess = "$file does not have non-zero size.");
-       $tmp eq 'f' && ($mess = "$file is not a plain file.");
-       $tmp eq 'd' && ($mess = "$file is not a directory.");
-       $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
-       $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
-       $tmp eq 'S' && ($mess = "$file is not a socket.");
-       $tmp eq 'b' && ($mess = "$file is not a block special file.");
-       $tmp eq 'c' && ($mess = "$file is not a character special file.");
-       $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
-       $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
-       $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
-       $tmp eq 'T' && ($mess = "$file is not a text file.");
-       $tmp eq 'B' && ($mess = "$file is not a binary file.");
+       my($neg,$ftype) = ($1,$2);
+
+        $ferror = $Val_Switch{$tmp}->($file);
+
        if ($neg eq '!') {
-           $mess =~ s/ is not / should not be / ||
-           $mess =~ s/ does not / should not / ||
-           $mess =~ s/ not / /;
+           $ferror =~ s/ is not / should not be / ||
+           $ferror =~ s/ does not / should not / ||
+           $ferror =~ s/ not / /;
        }
     }
     else {
        $this =~ s/\$file/'$file'/g;
-       $mess = "Can't do $this.\n";
+       $ferror = "Can't do $this.\n";
     }
-    die "$mess\n" if $disposition eq 'die';
-    warn "$mess\n";
+    die "$ferror\n" if $disposition eq 'die';
+    warn "$ferror\n";
     ++$warnings;
 }
 
index d7dea7b..2b4d39a 100644 (file)
@@ -1,54 +1,59 @@
 #!perl -w
 
+# use strict fails
+#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.
+
 #
 # Documentation at the __END__
 #
 
 package File::DosGlob;
 
+our $VERSION = '1.00';
+use strict;
+
 sub doglob {
     my $cond = shift;
     my @retval = ();
     #print "doglob: ", join('|', @_), "\n";
   OUTER:
-    for my $arg (@_) {
-        local $_ = $arg;
+    for my $pat (@_) {
        my @matched = ();
        my @globdirs = ();
        my $head = '.';
        my $sepchr = '/';
-       next OUTER unless defined $_ and $_ ne '';
+        my $tail;
+       next OUTER unless defined $pat and $pat ne '';
        # if arg is within quotes strip em and do no globbing
-       if (/^"(.*)"\z/s) {
-           $_ = $1;
-           if ($cond eq 'd') { push(@retval, $_) if -d $_ }
-           else              { push(@retval, $_) if -e $_ }
+       if ($pat =~ /^"(.*)"\z/s) {
+           $pat = $1;
+           if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
+           else              { push(@retval, $pat) if -e $pat }
            next OUTER;
        }
        # wildcards with a drive prefix such as h:*.pm must be changed
        # to h:./*.pm to expand correctly
-       if (m|^([A-Za-z]:)[^/\\]|s) {
+       if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
            substr($_,0,2) = $1 . "./";
        }
-       if (m|^(.*)([\\/])([^\\/]*)\z|s) {
-           my $tail;
+       if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
            ($head, $sepchr, $tail) = ($1,$2,$3);
            #print "div: |$head|$sepchr|$tail|\n";
-           push (@retval, $_), next OUTER if $tail eq '';
+           push (@retval, $pat), next OUTER if $tail eq '';
            if ($head =~ /[*?]/) {
                @globdirs = doglob('d', $head);
                push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
                    next OUTER if @globdirs;
            }
            $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
-           $_ = $tail;
+           $pat = $tail;
        }
        #
        # If file component has no wildcards, we can avoid opendir
-       unless (/[*?]/) {
+       unless ($pat =~ /[*?]/) {
            $head = '' if $head eq '.';
            $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
-           $head .= $_;
+           $head .= $pat;
            if ($cond eq 'd') { push(@retval,$head) if -d $head }
            else              { push(@retval,$head) if -e $head }
            next OUTER;
@@ -60,14 +65,13 @@ sub doglob {
        $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
 
        # escape regex metachars but not glob chars
-       s:([].+^\-\${}[|]):\\$1:g;
+        $pat =~ s:([].+^\-\${}[|]):\\$1:g;
        # and convert DOS-style wildcards to regex
-       s/\*/.*/g;
-       s/\?/.?/g;
+       $pat =~ s/\*/.*/g;
+       $pat =~ s/\?/.?/g;
 
-       #print "regex: '$_', head: '$head'\n";
-       my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
-       warn($@), next OUTER if $@;
+       #print "regex: '$pat', head: '$head'\n";
+       my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
       INNER:
        for my $e (@leaves) {
            next INNER if $e eq '.' or $e eq '..';
@@ -80,7 +84,7 @@ sub doglob {
            # has a dot *and* name is shorter than 9 chars.
            #
            if (index($e,'.') == -1 and length($e) < 9
-               and index($_,'\\.') != -1) {
+               and index($pat,'\\.') != -1) {
                push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
            }
        }
@@ -100,8 +104,7 @@ my %iter;
 my %entries;
 
 sub glob {
-    my $pat = shift;
-    my $cxix = shift;
+    my($pat,$cxix) = @_;
     my @pat;
 
     # glob without args defaults to $_
@@ -116,6 +119,52 @@ sub glob {
        push @pat, $pat;
     }
 
+    # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
+    #   abc3 will be the original {3} (and drop the {}).
+    #   abc1 abc2 will be put in @appendpat.
+    # This was just the esiest way, not nearly the best.
+    REHASH: {
+       my @appendpat = ();
+       for (@pat) {
+           # There must be a "," I.E. abc{efg} is not what we want.
+           while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
+               my ($start, $match, $end) = ($1, $2, $3);
+               #print "Got: \n\t$start\n\t$match\n\t$end\n";
+               my $tmp = "$start$match$end";
+               while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
+                   #print "Striped: $tmp\n";
+                   #  these expanshions will be preformed by the original,
+                   #  when we call REHASH.
+               }
+               push @appendpat, ("$tmp");
+               s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
+               if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
+                   $match = $1;
+                   #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
+                   $_ = "$start$match$end";
+               }
+           }
+           #print "Sould have "GOT" vs "Got"!\n";
+               #FIXME: There should be checking for this.
+               #  How or what should be done about failure is beond me.
+       }
+       if ( $#appendpat != -1
+               ) {
+           #print "LOOP\n";
+           #FIXME: Max loop, no way! :")
+           for ( @appendpat ) {
+               push @pat, $_;
+           }
+           goto REHASH;
+       }
+    }
+    for ( @pat ) {
+       s/\\{/{/g;
+       s/\\}/}/g;
+       s/\\,/,/g;
+    }
+    #print join ("\n", @pat). "\n";
     # assume global context if not provided one
     $cxix = '_G_' unless defined $cxix;
     $iter{$cxix} = 0 unless exists $iter{$cxix};
@@ -143,14 +192,17 @@ sub glob {
     }
 }
 
-sub import {
+{
+    no strict 'refs';
+
+    sub import {
     my $pkg = shift;
     return unless @_;
     my $sym = shift;
     my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
     *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
+    }
 }
-
 1;
 
 __END__
index 6e6e462..1e33f1e 100644 (file)
@@ -1,5 +1,7 @@
 package File::Find;
+use strict;
 use 5.005_64;
+our $VERSION = '1.00';
 require Exporter;
 require Cwd;
 
@@ -187,8 +189,8 @@ in an unknown directory.
 
 =cut
 
-@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+our @ISA = qw(Exporter);
+our @EXPORT = qw(find finddepth);
 
 
 use strict;
@@ -759,7 +761,7 @@ if ($^O eq 'VMS') {
 
 $File::Find::dont_use_nlink = 1
     if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
-       $^O eq 'cygwin';
+       $^O eq 'cygwin' || $^O eq 'epoc';
 
 # Set dont_use_nlink in your hint file if your system's stat doesn't
 # report the number of links in a directory as an indication
index ffc856b..3859f24 100644 (file)
@@ -105,8 +105,8 @@ my $Is_VMS = $^O eq 'VMS';
 
 # These OSes complain if you want to remove a file that you have no
 # write permission to:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
-                      || $^O eq 'amigaos');
+my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
+                      $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
 
 sub mkpath {
     my($paths, $verbose, $mode) = @_;
index 40503c4..35707cc 100644 (file)
@@ -1,14 +1,15 @@
 package File::Spec;
 
 use strict;
-use vars qw(@ISA $VERSION);
+our(@ISA, $VERSION);
 
 $VERSION = 0.82 ;
 
 my %module = (MacOS   => 'Mac',
              MSWin32 => 'Win32',
              os2     => 'OS2',
-             VMS     => 'VMS');
+             VMS     => 'VMS',
+             epoc    => 'Epoc');
 
 my $module = $module{$^O} || 'Unix';
 require "File/Spec/$module.pm";
diff --git a/lib/File/Spec/Epoc.pm b/lib/File/Spec/Epoc.pm
new file mode 100644 (file)
index 0000000..65d5e1f
--- /dev/null
@@ -0,0 +1,378 @@
+package File::Spec::Epoc;
+
+use strict;
+use Cwd;
+use vars qw(@ISA);
+require File::Spec::Unix;
+@ISA = qw(File::Spec::Unix);
+
+=head1 NAME
+
+File::Spec::Epoc - methods for Epoc file specs
+
+=head1 SYNOPSIS
+
+ require File::Spec::Epoc; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+This package is still work in progress ;-)
+o.flebbe@gmx.de
+
+
+=over
+
+=item devnull
+
+Returns a string representation of the null device.
+
+=cut
+
+sub devnull {
+    return "nul:";
+}
+
+=item tmpdir
+
+Returns a string representation of a temporay directory:
+
+=cut
+
+my $tmpdir;
+sub tmpdir {
+    return "C:/System/temp";
+}
+
+sub case_tolerant {
+    return 1;
+}
+
+sub file_name_is_absolute {
+    my ($self,$file) = @_;
+    return scalar($file =~ m{^([a-z?]:)?[\\/]}is);
+}
+
+=item path
+
+Takes no argument, returns the environment variable PATH as an array. Since
+there is no search path supported, it returns undef, sorry.
+
+=cut
+sub path {
+    return undef;
+}
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=cut
+
+sub canonpath {
+    my ($self,$path) = @_;
+    $path =~ s/^([a-z]:)/\u$1/s;
+
+    $path =~ s|/+|/|g unless($^O eq 'cygwin');     # xx////xx  -> xx/xx
+    $path =~ s|(/\.)+/|/|g;                        # xx/././xx -> xx/xx
+    $path =~ s|^(\./)+||s unless $path eq "./";    # ./xx      -> xx
+    $path =~ s|^/(\.\./)+|/|s;                     # /../../xx -> xx
+    $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
+    return $path;
+}
+
+=item splitpath
+
+    ($volume,$directories,$file) = File::Spec->splitpath( $path );
+    ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+
+Splits a path in to volume, directory, and filename portions. Assumes that 
+the last file is a path unless the path ends in '\\', '\\.', '\\..'
+or $no_file is true.  On Win32 this means that $no_file true makes this return 
+( $volume, $path, undef ).
+
+Separators accepted are \ and /.
+
+The results can be passed to L</catpath> to get back a path equivalent to
+(usually identical to) the original path.
+
+=cut
+
+sub splitpath {
+    my ($self,$path, $nofile) = @_;
+    my ($volume,$directory,$file) = ('','','');
+    if ( $nofile ) {
+        $path =~ 
+            m{^( (?:[a-zA-Z?]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
+                 (.*)
+             }xs;
+        $volume    = $1;
+        $directory = $2;
+    }
+    else {
+        $path =~ 
+            m{^ ( (?: [a-zA-Z?]: |
+                      (?:\\\\|//)[^\\/]+[\\/][^\\/]+
+                  )?
+                )
+                ( (?:.*[\\\\/](?:\.\.?\z)?)? )
+                (.*)
+             }xs;
+        $volume    = $1;
+        $directory = $2;
+        $file      = $3;
+    }
+
+    return ($volume,$directory,$file);
+}
+
+
+=item splitdir
+
+The opposite of L</catdir()>.
+
+    @dirs = File::Spec->splitdir( $directories );
+
+$directories must be only the directory portion of the path on systems 
+that have the concept of a volume or that have path syntax that differentiates
+files from directories.
+
+Unlike just splitting the directories on the separator, leading empty and 
+trailing directory entries can be returned, because these are significant
+on some OSs. So,
+
+    File::Spec->splitdir( "/a/b/c" );
+
+Yields:
+
+    ( '', 'a', 'b', '', 'c', '' )
+
+=cut
+
+sub splitdir {
+    my ($self,$directories) = @_ ;
+    #
+    # split() likes to forget about trailing null fields, so here we
+    # check to be sure that there will not be any before handling the
+    # simple case.
+    #
+    if ( $directories !~ m|[\\/]\z| ) {
+        return split( m|[\\/]|, $directories );
+    }
+    else {
+        #
+        # since there was a trailing separator, add a file name to the end, 
+        # then do the split, then replace it with ''.
+        #
+        my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
+        $directories[ $#directories ]= '' ;
+        return @directories ;
+    }
+}
+
+
+=item catpath
+
+Takes volume, directory and file portions and returns an entire path. Under
+Unix, $volume is ignored, and this is just like catfile(). On other OSs,
+the $volume become significant.
+
+=cut
+
+sub catpath {
+    my ($self,$volume,$directory,$file) = @_;
+
+    # If it's UNC, make sure the glue separator is there, reusing
+    # whatever separator is first in the $volume
+    $volume .= $1
+        if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s &&
+             $directory =~ m@^[^\\/]@s
+           ) ;
+
+    $volume .= $directory ;
+
+    # If the volume is not just A:, make sure the glue separator is 
+    # there, reusing whatever separator is first in the $volume if possible.
+    if ( $volume !~ m@^[a-zA-Z]:\z@s &&
+         $volume =~ m@[^\\/]\z@      &&
+         $file   =~ m@[^\\/]@
+       ) {
+        $volume =~ m@([\\/])@ ;
+        my $sep = $1 ? $1 : '\\' ;
+        $volume .= $sep ;
+    }
+
+    $volume .= $file ;
+
+    return $volume ;
+}
+
+
+=item abs2rel
+
+Takes a destination path and an optional base path returns a relative path
+from the base path to the destination path:
+
+    $rel_path = File::Spec->abs2rel( $destination ) ;
+    $rel_path = File::Spec->abs2rel( $destination, $base ) ;
+
+If $base is not present or '', then L</cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L<cwd()>.
+
+On systems with the concept of a volume, this assumes that both paths 
+are on the $destination volume, and ignores the $base volume.
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is relative, it is converted to absolute form using L</rel2abs()>.
+This means that it is taken to be relative to L</cwd()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub abs2rel {
+    my($self,$path,$base) = @_;
+
+    # Clean up $path
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+        $path = $self->rel2abs( $path ) ;
+    }
+    else {
+        $path = $self->canonpath( $path ) ;
+    }
+
+    # Figure out the effective $base and clean it up.
+    if ( ! $self->file_name_is_absolute( $base ) ) {
+        $base = $self->rel2abs( $base ) ;
+    }
+    elsif ( !defined( $base ) || $base eq '' ) {
+        $base = cwd() ;
+    }
+    else {
+        $base = $self->canonpath( $base ) ;
+    }
+
+    # Split up paths
+    my ( $path_volume, $path_directories, $path_file ) =
+        $self->splitpath( $path, 1 ) ;
+
+    my ( undef, $base_directories, undef ) =
+        $self->splitpath( $base, 1 ) ;
+
+    # Now, remove all leading components that are the same
+    my @pathchunks = $self->splitdir( $path_directories );
+    my @basechunks = $self->splitdir( $base_directories );
+
+    while ( @pathchunks && 
+            @basechunks && 
+            lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
+          ) {
+        shift @pathchunks ;
+        shift @basechunks ;
+    }
+
+    # No need to catdir, we know these are well formed.
+    $path_directories = CORE::join( '\\', @pathchunks );
+    $base_directories = CORE::join( '\\', @basechunks );
+
+    # $base_directories now contains the directories the resulting relative
+    # path must ascend out of before it can descend to $path_directory.  So, 
+    # replace all names with $parentDir
+
+    #FA Need to replace between backslashes...
+    $base_directories =~ s|[^\\]+|..|g ;
+
+    # Glue the two together, using a separator if necessary, and preventing an
+    # empty result.
+
+    #FA Must check that new directories are not empty.
+    if ( $path_directories ne '' && $base_directories ne '' ) {
+        $path_directories = "$base_directories\\$path_directories" ;
+    } else {
+        $path_directories = "$base_directories$path_directories" ;
+    }
+
+    # It makes no sense to add a relative path to a UNC volume
+    $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ;
+
+    return $self->canonpath( 
+        $self->catpath($path_volume, $path_directories, $path_file ) 
+    ) ;
+}
+
+=item rel2abs
+
+Converts a relative path to an absolute path. 
+
+    $abs_path = File::Spec->rel2abs( $destination ) ;
+    $abs_path = File::Spec->rel2abs( $destination, $base ) ;
+
+If $base is not present or '', then L<cwd()> is used. If $base is relative, 
+then it is converted to absolute form using L</rel2abs()>. This means that it
+is taken to be relative to L</cwd()>.
+
+Assumes that both paths are on the $base volume, and ignores the 
+$destination volume. 
+
+On systems that have a grammar that indicates filenames, this ignores the 
+$base filename as well. Otherwise all path components are assumed to be
+directories.
+
+If $path is absolute, it is cleaned up and returned using L</canonpath()>.
+
+Based on code written by Shigio Yamaguchi.
+
+No checks against the filesystem are made. 
+
+=cut
+
+sub rel2abs($;$;) {
+    my ($self,$path,$base ) = @_;
+
+    if ( ! $self->file_name_is_absolute( $path ) ) {
+
+        if ( !defined( $base ) || $base eq '' ) {
+            $base = cwd() ;
+        }
+        elsif ( ! $self->file_name_is_absolute( $base ) ) {
+            $base = $self->rel2abs( $base ) ;
+        }
+        else {
+            $base = $self->canonpath( $base ) ;
+        }
+
+        my ( undef, $path_directories, $path_file ) =
+            $self->splitpath( $path, 1 ) ;
+
+        my ( $base_volume, $base_directories, undef ) =
+            $self->splitpath( $base, 1 ) ;
+
+        $path = $self->catpath( 
+            $base_volume, 
+            $self->catdir( $base_directories, $path_directories ), 
+            $path_file
+        ) ;
+    }
+
+    return $self->canonpath( $path ) ;
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<File::Spec>
+
+=cut
+
+1;
index 0036ac1..be65333 100644 (file)
@@ -3,7 +3,7 @@ package File::Spec::Functions;
 use File::Spec;
 use strict;
 
-use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+our (@ISA,@EXPORT,@EXPORT_OK,%EXPORT_TAGS,$VERSION);
 
 $VERSION = '1.1';
 
index a81c533..4e4cc75 100644 (file)
@@ -1,7 +1,7 @@
 package File::Spec::Unix;
 
 use strict;
-use vars qw($VERSION);
+our($VERSION);
 
 $VERSION = '1.2';
 
index a351044..2d1a4b2 100644 (file)
@@ -124,7 +124,7 @@ use Carp;
 use File::Spec 0.8;
 use File::Path qw/ rmtree /;
 use Fcntl 1.03;
-use Errno qw( EEXIST ENOENT ENOTDIR EINVAL );
+use Errno;
 require VMS::Stdio if $^O eq 'VMS';
 
 # Need the Symbol package if we are running older perl
@@ -166,7 +166,7 @@ Exporter::export_tags('POSIX','mktemp');
 
 # Version number 
 
-$VERSION = '0.10';
+$VERSION = '0.11';
 
 # This is a list of characters that can be used in random filenames
 
@@ -443,7 +443,7 @@ sub _gettemp {
 
        # Error opening file - abort with error
        # if the reason was anything but EEXIST
-       unless ($! == EEXIST) {
+       unless ($!{EEXIST}) {
          carp "File::Temp: Could not create temp file $path: $!";
          return ();
        }
@@ -473,7 +473,7 @@ sub _gettemp {
 
        # Abort with error if the reason for failure was anything
        # except EEXIST
-       unless ($! == EEXIST) {
+       unless ($!{EEXIST}) {
          carp "File::Temp: Could not create directory $path: $!";
          return ();
        }
@@ -881,7 +881,8 @@ is specified.
 Return the filename and filehandle as before except that the file is
 automatically removed when the program exits. Default is for the file
 to be removed if a file handle is requested and to be kept if the
-filename is requested.
+filename is requested. In a scalar context (where no filename is 
+returned) the file is always deleted either on exit or when it is closed.
 
 If the template is not specified, a template is always
 automatically generated. This temporary file is placed in tmpdir()
@@ -896,8 +897,11 @@ the description of tmpfile() elsewhere in this document).
 This is the preferred mode of operation, as if you only 
 have a filehandle, you can never create a race condition
 by fumbling with the filename. On systems that can not unlink
-an open file (for example, Windows NT) the file is marked for
-deletion when the program ends (equivalent to setting UNLINK to 1).
+an open file or can not mark a file as temporary when it is opened
+(for example, Windows NT uses the C<O_TEMPORARY> flag))
+the file is marked for deletion when the program ends (equivalent
+to setting UNLINK to 1). The C<UNLINK> flag is ignored if present.
+
 
   (undef, $filename) = tempfile($template, OPEN => 0);
 
@@ -978,19 +982,33 @@ sub tempfile {
   # Now add a suffix
   $template .= $options{"SUFFIX"};
 
+  # Determine whether we should tell _gettemp to unlink the file
+  # On unix this is irrelevant and can be worked out after the file is
+  # opened (simply by unlinking the open filehandle). On Windows or VMS
+  # we have to indicate temporary-ness when we open the file. In general
+  # we only want a true temporary file if we are returning just the 
+  # filehandle - if the user wants the filename they probably do not
+  # want the file to disappear as soon as they close it.
+  # For this reason, tie unlink_on_close to the return context regardless
+  # of OS.
+  my $unlink_on_close = ( wantarray ? 0 : 1);
+
   # Create the file
   my ($fh, $path);
   croak "Error in tempfile() using $template"
     unless (($fh, $path) = _gettemp($template,
                                    "open" => $options{'OPEN'},
                                    "mkdir"=> 0 ,
-                                   "unlink_on_close" => $options{'UNLINK'},
+                                    "unlink_on_close" => $unlink_on_close,
                                    "suffixlen" => length($options{'SUFFIX'}),
                                   ) );
 
   # Set up an exit handler that can do whatever is right for the
-  # system. Do not check return status since this is all done with
-  # END blocks
+  # system. This removes files at exit when requested explicitly or when
+  # system is asked to unlink_on_close but is unable to do so because
+  # of OS limitations.
+  # The latter should be achieved by using a tied filehandle.
+  # Do not check return status since this is all done with END blocks.
   _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
 
   # Return
@@ -1731,6 +1749,15 @@ descriptor before passing it to another process.
     fcntl($tmpfh, F_SETFD, 0)
         or die "Can't clear close-on-exec flag on temp fh: $!\n";
 
+=head2 Temporary files and NFS
+
+Some problems are associated with using temporary files that reside
+on NFS file systems and it is recommended that a local filesystem
+is used whenever possible. Some of the security tests will most probably
+fail when the temp file is not local. Additionally, be aware that
+the performance of I/O operations over NFS will not be as good as for
+a local disk.
+
 =head1 HISTORY
 
 Originally began life in May 1999 as an XS interface to the system
@@ -1743,8 +1770,8 @@ operating system and to help with portability.
 
 L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
 
-See L<File::MkTemp> for a different implementation of temporary
-file handling.
+See L<IO::File> and L<File::MkTemp> for different implementations of 
+temporary file handling.
 
 =head1 AUTHOR
 
index 0cf7a0b..200af4e 100644 (file)
@@ -4,6 +4,8 @@ use strict;
 use 5.005_64;
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 
+our $VERSION = '1.00';
+
 BEGIN { 
     use Exporter   ();
     @EXPORT      = qw(stat lstat);
index e1c5ec4..78a3e67 100644 (file)
@@ -1,5 +1,7 @@
 package FileCache;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 FileCache - keep more files open than the system permits
diff --git a/lib/Filter/Simple.pm b/lib/Filter/Simple.pm
new file mode 100644 (file)
index 0000000..fa883e6
--- /dev/null
@@ -0,0 +1,248 @@
+package Filter::Simple;
+
+use vars qw{ $VERSION };
+
+$VERSION = '0.01';
+
+use Filter::Util::Call;
+use Carp;
+
+sub import {
+       my $caller = caller;
+       my ($class, $filter) = @_;
+       croak "Usage: use Filter::Simple sub {...}" unless ref $filter eq CODE;
+       *{"${caller}::import"} = gen_filter_import($caller, $filter);
+       *{"${caller}::unimport"} = \*filter_unimport;
+}
+
+sub gen_filter_import {
+    my ($class, $filter) = @_;
+    return sub {
+       my ($imported_class, @args) = @_;
+       filter_add(
+               sub {
+                       my ($status, $off);
+                       my $data = "";
+                       while ($status = filter_read()) {
+                               if (m/^\s*no\s+$class\s*;\s*$/) {
+                                       $off=1;
+                                       last;
+                               }
+                               $data .= $_;
+                               $_ = "";
+                       }
+                       $_ = $data;
+                       $filter->(@args) unless $status < 0;
+                       $_ .= "no $class;\n" if $off;
+                       return length;
+               }
+       );
+    }
+}
+
+sub filter_unimport {
+       filter_del();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Filter::Simple - Simplified source filtering
+
+
+=head1 SYNOPSIS
+
+ # in MyFilter.pm:
+
+        package MyFilter;
+
+        use Filter::Simple sub { ... };
+
+
+ # in user's code:
+
+        use MyFilter;
+
+        # this code is filtered
+
+        no MyFilter;
+
+        # this code is not
+
+
+=head1 DESCRIPTION
+
+=head2 The Problem
+
+Source filtering is an immensely powerful feature of recent versions of Perl.
+It allows one to extend the language itself (e.g. the Switch module), to 
+simplify the language (e.g. Language::Pythonesque), or to completely recast the
+language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
+the full power of Perl as its own, recursively applied, macro language.
+
+The excellent Filter::Util::Call module (by Paul Marquess) provides a
+usable Perl interface to source filtering, but it is often too powerful
+and not nearly as simple as it could be.
+
+To use the module it is necessary to do the following:
+
+=over 4
+
+=item 1.
+
+Download, build, and install the Filter::Util::Call module.
+
+=item 2.
+
+Set up a module that does a C<use Filter::Util::Call>.
+
+=item 3.
+
+Within that module, create an C<import> subroutine.
+
+=item 4.
+
+Within the C<import> subroutine do a call to C<filter_add>, passing
+it either a subroutine reference.
+
+=item 5.
+
+Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
+to "prime" $_ with source code data from the source file that will
+C<use> your module. Check the status value returned to see if any
+source code was actually read in.
+
+=item 6.
+
+Process the contents of $_ to change the source code in the desired manner.
+
+=item 7.
+
+Return the status value.
+
+=item 8.
+
+If the act of unimporting your module (via a C<no>) should cause source
+code filtering to cease, create an C<unimport> subroutine, and have it call
+C<filter_del>. Make sure that the call to C<filter_read> or
+C<filter_read_exact> in step 5 will not accidentally read past the
+C<no>. Effectively this limits source code filters to line-by-line
+operation, unless the C<import> subroutine does some fancy
+pre-pre-parsing of the source code it's filtering.
+
+=back
+
+For example, here is a minimal source code filter in a module named
+BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
+to the sequence C<die 'BANG' if $BANG> in any piece of code following a
+C<use BANG;> statement (until the next C<no BANG;> statement, if any):
+
+        package BANG;
+        use Filter::Util::Call ;
+
+        sub import {
+            filter_add( sub {
+                my $caller = caller;
+                my ($status, $no_seen, $data);
+                while ($status = filter_read()) {
+                        if (/^\s*no\s+$caller\s*;\s*$/) {
+                                $no_seen=1;
+                                last;
+                        }
+                        $data .= $_;
+                        $_ = "";
+                }
+                $_ = $data;
+                s/BANG\s+BANG/die 'BANG' if \$BANG/g
+                        unless $status < 0;
+                $_ .= "no $class;\n" if $no_seen;
+                return 1;
+            })
+        }
+
+        sub unimport {
+            filter_del();
+        }
+
+        1 ;
+
+Given this level of complexity, it's perhaps not surprising that source
+code filtering is still a mystery to most users.
+
+
+=head2 A Solution
+
+The Filter::Simple module provides a vastly simplified interface to
+Filter::Util::Call; one that is sufficient for most common cases.
+
+Instead of the above process, with Filter::Simple the task of setting up
+a source code filter is reduced to:
+
+=over 4
+
+=item 1.
+
+Set up a module that does a C<use Filter::Simple sub { ... }>.
+
+=item 2.
+
+Within the anonymous subroutine passed to C<use Filter::Simple>, process the
+contents of $_ to change the source code in the desired manner.
+
+=back
+
+In other words, the previous example, would become:
+
+        package BANG;
+        use Filter::Simple sub {
+            s/BANG\s+BANG/die 'BANG' if \$BANG/g;
+        };
+
+        1 ;
+
+
+=head2 How it works
+
+The Filter::Simple module exports into the package that C<use>s it (e.g.
+package "BANG" in the above example) two automagically constructed
+subroutines -- C<import> and C<unimport> -- which take care of all the
+nasty details.
+
+In addition, the generated C<import> subroutine passes its own argument
+list to the filtering subroutine, so the BANG.pm filter could easily 
+be made parametric:
+
+        package BANG;
+        use Filter::Simple sub {
+            my ($die_msg, $var_name) = @_;
+            s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
+        };
+
+        # and in some user code:
+
+        use BANG "BOOM", "BAM;  # "BANG BANG" becomes: die 'BOOM' if $BAM
+
+
+The specified filtering subroutine is called every time a C<use BANG>
+is encountered, and passed all the source code following that call,
+up to either the next C<no BANG;> call or the end of the source file
+(whichever occurs first). Currently, any C<no BANG;> call must appear
+by itself on a separate line, or it is ignored.
+
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org)
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2000, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+and/or modified under the terms of the Perl Artistic License
+     (see http://www.perl.com/perl/misc/Artistic.html)
index 2bb0548..e933c48 100644 (file)
@@ -2,17 +2,17 @@
 
 package Getopt::Long;
 
-# RCS Status      : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp $
+# RCS Status      : $Id: GetoptLong.pl,v 2.25 2000-08-28 21:45:17+02 jv Exp jv $
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
-# Last Modified On: Mon Jul 31 21:21:13 2000
-# Update Count    : 739
+# Last Modified On: Sat Jan  6 17:12:27 2001
+# Update Count    : 748
 # Status          : Released
 
 ################ Copyright ################
 
-# This program is Copyright 1990,2000 by Johan Vromans.
+# This program is Copyright 1990,2001 by Johan Vromans.
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the Perl Artistic License or the
 # GNU General Public License as published by the Free Software
@@ -30,19 +30,24 @@ package Getopt::Long;
 
 ################ Module Preamble ################
 
+use 5.004;
+
 use strict;
 
-BEGIN {
-    require 5.004;
-    use Exporter ();
-    use vars     qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-    $VERSION     = 2.24;
+use vars qw($VERSION $VERSION_STRING);
+$VERSION        =  2.24_02;
+$VERSION_STRING = "2.24_02";
+
+use Exporter;
+use AutoLoader qw(AUTOLOAD);
 
-    @ISA         = qw(Exporter);
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+@ISA = qw(Exporter);
+%EXPORT_TAGS = qw();
+BEGIN {
+    # Init immediately so their contents can be used in the 'use vars' below.
     @EXPORT      = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-    %EXPORT_TAGS = qw();
     @EXPORT_OK   = qw();
-    use AutoLoader qw(AUTOLOAD);
 }
 
 # User visible variables.
@@ -143,7 +148,7 @@ sub new {
     my %atts = @_;
 
     # Register the callers package.
-    my $self = { caller => (caller)[0] };
+    my $self = { caller_pkg => (caller)[0] };
 
     bless ($self, $class);
 
@@ -189,7 +194,7 @@ sub getoptions {
 
     # Call main routine.
     my $ret = 0;
-    $Getopt::Long::caller = $self->{caller};
+    $Getopt::Long::caller = $self->{caller_pkg};
     eval { $ret = Getopt::Long::GetOptions (@_); };
 
     # Restore saved settings.
@@ -210,12 +215,12 @@ __END__
 
 ################ AutoLoading subroutines ################
 
-# RCS Status      : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp $
+# RCS Status      : $Id: GetoptLongAl.pl,v 2.29 2000-08-28 21:56:18+02 jv Exp jv $
 # Author          : Johan Vromans
 # Created On      : Fri Mar 27 11:50:30 1998
 # Last Modified By: Johan Vromans
-# Last Modified On: Fri Jul 28 19:12:29 2000
-# Update Count    : 97
+# Last Modified On: Tue Dec 26 18:01:16 2000
+# Update Count    : 98
 # Status          : Released
 
 sub GetOptions {
@@ -321,7 +326,9 @@ sub GetOptions {
 
        if ( ! defined $o ) {
            # empty -> '-' option
-           $opctl{$linko = $o = ''} = $c;
+           $linko = $o = '';
+           $opctl{''} = $c;
+           $bopctl{''} = $c if $bundling;
        }
        else {
            # Handle alias names
@@ -658,7 +665,8 @@ sub FindOption ($$$$$$$) {
 
     print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
 
-    return (0) unless $opt =~ /^$prefix(.*)$/s;
+    return 0 unless $opt =~ /^$prefix(.*)$/s;
+    return 0 if $opt eq "-" && !defined $opctl->{""};
 
     $opt = $+;
     my ($starter) = $1;
@@ -687,7 +695,7 @@ sub FindOption ($$$$$$$) {
 
     if ( $bundling && $starter eq '-' ) {
        # Unbundle single letter option.
-       $rest = substr ($tryopt, 1);
+       $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : "";
        $tryopt = substr ($tryopt, 0, 1);
        $tryopt = lc ($tryopt) if $ignorecase > 1;
        print STDERR ("=> $starter$tryopt unbundled from ",
@@ -1553,13 +1561,18 @@ It goes without saying that bundling can be quite confusing.
 
 =head2 The lonesome dash
 
-Some applications require the option C<-> (that's a lone dash). This
-can be achieved by adding an option specification with an empty name:
+Normally, a lone dash C<-> on the command line will not be considered
+an option. Option processing will terminate (unless "permute" is
+configured) and the dash will be left in C<@ARGV>.
+
+It is possible to get special treatment for a lone dash. This can be
+achieved by adding an option specification with an empty name, for
+example:
 
     GetOptions ('' => \$stdio);
 
-A lone dash on the command line will now be legal, and set options
-variable C<$stdio>.
+A lone dash on the command line will now be a legal option, and using
+it will set variable C<$stdio>.
 
 =head2 Argument call-back
 
index 64a03a2..d18a5a5 100644 (file)
@@ -1,5 +1,8 @@
 package I18N::Collate;
 
+use strict;
+our $VERSION = '1.00';
+
 =head1 NAME
 
 I18N::Collate - compare 8-bit scalar data according to the current locale
@@ -112,15 +115,18 @@ use warnings::register;
 
 require Exporter;
 
-@ISA = qw(Exporter);
-@EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
-@EXPORT_OK = qw();
+our @ISA = qw(Exporter);
+our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
+our @EXPORT_OK = qw();
 
 use overload qw(
 fallback       1
 cmp            collate_cmp
 );
 
+our($LOCALE, $C);
+
+our $please_use_I18N_Collate_even_if_deprecated = 0;
 sub new {
   my $new = $_[1];
 
index e7a071a..066e366 100644 (file)
@@ -1414,6 +1414,8 @@ sub stringify_polar {
 1;
 __END__
 
+=pod
+
 =head1 NAME
 
 Math::Complex - complex numbers and associated mathematical functions
index 40da9f3..a2846fe 100644 (file)
@@ -269,13 +269,13 @@ sub checksum
         );
 
     $len_msg = length($msg);
-    $num_short = $len_msg / 2;
+    $num_short = int($len_msg / 2);
     $chk = 0;
     foreach $short (unpack("S$num_short", $msg))
     {
         $chk += $short;
     }                                           # Add the odd byte in
-    $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2;
+    $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
     $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
     return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
 }
@@ -369,16 +369,17 @@ sub ping_udp
         elsif ($nfound)         # A packet is waiting
         {
             $from_msg = "";
-            $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags);
-            ($from_port, $from_ip) = sockaddr_in($from_saddr);
-            if (($from_ip eq $ip) &&        # Does the packet check out?
-                ($from_port == $self->{"port_num"}) &&
-                ($from_msg eq $msg))
-            {
-                $ret = 1;       # It's a winner
-                $done = 1;
-            }
-        }
+            $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags)
+               or last; # For example an unreachable host will make recv() fail.
+           ($from_port, $from_ip) = sockaddr_in($from_saddr);
+           if (($from_ip eq $ip) &&        # Does the packet check out?
+               ($from_port == $self->{"port_num"}) &&
+               ($from_msg eq $msg))
+           {
+               $ret = 1;       # It's a winner
+               $done = 1;
+           }
+       }
         else                    # Oops, timed out
         {
             $done = 1;
@@ -459,6 +460,11 @@ received from the remote host and the received packet contains the
 same data as the packet that was sent, the remote host is considered
 reachable.  This protocol does not require any special privileges.
 
+It should be borne in mind that, for both tcp and udp ping, a host
+will be reported as unreachable if it is not running the
+appropriate echo service.  For Unix-like systems see L<inetd(8)> for
+more information.
+
 If the "icmp" protocol is specified, the ping() method sends an icmp
 echo message to the remote host, which is what the UNIX ping program
 does.  If the echoed message is received from the remote host and
index 6cfde72..0a22389 100644 (file)
@@ -2,6 +2,7 @@ package Net::hostent;
 use strict;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 BEGIN { 
     use Exporter   ();
index b21cd04..d5ce22e 100644 (file)
@@ -2,6 +2,7 @@ package Net::netent;
 use strict;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 BEGIN { 
     use Exporter   ();
index 6aad940..2c3db88 100644 (file)
@@ -2,6 +2,7 @@ package Net::protoent;
 use strict;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 BEGIN { 
     use Exporter   ();
index c892af0..18c7fb5 100644 (file)
@@ -2,6 +2,7 @@ package Net::servent;
 use strict;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 BEGIN {
     use Exporter   ();
index 37ed68f..35d0186 100644 (file)
@@ -150,8 +150,8 @@ C<"">.
 =item * Unknown command "I<CMD>"
 
 An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
-C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, C<=for>, C<=pod>,
-C<=cut>
+C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
+C<=for>, C<=pod>, C<=cut>
 
 =item * Unknown interior-sequence "I<SEQ>"
 
@@ -355,6 +355,8 @@ my %VALID_COMMANDS = (
     'cut'    =>  1,
     'head1'  =>  1,
     'head2'  =>  1,
+    'head3'  =>  1,
+    'head4'  =>  1,
     'over'   =>  1,
     'back'   =>  1,
     'item'   =>  1,
index 44619d5..960b847 100644 (file)
@@ -2,12 +2,16 @@ package Pod::Functions;
 
 #:vi:set ts=20
 
+our $VERSION = '1.00';
+
 require Exporter;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
 
-%Type_Description = (
+our(%Kinds, %Type, %Flavor);
+
+our %Type_Description = (
     'ARRAY'    => 'Functions for real @ARRAYs',
     'Binary'   => 'Functions for fixed length data or records',
     'File'     => 'Functions for filehandles, files, or directories',
@@ -30,7 +34,7 @@ require Exporter;
     'Namespace'        => 'Keywords altering or affecting scoping of identifiers',
 );
 
-@Type_Order = qw{
+our @Type_Order = qw{
     String
     Regexp
     Math
@@ -57,20 +61,20 @@ while (<DATA>) {
     chomp;
     s/#.*//;
     next unless $_;
-    ($name, $type, $text) = split " ", $_, 3;
+    my($name, $type, $text) = split " ", $_, 3;
     $Type{$name} = $type;
     $Flavor{$name} = $text;
-    for $type ( split /[,\s]+/, $type ) {
-       push @{$Kinds{$type}}, $name;
+    for my $t ( split /[,\s]+/, $type ) {
+       push @{$Kinds{$t}}, $name;
     }
 } 
 
 close DATA;
 
 unless (caller) { 
-    foreach $type ( @Type_Order ) {
-       $list = join(", ", sort @{$Kinds{$type}});
-       $typedesc = $Type_Description{$type} . ":";
+    foreach my $type ( @Type_Order ) {
+       my $list = join(", ", sort @{$Kinds{$type}});
+       my $typedesc = $Type_Description{$type} . ":";
        write;
     } 
 }
index f70a42b..4316823 100644 (file)
@@ -12,7 +12,6 @@ use Config;
 use Cwd;
 use File::Spec::Unix;
 use Getopt::Long;
-use Pod::Functions;
 
 use locale;    # make \w work right in non-ASCII lands
 
index 0fdb6d0..84c8f66 100644 (file)
@@ -1,5 +1,5 @@
 # Pod::Man -- Convert POD data to formatted *roff input.
-# $Id: Man.pm,v 1.8 2000/10/10 02:14:31 eagle Exp $
+# $Id: Man.pm,v 1.12 2000/12/25 12:56:12 eagle Exp $
 #
 # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
 #
@@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
 # Perl core and too many things could munge CVS magic revision strings.
 # This number should ideally be the same as the CVS revision in podlators,
 # however.
-$VERSION = 1.08;
+$VERSION = 1.12;
 
 
 ############################################################################
@@ -279,33 +279,6 @@ sub protect {
     $_;
 }
 
-# Given a command and a single argument that may or may not contain double
-# quotes, handle double-quote formatting for it.  If there are no double
-# quotes, just return the command followed by the argument in double quotes.
-# If there are double quotes, use an if statement to test for nroff, and for
-# nroff output the command followed by the argument in double quotes with
-# embedded double quotes doubled.  For other formatters, remap paired double
-# quotes to `` and ''.
-sub switchquotes {
-    my $command = shift;
-    local $_ = shift;
-    my $extra = shift;
-    s/\\\*\([LR]\"/\"/g;
-    if (/\"/) {
-        s/\"/\"\"/g;
-        my $troff = $_;
-        $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
-        s/\"/\"\"/g if $extra;
-        $troff =~ s/\"/\"\"/g if $extra;
-        $_ = qq("$_") . ($extra ? " $extra" : '');
-        $troff = qq("$troff") . ($extra ? " $extra" : '');
-        return ".if n $command $_\n.el $command $troff\n";
-    } else {
-        $_ = qq("$_") . ($extra ? " $extra" : '');
-        return "$command $_\n";
-    }
-}
-
 # Translate a font string into an escape.
 sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
 
@@ -568,7 +541,7 @@ sub textblock {
     $text = $self->parse ($text, @_);
     $text =~ s/\n\s*$/\n/;
     $self->makespace;
-    $self->output (protect $self->mapfonts ($text));
+    $self->output (protect $self->textmapfonts ($text));
     $self->outindex;
     $$self{NEEDSPACE} = 1;
 }
@@ -661,7 +634,7 @@ sub cmd_head1 {
         $$self{ITEMS} = 0;
         $self->output (".PD\n");
     }
-    $self->output (switchquotes ('.SH', $self->mapfonts ($_)));
+    $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_)));
     $self->outindex (($_ eq 'NAME') ? () : ('Header', $_));
     $$self{NEEDSPACE} = 0;
 }
@@ -675,11 +648,41 @@ sub cmd_head2 {
         $$self{ITEMS} = 0;
         $self->output (".PD\n");
     }
-    $self->output (switchquotes ('.Sh', $self->mapfonts ($_)));
+    $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_)));
     $self->outindex ('Subsection', $_);
     $$self{NEEDSPACE} = 0;
 }
 
+# Third level heading.
+sub cmd_head3 {
+    my $self = shift;
+    local $_ = $self->parse (@_);
+    s/\s+$//;
+    if ($$self{ITEMS} > 1) {
+        $$self{ITEMS} = 0;
+        $self->output (".PD\n");
+    }
+    $self->makespace;
+    $self->output ($self->switchquotes ('.I', $self->mapfonts ($_)));
+    $self->outindex ('Subsection', $_);
+    $$self{NEEDSPACE} = 1;
+}
+
+# Fourth level heading.
+sub cmd_head4 {
+    my $self = shift;
+    local $_ = $self->parse (@_);
+    s/\s+$//;
+    if ($$self{ITEMS} > 1) {
+        $$self{ITEMS} = 0;
+        $self->output (".PD\n");
+    }
+    $self->makespace;
+    $self->output ($self->textmapfonts ($_) . "\n");
+    $self->outindex ('Subsection', $_);
+    $$self{NEEDSPACE} = 1;
+}
+
 # Start a list.  For indents after the first, wrap the outside indent in .RS
 # so that hanging paragraph tags will be correct.
 sub cmd_over {
@@ -736,9 +739,9 @@ sub cmd_item {
         $self->output (".RE\n");
         $$self{WEIRDINDENT} = 0;
     }
-    $_ = $self->mapfonts ($_);
+    $_ = $self->textmapfonts ($_);
     $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
-    $self->output (switchquotes ('.Ip', $_, $$self{INDENT}));
+    $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT}));
     $self->outindex ($index ? ('Item', $index) : ());
     $$self{NEEDSPACE} = 0;
     $$self{ITEMS}++;
@@ -844,18 +847,52 @@ sub buildlink {
 
 # At this point, we'll have embedded font codes of the form \f(<font>[SE]
 # where <font> is one of B, I, or F.  Turn those into the right font start
-# or end codes.  B<someI<thing> else> should map to \fBsome\f(BIthing\fB
-# else\fR.  The old pod2man didn't get this right; the second \fB was \fR,
-# so nested sequences didn't work right.  We take care of this by using
-# variables as a combined pointer to our current font sequence, and set each
-# to the number of current nestings of start tags for that font.  Use them
-# as a vector to look up what font sequence to use.
+# or end codes.  The old pod2man didn't get B<someI<thing> else> right;
+# after I<> it switched back to normal text rather than bold.  We take care
+# of this by using variables as a combined pointer to our current font
+# sequence, and set each to the number of current nestings of start tags for
+# that font.  Use them as a vector to look up what font sequence to use.
+#
+# \fP changes to the previous font, but only one previous font is kept.  We
+# don't know what the outside level font is; normally it's R, but if we're
+# inside a heading it could be something else.  So arrange things so that
+# the outside font is always the "previous" font and end with \fP instead of
+# \fR.  Idea from Zack Weinberg.
 sub mapfonts {
     my $self = shift;
     local $_ = shift;
 
     my ($fixed, $bold, $italic) = (0, 0, 0);
     my %magic = (F => \$fixed, B => \$bold, I => \$italic);
+    my $last = '\fR';
+    s { \\f\((.)(.) } {
+        my $sequence = '';
+        my $f;
+        if ($last ne '\fR') { $sequence = '\fP' }
+        ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
+        $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
+        if ($f eq $last) {
+            '';
+        } else {
+            if ($f ne '\fR') { $sequence .= $f }
+            $last = $f;
+            $sequence;
+        }
+    }gxe;
+    $_;
+}
+
+# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
+# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
+# than R, presumably because \f(CW doesn't actually do a font change.  To
+# work around this, use a separate textmapfonts for text blocks where the
+# default font is always R and only use the smart mapfonts for headings.
+sub textmapfonts {
+    my $self = shift;
+    local $_ = shift;
+
+    my ($fixed, $bold, $italic) = (0, 0, 0);
+    my %magic = (F => \$fixed, B => \$bold, I => \$italic);
     s { \\f\((.)(.) } {
         ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
         $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
@@ -1020,6 +1057,44 @@ sub outindex {
 # Output text to the output device.
 sub output { print { $_[0]->output_handle } $_[1] }
 
+# Given a command and a single argument that may or may not contain double
+# quotes, handle double-quote formatting for it.  If there are no double
+# quotes, just return the command followed by the argument in double quotes.
+# If there are double quotes, use an if statement to test for nroff, and for
+# nroff output the command followed by the argument in double quotes with
+# embedded double quotes doubled.  For other formatters, remap paired double
+# quotes to LQUOTE and RQUOTE.
+sub switchquotes {
+    my $self = shift;
+    my $command = shift;
+    local $_ = shift;
+    my $extra = shift;
+    s/\\\*\([LR]\"/\"/g;
+
+    # We also have to deal with \*C` and \*C', which are used to add the
+    # quotes around C<> text, since they may expand to " and if they do this
+    # confuses the .SH macros and the like no end.  Expand them ourselves.
+    # If $extra is set, we're dealing with =item, which in most nroff macro
+    # sets requires an extra level of quoting of double quotes.
+    my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
+    if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) {
+        s/\"/\"\"/g;
+        my $troff = $_;
+        $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
+        s/\\\*\(C\`/$$self{LQUOTE}/g;
+        s/\\\*\(C\'/$$self{RQUOTE}/g;
+        $troff =~ s/\\\*\(C[\'\`]//g;
+        s/\"/\"\"/g if $extra;
+        $troff =~ s/\"/\"\"/g if $extra;
+        $_ = qq("$_") . ($extra ? " $extra" : '');
+        $troff = qq("$troff") . ($extra ? " $extra" : '');
+        return ".if n $command $_\n.el $command $troff\n";
+    } else {
+        $_ = qq("$_") . ($extra ? " $extra" : '');
+        return "$command $_\n";
+    }
+}
+
 __END__
 
 .\" These are some extra bits of roff that I don't want to lose track of
index d86d823..e7c820f 100644 (file)
@@ -109,33 +109,39 @@ Some example section specifications follow.
 
 =over 4
 
-=item
+=item *
+
 Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
 
 C<NAME|SYNOPSIS>
 
-=item
+=item *
+
 Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
 section:
 
 C<DESCRIPTION/Question|Answer>
 
-=item
+=item *
+
 Match the C<Comments> subsection of I<all> sections:
 
 C</Comments>
 
-=item
+=item *
+
 Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
 
 C<DESCRIPTION/!Comments>
 
-=item
+=item *
+
 Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
 
 C<DESCRIPTION/!.+>
 
-=item
+=item *
+
 Match all top level sections but none of their subsections:
 
 C</!.+>
index 5a7bab8..5f2dae0 100644 (file)
@@ -1,5 +1,5 @@
 # Pod::Text -- Convert POD data to formatted ASCII text.
-# $Id: Text.pm,v 2.6 2000/10/10 02:13:17 eagle Exp $
+# $Id: Text.pm,v 2.7 2000/11/19 04:47:50 eagle Exp $
 #
 # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
 #
@@ -37,7 +37,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
 # Perl core and too many things could munge CVS magic revision strings.
 # This number should ideally be the same as the CVS revision in podlators,
 # however.
-$VERSION = 2.06;
+$VERSION = 2.07;
 
 
 ############################################################################
@@ -173,7 +173,7 @@ sub initialize {
     $$self{width}    = 76 unless defined $$self{width};
 
     # Figure out what quotes we'll be using for C<> text.
-    $$self{quotes} ||= "'";
+    $$self{quotes} ||= '"';
     if ($$self{quotes} eq 'none') {
         $$self{LQUOTE} = $$self{RQUOTE} = '';
     } elsif (length ($$self{quotes}) == 1) {
@@ -376,6 +376,32 @@ sub cmd_head2 {
     }
 }
 
+# Third level heading.
+sub cmd_head3 {
+    my $self = shift;
+    local $_ = shift;
+    s/\s+$//;
+    $_ = $self->interpolate ($_, shift);
+    if ($$self{alt}) {
+        $self->output ("\n=    $_    =\n\n");
+    } else {
+        $self->output (' ' x ($$self{indent} * 2 / 3 + 0.5) . $_ . "\n\n");
+    }
+}
+
+# Third level heading.
+sub cmd_head4 {
+    my $self = shift;
+    local $_ = shift;
+    s/\s+$//;
+    $_ = $self->interpolate ($_, shift);
+    if ($$self{alt}) {
+        $self->output ("\n-    $_    -\n\n");
+    } else {
+        $self->output (' ' x ($$self{indent} * 3 / 4 + 0.5) . $_ . "\n\n");
+    }
+}
+
 # Start a list.
 sub cmd_over {
     my $self = shift;
index 10e1d9f..e943216 100644 (file)
@@ -1,5 +1,5 @@
 # Pod::Text::Color -- Convert POD data to formatted color ASCII text
-# $Id: Color.pm,v 0.5 1999/09/20 10:15:16 eagle Exp $
+# $Id: Color.pm,v 0.6 2000/12/25 12:52:39 eagle Exp $
 #
 # Copyright 1999 by Russ Allbery <rra@stanford.edu>
 #
@@ -26,8 +26,11 @@ use vars qw(@ISA $VERSION);
 
 @ISA = qw(Pod::Text);
 
-# Use the CVS revision of this file as its version number.
-($VERSION = (split (' ', q$Revision: 0.5 $ ))[1]) =~ s/\.(\d)$/.0$1/;
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 0.06;
 
 
 ############################################################################
diff --git a/lib/Pod/Text/Overstrike.pm b/lib/Pod/Text/Overstrike.pm
new file mode 100644 (file)
index 0000000..c9f0789
--- /dev/null
@@ -0,0 +1,160 @@
+# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
+# $Id: Overstrike.pm,v 1.1 2000/12/25 12:51:23 eagle Exp $
+#
+# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
+#   (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This was written because the output from:
+#
+#     pod2text Text.pm > plain.txt; less plain.txt
+#
+# is not as rich as the output from
+#
+#     pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
+#
+# and because both Pod::Text::Color and Pod::Text::Termcap are not device
+# independent.
+
+############################################################################
+# Modules and declarations
+############################################################################
+
+package Pod::Text::Overstrike;
+
+require 5.004;
+
+use Pod::Text ();
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw(Pod::Text);
+
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 1.01;
+
+
+############################################################################
+# Overrides
+############################################################################
+
+# Make level one headings bold, overridding any existing formatting.
+sub cmd_head1 {
+    my $self = shift;
+    local $_ = shift;
+    s/\s+$//;
+    s/(.)\cH\1//g;
+    s/_\cH//g;
+    s/(.)/$1\b$1/g;
+    $self->SUPER::cmd_head1 ($_);
+}
+
+# Make level two headings bold, overriding any existing formatting.
+sub cmd_head2 {
+    my $self = shift;
+    local $_ = shift;
+    s/\s+$//;
+    s/(.)\cH\1//g;
+    s/_\cH//g;
+    s/(.)/$1\b$1/g;
+    $self->SUPER::cmd_head2 ($_);
+}
+
+# Make level three headings underscored, overriding any existing formatting.
+sub cmd_head3 {
+    my $self = shift;
+    local $_ = shift;
+    s/\s+$//;
+    s/(.)\cH\1//g;
+    s/_\cH//g;
+    s/(.)/_\b$1/g;
+    $self->SUPER::cmd_head3 ($_);
+}
+
+# Fix the various interior sequences.
+sub seq_b { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/$1\b$1/g; $_ }
+sub seq_f { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ }
+sub seq_i { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ }
+
+# We unfortunately have to override the wrapping code here, since the normal
+# wrapping code gets really confused by all the escape sequences.
+sub wrap {
+    my $self = shift;
+    local $_ = shift;
+    my $output = '';
+    my $spaces = ' ' x $$self{MARGIN};
+    my $width = $$self{width} - $$self{MARGIN};
+    while (length > $width) {
+        if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})\s+//
+            || s/^((?:(?:[^\n]\cH)?[^\n]){$width})//) {
+            $output .= $spaces . $1 . "\n";
+        } else {
+            last;
+        }
+    }
+    $output .= $spaces . $_;
+    $output =~ s/\s+$/\n\n/;
+    $output;
+}
+
+############################################################################
+# Module return value and documentation
+############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text::Overstrike - Convert POD data to formatted overstrike text
+
+=head1 SYNOPSIS
+
+    use Pod::Text::Overstrike;
+    my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78);
+
+    # Read POD from STDIN and write to STDOUT.
+    $parser->parse_from_filehandle;
+
+    # Read POD from file.pod and write to file.txt.
+    $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights
+output text using overstrike sequences, in a manner similar to nroff.
+Characters in bold text are overstruck (character, backspace, character) and
+characters in underlined text are converted to overstruck underscores
+(underscore, backspace, character).  This format was originally designed for
+hardcopy terminals and/or lineprinters, yet is readable on softcopy (CRT)
+terminals.
+
+Overstruck text is best viewed by page-at-a-time programs that take
+advantage of the terminal's B<stand-out> and I<underline> capabilities, such
+as the less program on Unix.
+
+Apart from the overstrike, it in all ways functions like Pod::Text.  See
+L<Pod::Text> for details and available options.
+
+=head1 BUGS
+
+Currently, the outermost formatting instruction wins, so for example
+underlined text inside a region of bold text is displayed as simply bold.
+There may be some better approach possible.
+
+=head1 SEE ALSO
+
+L<Pod::Text|Pod::Text>, L<Pod::Parser|Pod::Parser>
+
+=head1 AUTHOR
+
+Joe Smith E<lt>Joe.Smith@inwap.comE<gt>, using the framework created by Russ
+Allbery E<lt>rra@stanford.eduE<gt>.
+
+=cut
index 7e89ec6..333852a 100644 (file)
@@ -1,5 +1,5 @@
 # Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
-# $Id: Termcap.pm,v 0.4 1999/09/20 10:17:45 eagle Exp $
+# $Id: Termcap.pm,v 1.0 2000/12/25 12:52:48 eagle Exp $
 #
 # Copyright 1999 by Russ Allbery <rra@stanford.edu>
 #
@@ -27,8 +27,11 @@ use vars qw(@ISA $VERSION);
 
 @ISA = qw(Pod::Text);
 
-# Use the CVS revision of this file as its version number.
-($VERSION = (split (' ', q$Revision: 0.4 $ ))[1]) =~ s/\.(\d)$/.0$1/;
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 1.00;
 
 
 ############################################################################
index 9a229a7..58c7543 100644 (file)
@@ -2,8 +2,11 @@ package Search::Dict;
 require 5.000;
 require Exporter;
 
-@ISA = qw(Exporter);
-@EXPORT = qw(look);
+use strict;
+
+our $VERSION = '1.00';
+our @ISA = qw(Exporter);
+our @EXPORT = qw(look);
 
 =head1 NAME
 
@@ -30,9 +33,9 @@ If I<$fold> is true, ignore case.
 =cut
 
 sub look {
-    local(*FH,$key,$dict,$fold) = @_;
+    my($fh,$key,$dict,$fold) = @_;
     local($_);
-    my(@stat) = stat(FH)
+    my(@stat) = stat($fh)
        or return -1;
     my($size, $blksize) = @stat[7,11];
     $blksize ||= 8192;
@@ -41,10 +44,10 @@ sub look {
     my($min, $max, $mid) = (0, int($size / $blksize));
     while ($max - $min > 1) {
        $mid = int(($max + $min) / 2);
-       seek(FH, $mid * $blksize, 0)
+       seek($fh, $mid * $blksize, 0)
            or return -1;
-       <FH> if $mid;                   # probably a partial line
-       $_ = <FH>;
+       <$fh> if $mid;                  # probably a partial line
+       $_ = <$fh>;
        chop;
        s/[^\w\s]//g if $dict;
        $_ = lc $_ if $fold;
@@ -56,19 +59,19 @@ sub look {
        }
     }
     $min *= $blksize;
-    seek(FH,$min,0)
+    seek($fh,$min,0)
        or return -1;
-    <FH> if $min;
+    <$fh> if $min;
     for (;;) {
-       $min = tell(FH);
-       defined($_ = <FH>)
+       $min = tell($fh);
+       defined($_ = <$fh>)
            or last;
        chop;
        s/[^\w\s]//g if $dict;
        $_ = lc $_ if $fold;
        last if $_ ge $key;
     }
-    seek(FH,$min,0);
+    seek($fh,$min,0);
     $min;
 }
 
index 5f56922..08104f4 100644 (file)
@@ -1,5 +1,7 @@
 package SelectSaver;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 SelectSaver - save and restore selected file handle
index 0954000..6d31ab7 100644 (file)
@@ -1,7 +1,9 @@
 package Term::Cap;
 use Carp;
 
-# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
+our $VERSION = '1.00';
+
+# Last updated: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
 
 # TODO:
 # support Berkeley DB termcaps
index 445dfca..6cf6a0c 100644 (file)
@@ -2,8 +2,10 @@ package Term::Complete;
 require 5.000;
 require Exporter;
 
-@ISA = qw(Exporter);
-@EXPORT = qw(Complete);
+use strict;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(Complete);
+our $VERSION = '1.2';
 
 #      @(#)complete.pl,v1.2            (me@anywhere.EBay.Sun.COM) 09/23/91
 
@@ -64,6 +66,7 @@ Wayne Thompson
 
 =cut
 
+our($complete, $kill, $erase1, $erase2);
 CONFIG: {
     $complete = "\004";
     $kill     = "\025";
@@ -72,7 +75,7 @@ CONFIG: {
 }
 
 sub Complete {
-    my($prompt, @cmp_list, $cmp, $test, $l, @match);
+    my($prompt, @cmp_lst, $cmp, $test, $l, @match);
     my ($return, $r) = ("", 0);
 
     $return = "";
index 8bb8205..491ce79 100644 (file)
@@ -159,22 +159,27 @@ particular used C<Term::ReadLine::*> package).
 
 =cut
 
+use strict;
+
 package Term::ReadLine::Stub;
-@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
 
 $DB::emacs = $DB::emacs;       # To peacify -w
+our @rl_term_set;
 *rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
 
 sub ReadLine {'Term::ReadLine::Stub'}
 sub readline {
   my $self = shift;
   my ($in,$out,$str) = @$self;
-  print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2]; 
+  my $prompt = shift;
+  print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; 
   $self->register_Tk 
      if not $Term::ReadLine::registered and $Term::ReadLine::toloop
        and defined &Tk::DoOneEvent;
   #$str = scalar <$in>;
   $str = $self->get_line;
+  $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
   print $out $rl_term_set[3]; 
   # bug in 5.000: chomping empty string creats length -1:
   chomp $str if defined $str;
@@ -185,7 +190,9 @@ sub addhistory {}
 sub findConsole {
     my $console;
 
-    if (-e "/dev/tty") {
+    if ($^O eq 'MacOS') {
+        $console = "Dev:Console";
+    } elsif (-e "/dev/tty") {
        $console = "/dev/tty";
     } elsif (-e "con" or $^O eq 'MSWin32') {
        $console = "con";
@@ -204,7 +211,7 @@ sub findConsole {
       }
     }
 
-    $consoleOUT = $console;
+    my $consoleOUT = $console;
     $console = "&STDIN" unless defined $console;
     if (!defined $consoleOUT) {
       $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
@@ -218,19 +225,19 @@ sub new {
   #local (*FIN, *FOUT);
   my ($FIN, $FOUT, $ret);
   if (@_==2) {
-    ($console, $consoleOUT) = findConsole;
+    my($console, $consoleOUT) = findConsole;
 
     open(FIN, "<$console"); 
     open(FOUT,">$consoleOUT");
     #OUT->autoflush(1);                # Conflicts with debugger?
-    $sel = select(FOUT);
+    my $sel = select(FOUT);
     $| = 1;                            # for DB::OUT
     select($sel);
     $ret = bless [\*FIN, \*FOUT];
   } else {                     # Filehandles supplied
     $FIN = $_[2]; $FOUT = $_[3];
     #OUT->autoflush(1);                # Conflicts with debugger?
-    $sel = select($FOUT);
+    my $sel = select($FOUT);
     $| = 1;                            # for DB::OUT
     select($sel);
     $ret = bless [$FIN, $FOUT];
@@ -262,6 +269,8 @@ sub Features { \%features }
 
 package Term::ReadLine;                # So late to allow the above code be defined?
 
+our $VERSION = '1.00';
+
 my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
 if ($which) {
   if ($which =~ /\bgnu\b/i){
@@ -281,7 +290,7 @@ if ($which) {
 
 # To make possible switch off RL in debugger: (Not needed, work done
 # in debugger).
-
+our @ISA;
 if (defined &Term::ReadLine::Gnu::readline) {
   @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
 } elsif (defined &Term::ReadLine::Perl::readline) {
@@ -294,10 +303,11 @@ package Term::ReadLine::TermCap;
 
 # Prompt-start, prompt-end, command-line-start, command-line-end
 #     -- zero-width beautifies to emit around prompt and the command line.
-@rl_term_set = ("","","","");
+our @rl_term_set = ("","","","");
 # string encoded:
-$rl_term_set = ',,,';
+our $rl_term_set = ',,,';
 
+our $terminal;
 sub LoadTermCap {
   return if defined $terminal;
   
@@ -325,8 +335,10 @@ sub ornaments {
 
 package Term::ReadLine::Tk;
 
+our($count_handle, $count_DoOne, $count_loop);
 $count_handle = $count_DoOne = $count_loop = 0;
 
+our($giveup);
 sub handle {$giveup = 1; $count_handle++}
 
 sub Tk_loop {
index c18d381..60e9f7e 100644 (file)
@@ -177,9 +177,9 @@ __END__
 
 =head1 DESCRIPTION
 
-L<Test::Harness> expects to see particular output when it executes
-tests.  This module aims to make writing proper test scripts just a
-little bit easier (and less error prone :-).
+L<Test::Harness|Test::Harness> expects to see particular output when it
+executes tests.  This module aims to make writing proper test scripts just
+a little bit easier (and less error prone :-).
 
 =head1 TEST TYPES
 
index a17bdbf..f438af6 100644 (file)
@@ -1,17 +1,17 @@
+# -*- Mode: cperl; cperl-indent-level: 4 -*-
 package Test::Harness;
 
 use 5.005_64;
 use Exporter;
 use Benchmark;
 use Config;
-use FileHandle;
 use strict;
 
 our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
     $columns, @ISA, @EXPORT, @EXPORT_OK);
 $have_devel_corestack = 0;
 
-$VERSION = "1.1604";
+$VERSION = "1.1607";
 
 $ENV{HARNESS_ACTIVE} = 1;
 
@@ -72,21 +72,20 @@ sub runtests {
        $ml = "\r$blank\r$leader"
            if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose;
        print $leader;
-       my $fh = new FileHandle;
-       $fh->open($test) or print "can't open $test. $!\n";
+       open(my $fh, $test) or print "can't open $test. $!\n";
        my $first = <$fh>;
        my $s = $switches;
        $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
            if exists $ENV{'HARNESS_PERL_SWITCHES'};
        $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
            if $first =~ /^#!.*\bperl.*-\w*T/;
-       $fh->close or print "can't close $test. $!\n";
+       close($fh) or print "can't close $test. $!\n";
        my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
                ? "./perl -I../lib ../utils/perlcc $test "
                  . "-run 2>> ./compilelog |" 
                : "$^X $s $test|";
        $cmd = "MCR $cmd" if $^O eq 'VMS';
-       $fh->open($cmd) or print "can't run $test. $!\n";
+       open($fh, $cmd) or print "can't run $test. $!\n";
        $ok = $next = $max = 0;
        @failed = ();
        my %todo = ();
@@ -120,7 +119,7 @@ sub runtests {
                        $ok++;
                        $totok++;
                    }
-               } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?/) {
+               } elsif (/^ok\s*(\d*) *(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?$/) {
                    $this = $1 if $1 > 0;
                    print "${ml}ok $this/$max" if $ml;
                    $ok++;
@@ -137,6 +136,15 @@ sub runtests {
                      $skip_reason = $reason;
                    }
                    $bonus++, $totbonus++ if $todo{$this};
+               } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) {
+                   $this = $1 if $1 > 0;
+                   print "${ml}ok $this/$max" if $ml;
+                   $ok++;
+                   $totok++;
+               } else {
+                   # an ok or not ok not matching the 3 cases above...
+                   # just ignore it for compatibility with TEST
+                   next;
                }
                if ($this > $next) {
                    # print "Test output counter mismatch [test $this]\n";
@@ -148,9 +156,11 @@ sub runtests {
                    $next = $this;
                }
                $next = $this + 1;
-           }
+           } elsif (/^Bail out!\s*(.*)/i) { # magic words
+                die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
+            }
        }
-       $fh->close; # must close to reap child resource values
+       close($fh); # must close to reap child resource values
        my $wstatus = $ignore_exitcode ? 0 : $?;        # Can trust $? ?
        my $estatus;
        $estatus = ($^O eq 'VMS'
@@ -249,7 +259,7 @@ sub runtests {
        }
     }
     my $t_total = timediff(new Benchmark, $t_start);
-    
+
     if ($^O eq 'VMS') {
        if (defined $old5lib) {
            $ENV{PERL5LIB} = $old5lib;
@@ -452,7 +462,7 @@ script supplies test numbers again. So the following test script
     ok
     END
 
-will generate 
+will generate
 
     FAILED tests 1, 3, 6
     Failed 3/6 tests, 50.00% okay
@@ -467,15 +477,26 @@ script(s). The default value is C<-w>.
 
 If the standard output line contains substring C< # Skip> (with
 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
-counted as a skipped test.  If the whole testscript succeeds, the
-count of skipped tests is included in the generated output.
+counted as a skipped test.  In no other circumstance is anything
+allowed to follow C<ok> or C<ok NUMBER>.  If the whole testscript
+succeeds, the count of skipped tests is included in the generated
+output.
 
-C<Test::Harness> reports the text after C< # Skip(whatever)> as a
-reason for skipping.  Similarly, one can include a similar explanation
-in a C<1..0> line emitted if the test is skipped completely:
+C<Test::Harness> reports the text after C< # Skip\S*\s+> as a reason
+for skipping.  Similarly, one can include a similar explanation in a
+C<1..0> line emitted if the test is skipped completely:
 
   1..0 # Skipped: no leverage found
 
+As an emergency measure, a test script can decide that further tests
+are useless (e.g. missing dependencies) and testing should stop
+immediately. In that case the test script prints the magic words
+
+  Bail out!
+
+to standard output. Any message after these words will be displayed by
+C<Test::Harness> as the reason why testing is stopped.
+
 =head1 EXPORT
 
 C<&runtests> is exported by Test::Harness per default.
@@ -506,6 +527,11 @@ printed in a message similar to the above.
 If not all tests were successful, the script dies with one of the
 above messages.
 
+=item C<FAILED--Further testing stopped%s>
+
+If a single subtest decides that further testing will not make sense,
+the script dies with this message.
+
 =back
 
 =head1 ENVIRONMENT
index d4f12d0..08143fe 100644 (file)
@@ -2,6 +2,8 @@ package Text::Abbrev;
 require 5.005;         # Probably works on earlier versions too.
 require Exporter;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 abbrev - create an abbreviation table from a list
index 2a6afc3..23eace9 100644 (file)
@@ -214,21 +214,27 @@ demonstrating:
 =over 4
 
 =item 0
+
 a simple word
 
 =item 1
+
 multiple spaces are skipped because of our $delim
 
 =item 2
+
 use of quotes to include a space in a word
 
 =item 3
+
 use of a backslash to include a space in a word
 
 =item 4
+
 use of a backslash to remove the special meaning of a double-quote
 
 =item 5
+
 another simple word (note the lack of effect of the
 backslashed double-quote)
 
index e3b85d4..f4c6193 100644 (file)
@@ -34,47 +34,43 @@ sub POP
  $val;
 }
 
-sub SPLICE
-{
- my $obj = shift;
- my $sz  = $obj->FETCHSIZE;
- my $off = (@_) ? shift : 0;
- $off += $sz if ($off < 0);
- my $len = (@_) ? shift : $sz - $off;
- my @result;
- for (my $i = 0; $i < $len; $i++)
-  {
-   push(@result,$obj->FETCH($off+$i));
-  }
- if (@_ > $len)
-  {
-   # Move items up to make room
-   my $d = @_ - $len;
-   my $e = $off+$len;
-   $obj->EXTEND($sz+$d);
-   for (my $i=$sz-1; $i >= $e; $i--)
-    {
-     my $val = $obj->FETCH($i);
-     $obj->STORE($i+$d,$val);
+sub SPLICE {
+    my $obj = shift;
+    my $sz  = $obj->FETCHSIZE;
+    my $off = (@_) ? shift : 0;
+    $off += $sz if ($off < 0);
+    my $len = (@_) ? shift : $sz - $off;
+    $len += $sz - $off if $len < 0;
+    my @result;
+    for (my $i = 0; $i < $len; $i++) {
+        push(@result,$obj->FETCH($off+$i));
     }
-  }
- elsif (@_ < $len)
-  {
-   # Move items down to close the gap
-   my $d = $len - @_;
-   my $e = $off+$len;
-   for (my $i=$off+$len; $i < $sz; $i++)
-    {
-     my $val = $obj->FETCH($i);
-     $obj->STORE($i-$d,$val);
+    $off = $sz if $off > $sz;
+    $len -= $off + $len - $sz if $off + $len > $sz;
+    if (@_ > $len) {
+        # Move items up to make room
+        my $d = @_ - $len;
+        my $e = $off+$len;
+        $obj->EXTEND($sz+$d);
+        for (my $i=$sz-1; $i >= $e; $i--) {
+            my $val = $obj->FETCH($i);
+            $obj->STORE($i+$d,$val);
+        }
     }
-   $obj->STORESIZE($sz-$d);
-  }
- for (my $i=0; $i < @_; $i++)
-  {
-   $obj->STORE($off+$i,$_[$i]);
-  }
- return @result;
+    elsif (@_ < $len) {
+        # Move items down to close the gap
+        my $d = $len - @_;
+        my $e = $off+$len;
+        for (my $i=$off+$len; $i < $sz; $i++) {
+            my $val = $obj->FETCH($i);
+            $obj->STORE($i-$d,$val);
+        }
+        $obj->STORESIZE($sz-$d);
+    }
+    for (my $i=0; $i < @_; $i++) {
+        $obj->STORE($off+$i,$_[$i]);
+    }
+    return @result;
 }
 
 sub EXISTS {
index 2244711..7399d8b 100644 (file)
@@ -1,5 +1,7 @@
 package Tie::Hash;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 Tie::Hash, Tie::StdHash - base class definitions for tied hashes
index ffa9eb2..8555635 100644 (file)
@@ -1,5 +1,7 @@
 package Tie::RefHash;
 
+our $VERSION = '1.21';
+
 =head1 NAME
 
 Tie::RefHash - use references as hash keys
@@ -9,17 +11,26 @@ Tie::RefHash - use references as hash keys
     require 5.004;
     use Tie::RefHash;
     tie HASHVARIABLE, 'Tie::RefHash', LIST;
+    tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
 
     untie HASHVARIABLE;
 
 =head1 DESCRIPTION
 
-This module provides the ability to use references as hash keys if
-you first C<tie> the hash variable to this module.
+This module provides the ability to use references as hash keys if you
+first C<tie> the hash variable to this module.  Normally, only the
+keys of the tied hash itself are preserved as references; to use
+references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
+included as part of Tie::Hash.
 
 It is implemented using the standard perl TIEHASH interface.  Please
 see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
 
+The Nestable version works by looking for hash references being stored
+and converting them to tied hashes so that they too can have
+references as keys.  This will happen without warning whenever you
+store a reference to one of your own hashes in the tied hash.
+
 =head1 EXAMPLE
 
     use Tie::RefHash;
@@ -36,6 +47,11 @@ see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
        print ref($_), "\n";
     }
 
+    tie %h, 'Tie::RefHash::Nestable';
+    $h{$a}->{$b} = 1;
+    for (keys %h, keys %{$h{$a}}) {
+       print ref($_), "\n";
+    }
 
 =head1 AUTHOR
 
@@ -68,7 +84,17 @@ sub TIEHASH {
 
 sub FETCH {
   my($s, $k) = @_;
-  (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k};
+  if (ref $k) {
+      if (defined $s->[0]{"$k"}) {
+        $s->[0]{"$k"}[1];
+      }
+      else {
+        undef;
+      }
+  }
+  else {
+      $s->[1]{$k};
+  }
 }
 
 sub STORE {
@@ -121,4 +147,16 @@ sub CLEAR {
   %{$s->[1]} = ();
 }
 
+package Tie::RefHash::Nestable;
+use vars '@ISA'; @ISA = qw(Tie::RefHash);
+
+sub STORE {
+  my($s, $k, $v) = @_;
+  if (ref($v) eq 'HASH' and not tied %$v) {
+      my @elems = %$v;
+      tie %$v, ref($s), @elems;
+  }
+  $s->SUPER::STORE($k, $v);
+}
+
 1;
index 89ad03e..39480c8 100644 (file)
@@ -1,5 +1,7 @@
 package Tie::Scalar;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
index 4b18a58..afe5d8d 100644 (file)
@@ -1,5 +1,7 @@
 package Tie::SubstrHash;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
@@ -33,6 +35,8 @@ Because the current implementation uses the table and key sizes for the
 hashing algorithm, there is no means by which to dynamically change the
 value of any of the initialization parameters.
 
+The hash does not support exists().
+
 =cut
 
 use Carp;
@@ -41,12 +45,20 @@ sub TIEHASH {
     my $pack = shift;
     my ($klen, $vlen, $tsize) = @_;
     my $rlen = 1 + $klen + $vlen;
-    $tsize = findprime($tsize * 1.1);  # Allow 10% empty.
+    $tsize = [$tsize,
+             findgteprime($tsize * 1.1)]; # Allow 10% empty.
     $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
-    $$self[0] x= $rlen * $tsize;
+    $$self[0] x= $rlen * $tsize->[1];
     $self;
 }
 
+sub CLEAR {
+    local($self) = @_;
+    $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
+    $$self[5] =  0;
+    $$self[6] = -1;
+}
+
 sub FETCH {
     local($self,$key) = @_;
     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
@@ -69,8 +81,8 @@ sub FETCH {
 sub STORE {
     local($self,$key,$val) = @_;
     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
-    croak("Table is full") if $$self[5] == $tsize;
-    croak(qq/Value "$val" is not $vlen characters long./)
+    croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
+    croak(qq/Value "$val" is not $vlen characters long/)
        if length($val) != $vlen;
     my $writeoffset;
 
@@ -129,7 +141,7 @@ sub FIRSTKEY {
 sub NEXTKEY {
     local($self) = @_;
     local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
-    for (++$iterix; $iterix < $tsize; ++$iterix) {
+    for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
        next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
        $$self[6] = $iterix;
        return substr($$self[0], $iterix * $rlen + 1, $klen);
@@ -138,42 +150,57 @@ sub NEXTKEY {
     undef;
 }
 
+sub EXISTS {
+    croak "Tie::SubstrHash does not support exists()";
+}
+
 sub hashkey {
-    croak(qq/Key "$key" is not $klen characters long.\n/)
+    croak(qq/Key "$key" is not $klen characters long/)
        if length($key) != $klen;
     $hash = 2;
     for (unpack('C*', $key)) {
        $hash = $hash * 33 + $_;
        &_hashwrap if $hash >= 1e13;
     }
-    &_hashwrap if $hash >= $tsize;
+    &_hashwrap if $hash >= $tsize->[1];
     $hash = 1 unless $hash;
     $hashbase = $hash;
 }
 
 sub _hashwrap {
-    $hash -= int($hash / $tsize) * $tsize;
+    $hash -= int($hash / $tsize->[1]) * $tsize->[1];
 }
 
 sub rehash {
     $hash += $hashbase;
-    $hash -= $tsize if $hash >= $tsize;
+    $hash -= $tsize->[1] if $hash >= $tsize->[1];
 }
 
-sub findprime {
+# using POSIX::ceil() would be too heavy, and not all platforms have it.
+sub ceil {
+    my $num = shift;
+    $num = int($num + 1) unless $num == int $num;
+    return $num;
+}
+
+sub findgteprime { # find the smallest prime integer greater than or equal to
     use integer;
 
-    my $num = shift;
-    $num++ unless $num % 2;
+# It may be sufficient (and more efficient, IF IT IS CORRECT) to use
+# $max = 1 + int sqrt $num and calculate it once only, but is it correct?
+
+    my $num = ceil(shift);
+    return 2 if $num <= 2;
 
-    $max = int sqrt $num;
+    $num++ unless $num % 2;
 
   NUM:
     for (;; $num += 2) {
-       for ($i = 3; $i <= $max; $i += 2) {
-           next NUM unless $num % $i;
-       }
-       return $num;
+        my $max = int sqrt $num;
+        for ($i = 3; $i <= $max; $i += 2) {
+            next NUM unless $num % $i;
+        }
+        return $num;
     }
 }
 
index a480884..9c81209 100644 (file)
@@ -2,23 +2,25 @@ package Time::Local;
 require 5.000;
 require Exporter;
 use Carp;
+use strict;
 
-@ISA           = qw( Exporter );
-@EXPORT                = qw( timegm timelocal );
-@EXPORT_OK     = qw( timegm_nocheck timelocal_nocheck );
+our $VERSION    = '1.00';
+our @ISA       = qw( Exporter );
+our @EXPORT    = qw( timegm timelocal );
+our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
 
 # Set up constants
-    $SEC  = 1;
-    $MIN  = 60 * $SEC;
-    $HR   = 60 * $MIN;
-    $DAY  = 24 * $HR;
+our $SEC  = 1;
+our $MIN  = 60 * $SEC;
+our $HR   = 60 * $MIN;
+our $DAY  = 24 * $HR;
 # Determine breakpoint for rolling century
-    my $thisYear = (localtime())[5];
-    $nextCentury = int($thisYear / 100) * 100;
-    $breakpoint = ($thisYear + 50) % 100;
-    $nextCentury += 100 if $breakpoint < 50;
+    my $ThisYear = (localtime())[5];
+    my $NextCentury = int($ThisYear / 100) * 100;
+    my $Breakpoint = ($ThisYear + 50) % 100;
+       $NextCentury += 100 if $Breakpoint < 50;
 
-my %options;
+our(%Options, %Cheat);
 
 sub timegm {
     my (@date) = @_;
@@ -26,11 +28,11 @@ sub timegm {
         $date[5] -= 1900;
     }
     elsif ($date[5] >= 0 && $date[5] < 100) {
-        $date[5] -= 100 if $date[5] > $breakpoint;
-        $date[5] += $nextCentury;
+        $date[5] -= 100 if $date[5] > $Breakpoint;
+        $date[5] += $NextCentury;
     }
-    $ym = pack(C2, @date[5,4]);
-    $cheat = $cheat{$ym} || &cheat(@date);
+    my $ym = pack('C2', @date[5,4]);
+    my $cheat = $Cheat{$ym} || &cheat($ym, @date);
     $cheat
     + $date[0] * $SEC
     + $date[1] * $MIN
@@ -39,7 +41,7 @@ sub timegm {
 }
 
 sub timegm_nocheck {
-    local $options{no_range_check} = 1;
+    local $Options{no_range_check} = 1;
     &timegm;
 }
 
@@ -71,59 +73,61 @@ sub timelocal {
 
     $tzsec += $HR if($lt[8]);
     
-    $time = $t + $tzsec;
-    @test = localtime($time + ($tt - $t));
+    my $time = $t + $tzsec;
+    my @test = localtime($time + ($tt - $t));
     $time -= $HR if $test[2] != $_[2];
     $time;
 }
 
 sub timelocal_nocheck {
-    local $options{no_range_check} = 1;
+    local $Options{no_range_check} = 1;
     &timelocal;
 }
 
 sub cheat {
-    $year = $_[5];
-    $month = $_[4];
-    unless ($options{no_range_check}) {
+    my($ym, @date) = @_;
+    my($sec, $min, $hour, $day, $month, $year) = @date;
+    unless ($Options{no_range_check}) {
        croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0;
-       croak "Day '$_[3]' out of range 1..31"    if $_[3] > 31 || $_[3] < 1;
-       croak "Hour '$_[2]' out of range 0..23"   if $_[2] > 23 || $_[2] < 0;
-       croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0;
-       croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0;
+       croak "Day '$day' out of range 1..31"     if $day > 31  || $day < 1;
+       croak "Hour '$hour' out of range 0..23"   if $hour > 23 || $hour < 0;
+       croak "Minute '$min' out of range 0..59" if $min > 59   || $min < 0;
+       croak "Second '$sec' out of range 0..59" if $sec > 59   || $sec < 0;
     }
-    $guess = $^T;
-    @g = gmtime($guess);
-    $lastguess = "";
-    $counter = 0;
-    while ($diff = $year - $g[5]) {
-       croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+    my $guess = $^T;
+    my @g = gmtime($guess);
+    my $lastguess = "";
+    my $counter = 0;
+    while (my $diff = $year - $g[5]) {
+        my $thisguess;
+       croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255;
        $guess += $diff * (363 * $DAY);
        @g = gmtime($guess);
        if (($thisguess = "@g") eq $lastguess){
-           croak "Can't handle date (".join(", ",@_).")";
+           croak "Can't handle date (".join(", ",@date).")";
            #date beyond this machine's integer limit
        }
        $lastguess = $thisguess;
     }
-    while ($diff = $month - $g[4]) {
-       croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+    while (my $diff = $month - $g[4]) {
+        my $thisguess;
+       croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255;
        $guess += $diff * (27 * $DAY);
        @g = gmtime($guess);
        if (($thisguess = "@g") eq $lastguess){
-           croak "Can't handle date (".join(", ",@_).")";
+           croak "Can't handle date (".join(", ",@date).")";
            #date beyond this machine's integer limit
        }
        $lastguess = $thisguess;
     }
-    @gfake = gmtime($guess-1); #still being sceptic
+    my @gfake = gmtime($guess-1); #still being sceptic
     if ("@gfake" eq $lastguess){
-        croak "Can't handle date (".join(", ",@_).")";
+        croak "Can't handle date (".join(", ",@date).")";
         #date beyond this machine's integer limit
     }
     $g[3]--;
     $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY;
-    $cheat{$ym} = $guess;
+    $Cheat{$ym} = $guess;
 }
 
 1;
index fd47ad1..2c308eb 100644 (file)
@@ -1,6 +1,8 @@
 package Time::tm;
 use strict;
 
+our $VERSION = '1.00';
+
 use Class::Struct qw(struct);
 struct('Time::tm' => [
      map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
index f2f1fe9..a66f8d5 100644 (file)
@@ -1,5 +1,7 @@
 package UNIVERSAL;
 
+our $VERSION = '1.00';
+
 # UNIVERSAL should not contain any extra subs/methods beyond those
 # that it exists to define. The use of Exporter below is a historical
 # accident that should be fixed sometime.
index 95e4189..fd6fe56 100644 (file)
@@ -2,6 +2,7 @@ package User::grent;
 use strict;
 
 use 5.005_64;
+our $VERSION = '1.00';
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 BEGIN { 
     use Exporter   ();
index 8c05926..edd5f51 100644 (file)
@@ -1,6 +1,7 @@
 package User::pwent;
 
 use 5.006;
+our $VERSION = '1.00';
 
 use strict;
 use warnings;
index 64361f8..842e484 100644 (file)
@@ -175,7 +175,9 @@ function.
 system boot. Resolution is limited to system timer ticks (about 10ms
 on WinNT and 55ms on Win9X).
 
-=item Win32::InitiateSystemShutdown(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT)
+=item Win32::InitiateSystemShutdown
+
+(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT)
 
 [EXT] Shutsdown the specified MACHINE, notifying users with the
 supplied MESSAGE, within the specified TIMEOUT interval. Forces
index f2f7e01..3b0268e 100644 (file)
@@ -1,5 +1,7 @@
 package bytes;
 
+our $VERSION = '1.00';
+
 $bytes::hint_bits = 0x00000008;
 
 sub import {
index 0ec7ec2..934fafd 100644 (file)
@@ -1,4 +1,7 @@
 package charnames;
+
+our $VERSION = '1.00';
+
 use bytes ();          # for $bytes::hint_bits
 use warnings();
 $charnames::hint_bits = 0x20000;
index 72ad793..1e07a68 100644 (file)
@@ -28,75 +28,93 @@ my %forbidden = (%keywords, %forced_into_main);
 sub import {
     my $class = shift;
     return unless @_;                  # Ignore 'use constant;'
-    my $name = shift;
-    unless (defined $name) {
-        require Carp;
-       Carp::croak("Can't use undef as constant name");
+    my %constants = ();
+    my $multiple  = ref $_[0];
+
+    if ( $multiple ) {
+       if (ref $_[0] ne 'HASH') {
+           require Carp;
+           Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
+       }
+       %constants = %{+shift};
+    } else {
+       $constants{+shift} = undef;
     }
-    my $pkg = caller;
-
-    # Normal constant name
-    if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
-        # Everything is okay
-
-    # Name forced into main, but we're not in main. Fatal.
-    } elsif ($forced_into_main{$name} and $pkg ne 'main') {
-       require Carp;
-       Carp::croak("Constant name '$name' is forced into main::");
-
-    # Starts with double underscore. Fatal.
-    } elsif ($name =~ /^__/) {
-       require Carp;
-       Carp::croak("Constant name '$name' begins with '__'");
-
-    # Maybe the name is tolerable
-    } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
-       # Then we'll warn only if you've asked for warnings
-       if (warnings::enabled()) {
-           if ($keywords{$name}) {
-               warnings::warn("Constant name '$name' is a Perl keyword");
-           } elsif ($forced_into_main{$name}) {
-               warnings::warn("Constant name '$name' is " .
-                   "forced into package main::");
+
+    foreach my $name ( keys %constants ) {
+       unless (defined $name) {
+           require Carp;
+           Carp::croak("Can't use undef as constant name");
+       }
+       my $pkg = caller;
+
+       # Normal constant name
+       if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
+           # Everything is okay
+
+       # Name forced into main, but we're not in main. Fatal.
+       } elsif ($forced_into_main{$name} and $pkg ne 'main') {
+           require Carp;
+           Carp::croak("Constant name '$name' is forced into main::");
+
+       # Starts with double underscore. Fatal.
+       } elsif ($name =~ /^__/) {
+           require Carp;
+           Carp::croak("Constant name '$name' begins with '__'");
+
+       # Maybe the name is tolerable
+       } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
+           # Then we'll warn only if you've asked for warnings
+           if (warnings::enabled()) {
+               if ($keywords{$name}) {
+                   warnings::warn("Constant name '$name' is a Perl keyword");
+               } elsif ($forced_into_main{$name}) {
+                   warnings::warn("Constant name '$name' is " .
+                       "forced into package main::");
+               } else {
+                   # Catch-all - what did I miss? If you get this error,
+                   # please let me know what your constant's name was.
+                   # Write to <rootbeer@redcat.com>. Thanks!
+                   warnings::warn("Constant name '$name' has unknown problems");
+               }
+           }
+
+       # Looks like a boolean
+       # use constant FRED == fred;
+       } elsif ($name =~ /^[01]?\z/) {
+            require Carp;
+           if (@_) {
+               Carp::croak("Constant name '$name' is invalid");
            } else {
-               # Catch-all - what did I miss? If you get this error,
-               # please let me know what your constant's name was.
-               # Write to <rootbeer@redcat.com>. Thanks!
-               warnings::warn("Constant name '$name' has unknown problems");
+               Carp::croak("Constant name looks like boolean value");
            }
-       }
 
-    # Looks like a boolean
-    #          use constant FRED == fred;
-    } elsif ($name =~ /^[01]?\z/) {
-        require Carp;
-       if (@_) {
-           Carp::croak("Constant name '$name' is invalid");
        } else {
-           Carp::croak("Constant name looks like boolean value");
+          # Must have bad characters
+            require Carp;
+           Carp::croak("Constant name '$name' has invalid characters");
        }
 
-    } else {
-       # Must have bad characters
-        require Carp;
-       Carp::croak("Constant name '$name' has invalid characters");
-    }
-
-    {
-       no strict 'refs';
-       my $full_name = "${pkg}::$name";
-       $declared{$full_name}++;
-       if (@_ == 1) {
-           my $scalar = $_[0];
-           *$full_name = sub () { $scalar };
-       } elsif (@_) {
-           my @list = @_;
-           *$full_name = sub () { @list };
-       } else {
-           *$full_name = sub () { };
+       {
+           no strict 'refs';
+           my $full_name = "${pkg}::$name";
+           $declared{$full_name}++;
+           if ($multiple) {
+               my $scalar = $constants{$name};
+               *$full_name = sub () { $scalar };
+           } else {
+               if (@_ == 1) {
+                   my $scalar = $_[0];
+                   *$full_name = sub () { $scalar };
+               } elsif (@_) {
+                   my @list = @_;
+                   *$full_name = sub () { @list };
+               } else {
+                   *$full_name = sub () { };
+               }
+           }
        }
     }
-
 }
 
 1;
@@ -133,6 +151,17 @@ constant - Perl pragma to declare constants
     print CCODE->("me");
     print CHASH->[10];                 # compile-time error
 
+    # declaring multiple constants at once
+    use constant {
+       BUFFER_SIZE     => 4096,
+       ONE_YEAR        => 365.2425 * 24 * 60 * 60,
+       PI              => 4 * atan2( 1, 1 ),
+       DEBUGGING       => 0,
+       ORACLE          => 'oracle@cs.indiana.edu',
+       USERNAME        => scalar getpwuid($<),
+       USERINFO        => getpwuid($<),
+    };
+
 =head1 DESCRIPTION
 
 This will declare a symbol to be a constant with the given scalar
@@ -176,14 +205,26 @@ Other as C<Other::CONST>.
 As with all C<use> directives, defining a constant happens at
 compile time. Thus, it's probably not correct to put a constant
 declaration inside of a conditional statement (like C<if ($foo)
-{ use constant ... }>).
+{ use constant ... }>).  When defining multiple constants, you
+cannot use the values of other constants within the same declaration
+scope.  This is because the calling package doesn't know about any
+constant within that group until I<after> the C<use> statement is
+finished.
+
+    use constant {
+       AGE    => 20,
+       PERSON => { age => AGE }, # Error!
+    };
+    [...]
+    use constant PERSON => { age => AGE }; # Right
 
 Omitting the value for a symbol gives it the value of C<undef> in
 a scalar context or the empty list, C<()>, in a list context. This
 isn't so nice as it may sound, though, because in this case you
 must either quote the symbol name, or use a big arrow, (C<=E<gt>>),
-with nothing to point to. It is probably best to declare these
-explicitly.
+with nothing to point to. It is also illegal to do when defining
+multiple constants at once, you must declare them explicitly.  It
+is probably best to declare these explicitly.
 
     use constant UNICORNS      => ();
     use constant LOGFILE       => undef;
@@ -206,6 +247,11 @@ Dereferencing constant references incorrectly (such as using an array
 subscript on a constant hash reference, or vice versa) will be trapped at
 compile time.
 
+When declaring multiple constants, all constant values will be a scalar.
+This is because C<constant> can't guess the intent of the programmer
+correctly all the time since values must be expressed in scalar context
+within a hash ref.
+
 In the rare case in which you need to discover at run time whether a
 particular constant has been declared via this module, you may use
 this function to examine the hash C<%constant::declared>. If the given
@@ -268,6 +314,9 @@ C<CONSTANT =E<gt> 'value'>.
 Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
 many other folks.
 
+Multiple constant declarations at once added by Casey Tweten,
+E<lt>F<crt@kiski.net>E<gt>.
+
 =head1 COPYRIGHT
 
 Copyright (C) 1997, 1999 Tom Phoenix
index 884ea3c..f3e60f5 100755 (executable)
@@ -171,7 +171,7 @@ use strict;
 use 5.005_64;
 use Carp;
 
-our $VERSION = v1.0;
+our $VERSION = 1.0;
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
index b52a9b4..21252f3 100644 (file)
@@ -1,5 +1,7 @@
 package filetest;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 filetest - Perl pragma to control the filetest permission operators
index aa6a489..3f0af1a 100644 (file)
@@ -74,7 +74,7 @@
 # No longer call die expect on fatal errors.  Just return fail codes.
 # Changed returns so higher up routines can tell whats happening.
 # Get expect/accept in correct order for dir listing.
-# When ftp_show is set then print hashes every 1k transfered (like ftp).
+# When ftp_show is set then print hashes every 1k transferred (like ftp).
 # Allow for stripping returns out of incoming data.
 # Save last error in a global string.
 #
index 86afcaf..f019fb3 100644 (file)
@@ -1,5 +1,7 @@
 package integer;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 integer - Perl pragma to compute arithmetic in integer instead of double
index b3afef0..de0ac8f 100644 (file)
@@ -1,5 +1,7 @@
 package less;
 
+our $VERSION = '0.01';
+
 =head1 NAME
 
 less - perl pragma to request less of something from the compiler
index bb02106..66b4944 100644 (file)
@@ -8,10 +8,30 @@ chdir dirname($0);
 my $file = basename($0, '.PL');
 $file =~ s!_(pm)$!.$1!i;
 
-my $Config_archname = defined($Config{'archname'}) ? $Config{'archname'} : '';
-my $Config_ver = defined($Config{'version'}) ? $Config{'version'} : '';
-my @Config_inc_version_list = defined($Config{'inc_version_list'}) ?
-  reverse split / /, $Config{'inc_version_list'} : ();
+my $useConfig;
+my $Config_archname;
+my $Config_version;
+my $Config_inc_version_list;
+
+# Expand the variables only if explicitly requested because
+# otherwise relocating Perl becomes much harder.
+
+if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
+    $useConfig = '';
+    $Config_archname = qq('$Config{archname}');
+    $Config_version  = qq('$Config{version}');
+    my @Config_inc_version_list =
+       reverse split / /, $Config{inc_version_list};
+    $Config_inc_version_list =
+       @Config_inc_version_list ?
+           qq(@Config_inc_version_list) : q(());
+} else {
+    $useConfig = 'use Config;';
+    $Config_archname = q($Config{archname});
+    $Config_version  = q($Config{version});
+    $Config_inc_version_list =
+             q(reverse split / /, qw($Config{inc_version_list}));
+}
  
 open OUT,">$file" or die "Can't create $file: $!";
  
@@ -26,9 +46,11 @@ package lib;
 # THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
 # ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
 
-my \$archname = "$Config_archname";
-my \$ver = "$Config_ver";
-my \@inc_version_list = qw(@Config_inc_version_list);
+$useConfig
+
+my \$archname         = $Config_archname;
+my \$version          = $Config_version;
+my \@inc_version_list = $Config_inc_version_list;
 
 !GROK!THIS!
 print OUT <<'!NO!SUBS!';
@@ -57,9 +79,9 @@ sub import {
         }
        # Put a corresponding archlib directory infront of $_ if it
        # looks like $_ has an archlib directory below it.
-       unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
-       unshift(@INC, "$_/$ver") if -d "$_/$ver";
-       unshift(@INC, "$_/$ver/$archname") if -d "$_/$ver/$archname";
+       unshift(@INC, "$_/$archname")          if -d "$_/$archname/auto";
+       unshift(@INC, "$_/$version")           if -d "$_/$version";
+       unshift(@INC, "$_/$version/$archname") if -d "$_/$version/$archname";
     }
 
     # remove trailing duplicates
@@ -74,9 +96,9 @@ sub unimport {
     my %names;
     foreach (@_) {
        ++$names{$_};
-       ++$names{"$_/$archname"} if -d "$_/$archname/auto";
-       ++$names{"$_/$ver"} if -d "$_/$ver";
-       ++$names{"$_/$ver/$archname"} if -d "$_/$ver/$archname";
+       ++$names{"$_/$archname"}          if -d "$_/$archname/auto";
+       ++$names{"$_/$version"}           if -d "$_/$version";
+       ++$names{"$_/$version/$archname"} if -d "$_/$version/$archname";
     }
 
     # Remove ALL instances of each named directory.
index 6314aca..3e5054c 100644 (file)
@@ -1,5 +1,7 @@
 package locale;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 locale - Perl pragma to use and avoid POSIX locales for built-in operations
index cdd20ac..1e073c2 100644 (file)
@@ -1,23 +1,45 @@
 package open;
+use Carp;
 $open::hint_bits = 0x20000;
 
+use vars qw(%layers @layers);
+
+# Populate hash in non-PerlIO case
+%layers = (crlf => 1, raw => 0) unless (@layers);
+
+our $VERSION = '1.00';
+
 sub import {
     shift;
     die "`use open' needs explicit list of disciplines" unless @_;
     $^H |= $open::hint_bits;
+    my ($in,$out) = split(/\0/,(${^OPEN} || '\0'));
+    my @in  = split(/\s+/,$in);
+    my @out = split(/\s+/,$out);
     while (@_) {
        my $type = shift;
-       if ($type =~ /^(IN|OUT)\z/s) {
-           my $discp = shift;
-           unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) {
-               die "Unknown discipline '$discp'";
+       my $discp = shift;
+       my @val;
+       foreach my $layer (split(/\s+:?/,$discp)) {
+           unless(exists $layers{$layer}) {
+               croak "Unknown discipline layer '$layer'";
            }
-           $^H{"open_$type"} = $discp;
+           push(@val,":$layer");
+           if ($layer =~ /^(crlf|raw)$/) {
+               $^H{"open_$type"} = $layer;
+           }
+       }
+       if ($type eq 'IN') {
+           $in  = join(' ',@val);
+       }
+       elsif ($type eq 'OUT') {
+           $out = join(' ',@val);
        }
        else {
-           die "Unknown discipline class '$type'";
+           croak "Unknown discipline class '$type'";
        }
     }
+    ${^OPEN} = join('\0',$in,$out);
 }
 
 1;
index 2b0b99d..69092a0 100644 (file)
@@ -1,5 +1,7 @@
 package overload;
 
+our $VERSION = '1.00';
+
 $overload::hint_bits = 0x20000;
 
 sub nil {}
index fb6d683..63b4381 100644 (file)
@@ -25,7 +25,7 @@ $header = "perl5db.pl version $VERSION";
 # if caller() is called from the package DB, it provides some
 # additional data.
 #
-# The array @{$main::{'_<'.$filename} is the line-by-line contents of
+# The array @{$main::{'_<'.$filename}} is the line-by-line contents of
 # $filename.
 #
 # The hash %{'_<'.$filename} contains breakpoints and action (it is
@@ -401,6 +401,12 @@ if ($notty) {
     $console = "/dev/tty";
   } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
     $console = "con";
+  } elsif ($^O eq 'MacOS') {
+    if ($MacPerl::Version !~ /MPW/) {
+      $console = "Dev:Console:Perl Debug"; # Separate window for application
+    } else {
+      $console = "Dev:Console";
+    }
   } else {
     $console = "sys\$command";
   }
diff --git a/lib/perlio.pm b/lib/perlio.pm
new file mode 100644 (file)
index 0000000..48acfbb
--- /dev/null
@@ -0,0 +1,87 @@
+package perlio;
+1;
+__END__
+
+=head1 NAME
+
+perlio - perl pragma to configure C level IO
+
+=head1 SYNOPSIS
+
+  Shell:
+    PERLIO=perlio perl ....
+
+    print "Have ",join(',',keys %perlio::layers),"\n";
+    print "Using ",join(',',@perlio::layers),"\n";
+
+
+=head1 DESCRIPTION
+
+Mainly a Place holder for now.
+
+The C<%perlio::layers> hash is a record of the available "layers" that may be pushed
+onto a C<PerlIO> stream.
+
+The C<@perlio::layers> array is the current set of layers that are used when
+a new C<PerlIO> stream is opened. The C code looks are the array each time
+a stream is opened so the "stack" can be manipulated by messing with the array :
+
+    pop(@perlio::layers);
+    push(@perlio::layers,$perlio::layers{'stdio'});
+
+The values if both the hash and the array are perl objects, of class C<perlio::Layer>
+which are created by the C code in C<perlio.c>. As yet there is nothing useful you
+can do with the objects at the perl level.
+
+There are three layers currently defined:
+
+=over 4
+
+=item unix
+
+Low level layer which calls C<read>, C<write> and C<lseek> etc.
+
+=item stdio
+
+Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc.
+Note that as this is "real" stdio it will ignore any layers beneath it and
+got straight to the operating system via the C library as usual.
+
+=item perlio
+
+This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer".
+As such it will call whatever layer is below it for its operations.
+
+=back
+
+=head2 Defaults and how to override them
+
+If C<Configure> found out how to do "fast" IO using system's stdio, then
+the default layers are :
+
+  unix stdio
+
+Otherwise the default layers are
+
+  unix perlio
+
+(STDERR will have just unix in this case as that is optimal way to make it
+"unbuffered" - do not add a buffering layer!)
+
+The default may change once perlio has been better tested and tuned.
+
+The default can be overridden by setting the environment variable PERLIO
+to a space separated list of layers (unix is always pushed first).
+This can be used to see the effect of/bugs in the various layers e.g.
+
+  cd .../perl/t
+  PERLIO=stdio  ./perl harness
+  PERLIO=perlio ./perl harness
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=cut
+
+
index 042227f..8afb9a3 100644 (file)
@@ -37,6 +37,14 @@ use symbolic references (see L<perlref>).
     $file = "STDOUT";
     print $file "Hi!"; # error; note: no comma after $file
 
+There is one exception to this rule:
+
+    $bar = \&{'foo'};
+    &$bar;
+
+is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
+
+
 =item C<strict vars>
 
 This generates a compile-time error if you access a variable that wasn't
index aa332a6..e5a9aa8 100644 (file)
@@ -1,5 +1,7 @@
 package subs;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 subs - Perl pragma to predeclare sub names
index 94f9a5c..a0aac62 100644 (file)
@@ -6,13 +6,23 @@ return <<'END';
 0041   005a
 0061   007a
 00aa   
+00b2   00b3
 00b5   
-00ba   
+00b9   00ba
+00bc   00be
 00c0   00d6
 00d8   00f6
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -21,38 +31,57 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
+0640   0655
 0660   0669
-0671   06d3
-06d5   
+0670   06d3
+06d5   06e8
+06ea   06ed
 06f0   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
 0966   096f
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09e6   09f1
+09f4   09f9
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -60,10 +89,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a66   0a6f
-0a72   0a74
+0a66   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -71,20 +104,27 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
 0ae6   0aef
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
 0b66   0b6f
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -95,36 +135,60 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
-0be7   0bef
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0be7   0bf2
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
 0c66   0c6f
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
 0ce6   0cef
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
 0d66   0d6f
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e50   0e59
 0e81   0e82
 0e84   
@@ -137,22 +201,33 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0ed0   0ed9
 0edc   0edd
 0f00   
-0f20   0f29
-0f40   0f47
+0f18   0f19
+0f20   0f33
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
+102c   1032
+1036   1039
 1040   1049
-1050   1055
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -183,18 +258,18 @@ return <<'END';
 1318   131e
 1320   1346
 1348   135a
-1369   1371
+1369   137c
 13a0   13f4
 1401   166c
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
+16ee   16f0
+1780   17d3
 17e0   17e9
 1810   1819
-1820   1842
-1844   1877
-1880   18a8
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -216,7 +291,10 @@ return <<'END';
 1fe0   1fec
 1ff2   1ff4
 1ff6   1ffc
-207f   
+2070   
+2074   2079
+207f   2089
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -228,12 +306,25 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+2153   2183
+2460   249b
+24ea   
+2776   2793
+3005   3007
+3021   302f
+3031   3035
+3038   303a
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
+3192   3195
 31a0   31b7
+3220   3229
+3280   3289
 3400   4db5
 4e00   9fa5
 a000   a48c
@@ -241,8 +332,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -253,15 +343,14 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff10   ff19
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
index de5046f..13dc003 100644 (file)
@@ -12,6 +12,14 @@ return <<'END';
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -20,36 +28,54 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
-0671   06d3
-06d5   
+0640   0655
+0670   06d3
+06d5   06e8
+06ea   06ed
 06fa   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09f0   09f1
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -57,9 +83,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a72   0a74
+0a70   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -67,18 +98,25 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -89,32 +127,56 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e81   0e82
 0e84   
 0e87   0e88
@@ -126,19 +188,30 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0edc   0edd
 0f00   
-0f40   0f47
+0f18   0f19
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
-1050   1055
+102c   1032
+1036   1039
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -174,10 +247,9 @@ return <<'END';
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
-1820   1842
-1844   1877
-1880   18a8
+1780   17d3
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -200,6 +272,7 @@ return <<'END';
 1ff2   1ff4
 1ff6   1ffc
 207f   
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -211,9 +284,14 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+3005   3006
+302a   302f
+3031   3035
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
 31a0   31b7
@@ -224,8 +302,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -236,14 +313,13 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
diff --git a/lib/unicode/Is/Blank.pl b/lib/unicode/Is/Blank.pl
new file mode 100644 (file)
index 0000000..8642921
--- /dev/null
@@ -0,0 +1,12 @@
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
+# This file is built by mktables.PL from e.g. Unicode.301.
+# Any changes made here will be lost!
+return <<'END';
+0009   
+0020   
+00a0   
+1680   
+2000   200b
+202f   
+3000   
+END
diff --git a/lib/unicode/Is/DCmedial.pl b/lib/unicode/Is/DCmedial.pl
new file mode 100644 (file)
index 0000000..8778a75
--- /dev/null
@@ -0,0 +1,59 @@
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
+# This file is built by mktables.PL from e.g. Unicode.301.
+# Any changes made here will be lost!
+return <<'END';
+fb55   
+fb59   
+fb5d   
+fb61   
+fb65   
+fb69   
+fb6d   
+fb71   
+fb75   
+fb79   
+fb7d   
+fb81   
+fb91   
+fb95   
+fb99   
+fb9d   
+fba3   
+fba9   
+fbad   
+fbd6   
+fbe7   
+fbe9   
+fbff   
+fcdf   fcf4
+fd34   fd3b
+fe71   
+fe77   
+fe79   
+fe7b   
+fe7d   
+fe7f   
+fe8c   
+fe92   
+fe98   
+fe9c   
+fea0   
+fea4   
+fea8   
+feb4   
+feb8   
+febc   
+fec0   
+fec4   
+fec8   
+fecc   
+fed0   
+fed4   
+fed8   
+fedc   
+fee0   
+fee4   
+fee8   
+feec   
+fef4   
+END
index 40d3506..238cc56 100644 (file)
@@ -3,7 +3,7 @@
 # Any changes made here will be lost!
 return <<'END';
 0021   007e
-00a0   021f
+00a1   021f
 0222   0233
 0250   02ad
 02b0   02ee
@@ -239,7 +239,7 @@ return <<'END';
 1361   137c
 13a0   13f4
 1401   1676
-1680   169c
+1681   169c
 16a0   16f0
 1780   17dc
 17e0   17e9
@@ -265,10 +265,8 @@ return <<'END';
 1fdd   1fef
 1ff2   1ff4
 1ff6   1ffe
-2000   2008
-200b   
-2010   2029
-202f   2046
+2010   2027
+2030   2046
 2048   204d
 2070   
 2074   208e
@@ -304,7 +302,7 @@ return <<'END';
 2e9b   2ef3
 2f00   2fd5
 2ff0   2ffb
-3000   303a
+3001   303a
 303e   303f
 3041   3094
 3099   309e
@@ -330,6 +328,7 @@ a4b5        a4c0
 a4c2   a4c4
 a4c6   
 ac00   d7a3
+e000   f8ff
 f900   fa2d
 fb00   fb06
 fb13   fb17
@@ -360,4 +359,6 @@ ffda        ffdc
 ffe0   ffe6
 ffe8   ffee
 fffc   fffd
+f0000  ffffd
+100000 10fffd
 END
index c3adba6..1229a28 100644 (file)
@@ -266,7 +266,7 @@ return <<'END';
 1ff2   1ff4
 1ff6   1ffe
 2000   200b
-2010   2029
+2010   2027
 202f   2046
 2048   204d
 2070   
@@ -329,6 +329,7 @@ a4b5        a4c0
 a4c2   a4c4
 a4c6   
 ac00   d7a3
+e000   f8ff
 f900   fa2d
 fb00   fb06
 fb13   fb17
@@ -359,4 +360,6 @@ ffda        ffdc
 ffe0   ffe6
 ffe8   ffee
 fffc   fffd
+f0000  ffffd
+100000 10fffd
 END
index 9e088ba..97330ec 100644 (file)
@@ -8,45 +8,45 @@ return <<'END';
 003a   003b
 003f   0040
 005b   005d
-005f
-007b
-007d
-00a1
-00ab
-00ad
-00b7
-00bb
-00bf
-037e
-0387
+005f   
+007b   
+007d   
+00a1   
+00ab   
+00ad   
+00b7   
+00bb   
+00bf   
+037e   
+0387   
 055a   055f
 0589   058a
-05be
-05c0
-05c3
+05be   
+05c0   
+05c3   
 05f3   05f4
-060c
-061b
-061f
+060c   
+061b   
+061f   
 066a   066d
-06d4
+06d4   
 0700   070d
 0964   0965
-0970
-0df4
-0e4f
+0970   
+0df4   
+0e4f   
 0e5a   0e5b
 0f04   0f12
 0f3a   0f3d
-0f85
+0f85   
 104a   104f
-10fb
+10fb   
 1361   1368
 166d   166e
 169b   169c
 16eb   16ed
 17d4   17da
-17dc
+17dc   
 1800   180a
 2010   2027
 2030   2043
@@ -58,14 +58,14 @@ return <<'END';
 3001   3003
 3008   3011
 3014   301f
-3030
-30fb
+3030   
+30fb   
 fd3e   fd3f
 fe30   fe44
 fe49   fe52
 fe54   fe61
-fe63
-fe68
+fe63   
+fe68   
 fe6a   fe6b
 ff01   ff03
 ff05   ff0a
@@ -73,8 +73,8 @@ ff0c  ff0f
 ff1a   ff1b
 ff1f   ff20
 ff3b   ff3d
-ff3f
-ff5b
-ff5d
+ff3f   
+ff5b   
+ff5d   
 ff61   ff65
 END
index 1625dce..9971082 100644 (file)
@@ -3,12 +3,11 @@
 # Any changes made here will be lost!
 return <<'END';
 0009   000d
-0020
-0085
-00a0
-1680
+0020   
+00a0   
+1680   
 2000   200b
 2028   2029
-202f
-3000
+202f   
+3000   
 END
diff --git a/lib/unicode/Is/SpacePerl.pl b/lib/unicode/Is/SpacePerl.pl
new file mode 100644 (file)
index 0000000..2bb74de
--- /dev/null
@@ -0,0 +1,14 @@
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
+# This file is built by mktables.PL from e.g. Unicode.301.
+# Any changes made here will be lost!
+return <<'END';
+0009   000a
+000c   000d
+0020   
+00a0   
+1680   
+2000   200b
+2028   2029
+202f   
+3000   
+END
index 1c76c60..6ea32e6 100644 (file)
@@ -7,13 +7,23 @@ return <<'END';
 005f   
 0061   007a
 00aa   
+00b2   00b3
 00b5   
-00ba   
+00b9   00ba
+00bc   00be
 00c0   00d6
 00d8   00f6
 00f8   021f
 0222   0233
 0250   02ad
+02b0   02b8
+02bb   02c1
+02d0   02d1
+02e0   02e4
+02ee   
+0300   034e
+0360   0362
+037a   
 0386   
 0388   038a
 038c   
@@ -22,38 +32,57 @@ return <<'END';
 03d0   03d7
 03da   03f3
 0400   0481
+0483   0486
+0488   0489
 048c   04c4
 04c7   04c8
 04cb   04cc
 04d0   04f5
 04f8   04f9
 0531   0556
+0559   
 0561   0587
+0591   05a1
+05a3   05b9
+05bb   05bd
+05bf   
+05c1   05c2
+05c4   
 05d0   05ea
 05f0   05f2
 0621   063a
-0641   064a
+0640   0655
 0660   0669
-0671   06d3
-06d5   
+0670   06d3
+06d5   06e8
+06ea   06ed
 06f0   06fc
-0710   
-0712   072c
-0780   07a5
+0710   072c
+0730   074a
+0780   07b0
+0901   0903
 0905   0939
-093d   
-0950   
-0958   0961
+093c   094d
+0950   0954
+0958   0963
 0966   096f
+0981   0983
 0985   098c
 098f   0990
 0993   09a8
 09aa   09b0
 09b2   
 09b6   09b9
+09bc   
+09be   09c4
+09c7   09c8
+09cb   09cd
+09d7   
 09dc   09dd
-09df   09e1
+09df   09e3
 09e6   09f1
+09f4   09f9
+0a02   
 0a05   0a0a
 0a0f   0a10
 0a13   0a28
@@ -61,10 +90,14 @@ return <<'END';
 0a32   0a33
 0a35   0a36
 0a38   0a39
+0a3c   
+0a3e   0a42
+0a47   0a48
+0a4b   0a4d
 0a59   0a5c
 0a5e   
-0a66   0a6f
-0a72   0a74
+0a66   0a74
+0a81   0a83
 0a85   0a8b
 0a8d   
 0a8f   0a91
@@ -72,20 +105,27 @@ return <<'END';
 0aaa   0ab0
 0ab2   0ab3
 0ab5   0ab9
-0abd   
+0abc   0ac5
+0ac7   0ac9
+0acb   0acd
 0ad0   
 0ae0   
 0ae6   0aef
+0b01   0b03
 0b05   0b0c
 0b0f   0b10
 0b13   0b28
 0b2a   0b30
 0b32   0b33
 0b36   0b39
-0b3d   
+0b3c   0b43
+0b47   0b48
+0b4b   0b4d
+0b56   0b57
 0b5c   0b5d
 0b5f   0b61
 0b66   0b6f
+0b82   0b83
 0b85   0b8a
 0b8e   0b90
 0b92   0b95
@@ -96,36 +136,60 @@ return <<'END';
 0ba8   0baa
 0bae   0bb5
 0bb7   0bb9
-0be7   0bef
+0bbe   0bc2
+0bc6   0bc8
+0bca   0bcd
+0bd7   
+0be7   0bf2
+0c01   0c03
 0c05   0c0c
 0c0e   0c10
 0c12   0c28
 0c2a   0c33
 0c35   0c39
+0c3e   0c44
+0c46   0c48
+0c4a   0c4d
+0c55   0c56
 0c60   0c61
 0c66   0c6f
+0c82   0c83
 0c85   0c8c
 0c8e   0c90
 0c92   0ca8
 0caa   0cb3
 0cb5   0cb9
+0cbe   0cc4
+0cc6   0cc8
+0cca   0ccd
+0cd5   0cd6
 0cde   
 0ce0   0ce1
 0ce6   0cef
+0d02   0d03
 0d05   0d0c
 0d0e   0d10
 0d12   0d28
 0d2a   0d39
+0d3e   0d43
+0d46   0d48
+0d4a   0d4d
+0d57   
 0d60   0d61
 0d66   0d6f
+0d82   0d83
 0d85   0d96
 0d9a   0db1
 0db3   0dbb
 0dbd   
 0dc0   0dc6
-0e01   0e30
-0e32   0e33
-0e40   0e45
+0dca   
+0dcf   0dd4
+0dd6   
+0dd8   0ddf
+0df2   0df3
+0e01   0e3a
+0e40   0e4e
 0e50   0e59
 0e81   0e82
 0e84   
@@ -138,22 +202,33 @@ return <<'END';
 0ea5   
 0ea7   
 0eaa   0eab
-0ead   0eb0
-0eb2   0eb3
-0ebd   
+0ead   0eb9
+0ebb   0ebd
 0ec0   0ec4
+0ec6   
+0ec8   0ecd
 0ed0   0ed9
 0edc   0edd
 0f00   
-0f20   0f29
-0f40   0f47
+0f18   0f19
+0f20   0f33
+0f35   
+0f37   
+0f39   
+0f3e   0f47
 0f49   0f6a
-0f88   0f8b
+0f71   0f84
+0f86   0f8b
+0f90   0f97
+0f99   0fbc
+0fc6   
 1000   1021
 1023   1027
 1029   102a
+102c   1032
+1036   1039
 1040   1049
-1050   1055
+1050   1059
 10a0   10c5
 10d0   10f6
 1100   1159
@@ -184,18 +259,18 @@ return <<'END';
 1318   131e
 1320   1346
 1348   135a
-1369   1371
+1369   137c
 13a0   13f4
 1401   166c
 166f   1676
 1681   169a
 16a0   16ea
-1780   17b3
+16ee   16f0
+1780   17d3
 17e0   17e9
 1810   1819
-1820   1842
-1844   1877
-1880   18a8
+1820   1877
+1880   18a9
 1e00   1e9b
 1ea0   1ef9
 1f00   1f15
@@ -217,7 +292,10 @@ return <<'END';
 1fe0   1fec
 1ff2   1ff4
 1ff6   1ffc
-207f   
+2070   
+2074   2079
+207f   2089
+20d0   20e3
 2102   
 2107   
 210a   2113
@@ -229,12 +307,25 @@ return <<'END';
 212a   212d
 212f   2131
 2133   2139
-3006   
+2153   2183
+2460   249b
+24ea   
+2776   2793
+3005   3007
+3021   302f
+3031   3035
+3038   303a
 3041   3094
+3099   309a
+309d   309e
 30a1   30fa
+30fc   30fe
 3105   312c
 3131   318e
+3192   3195
 31a0   31b7
+3220   3229
+3280   3289
 3400   4db5
 4e00   9fa5
 a000   a48c
@@ -242,8 +333,7 @@ ac00        d7a3
 f900   fa2d
 fb00   fb06
 fb13   fb17
-fb1d   
-fb1f   fb28
+fb1d   fb28
 fb2a   fb36
 fb38   fb3c
 fb3e   
@@ -254,15 +344,14 @@ fbd3      fd3d
 fd50   fd8f
 fd92   fdc7
 fdf0   fdfb
+fe20   fe23
 fe70   fe72
 fe74   
 fe76   fefc
 ff10   ff19
 ff21   ff3a
 ff41   ff5a
-ff66   ff6f
-ff71   ff9d
-ffa0   ffbe
+ff66   ffbe
 ffc2   ffc7
 ffca   ffcf
 ffd2   ffd7
diff --git a/lib/unicode/distinct.pm b/lib/unicode/distinct.pm
new file mode 100644 (file)
index 0000000..6471ac8
--- /dev/null
@@ -0,0 +1,35 @@
+package unicode:distinct;
+
+our $VERSION = '0.01';
+
+$unicode::distinct::hint_bits = 0x01000000;
+
+sub import {
+    $^H |= $unicode::distinct::hint_bits;
+}
+
+sub unimport {
+    $^H &= ~$unicode::distinct::hint_bits;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+unicode::distinct - Perl pragma to strictly distinguish UTF8 data and non-UTF data.
+
+=head1 SYNOPSIS
+
+    use unicode::distinct;
+    no unicode::distinct;
+
+=head1 DESCRIPTION
+
+ *NOT YET*
+
+=head1 SEE ALSO
+
+L<perlunicode>, L<utf8>
+
+=cut
index 37b6e84..82b35ef 100755 (executable)
@@ -16,18 +16,31 @@ mkdir "To", 0755;
 @todo = (
 # typical
 
-    ['IsWord',  '$cat =~ /^L[ulot]|^Nd/ or $code eq "005F"',   ''],
-    ['IsAlnum', '$cat =~ /^L[ulot]|^Nd/',      ''],
-    ['IsAlpha',  '$cat =~ /^L[ulot]/', ''],
-    ['IsSpace',  'White space',        $PropData],
+    # 005F: SPACING UNDERSCROE
+    ['IsWord',   '$cat =~ /^[LMN]/ or $code eq "005F"',        ''],
+    ['IsAlnum',  '$cat =~ /^[LMN]/',   ''],
+    ['IsAlpha',  '$cat =~ /^[LM]/',    ''],
+    # 0009: HORIZONTAL TABULATION
+    # 000A: LINE FEED
+    # 000B: VERTICAL TABULATION
+    # 000C: FORM FEED
+    # 000D: CARRIAGE RETURN
+    # 0020: SPACE
+    ['IsSpace',  '$cat  =~ /^Z/ ||
+                  $code =~ /^(0009|000A|000B|000C|000D)$/',    ''],
+    ['IsSpacePerl',
+                 '$cat  =~ /^Z/ ||
+                  $code =~ /^(0009|000A|000C|000D)$/',         ''],
+    ['IsBlank',  '$cat  =~ /^Z[^lp]$/ ||  $code eq "0009"',    ''],
     ['IsDigit',  '$cat =~ /^Nd$/',     ''],
     ['IsUpper',  '$cat =~ /^L[ut]$/',  ''],
     ['IsLower',  '$cat =~ /^Ll$/',     ''],
-    ['IsASCII',  'hex $code <= 127',   ''],
+    ['IsASCII',  '$code le "007f"',    ''],
     ['IsCntrl',  '$cat =~ /^C/',       ''],
-    ['IsGraph',  '$cat =~ /^[^C]/ and ($cat !~ /^Z/ and $code ne "0020" or chr(hex $code) !~ /^\s/)',  ''],
-    ['IsPrint',  '$cat =~ /^[^C]/',    ''],
-    ['IsPunct',  'Punctuation',        $PropData],
+    ['IsGraph',  '$cat =~ /^([LMNPS]|Co)/',    ''],
+    ['IsPrint',  '$cat =~ /^([LMNPS]|Co|Zs)/', ''],
+    ['IsPunct',  '$cat =~ /^P/',       ''],
+    # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f
     ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/',  ''],
     ['ToUpper',  '$up',                        '$up'],
     ['ToLower',  '$down',              '$down'],
@@ -145,7 +158,7 @@ mkdir "To", 0755;
     ['IsDCfont',       '$decomp =~ /^<font>/',         ''],
     ['IsDCnoBreak',    '$decomp =~ /^<noBreak>/',      ''],
     ['IsDCinitial',    '$decomp =~ /^<initial>/',      ''],
-    ['IsDCinital',     '$decomp =~ /^<medial>/',       ''],
+    ['IsDCmedial',     '$decomp =~ /^<medial>/',       ''],
     ['IsDCfinal',      '$decomp =~ /^<final>/',        ''],
     ['IsDCisolated',   '$decomp =~ /^<isolated>/',     ''],
     ['IsDCcircle',     '$decomp =~ /^<circle>/',       ''],
index 40e946e..bc8bc23 100644 (file)
-################################################################################\r
-#\r
-#   V: as  "u" in "but" (often represented with schwa or small uppercase lambda)\r
-#   U: as "oo" in "fool"\r
-#   I: as "ea" in "meat"\r
-#   A: as  "a" in "father"\r
-#   E: as  "a" in "hate"\r
-#   C: the consonant form having no vowel element\r
-#   O: as  "o" in "note"\r
-#\r
-#   Vowel identifiers are assumed short, doubled identifiers are considered long\r
-#   (following Cushitic rules).  Dipthong syllables are identified with "W" as\r
-#   per Ethiopic and Canadian syllabary character names.\r
-#   \r
-#\r
-#   WV  WVV  WU  WUU  WI  WII  WA  WAA  WAI  WAAI WE  WEE  WC  WO  WOO\r
-#\r
-#    V   VV   U   UU   I   II   A   AA   AI   AAI  E   EE   C   O   OO\r
-# \r
-################################################################################\r
-\r
-#\r
-# Ethiopic\r
-#\r
-1200; HA; V\r
-1201; HU; U\r
-1202; HI; I\r
-1203; HAA; A\r
-1204; HEE; E\r
-1205; HE; C\r
-1206; HO; O\r
-1208; LA; V\r
-1209; LU; U\r
-120A; LI; I\r
-120B; LAA; A\r
-120C; LEE; E\r
-120D; LE; C\r
-120E; LO; O\r
-120F; LWA; WA\r
-1210; HHA; V\r
-1211; HHU; U\r
-1212; HHI; I\r
-1213; HHAA; A\r
-1214; HHEE; E\r
-1215; HHE; C\r
-1216; HHO; O\r
-1217; HHWA; WA\r
-1218; MA; V\r
-1219; MU; U\r
-121A; MI; I\r
-121B; MAA; A\r
-121C; MEE; E\r
-121D; ME; C\r
-121E; MO; O\r
-121F; MWA; WA\r
-1220; SZA; V\r
-1221; SZU; U\r
-1222; SZI; I\r
-1223; SZAA; A\r
-1224; SZEE; E\r
-1225; SZE; C\r
-1226; SZO; O\r
-1227; SZWA; WA\r
-1228; RA; V\r
-1229; RU; U\r
-122A; RI; I\r
-122B; RAA; A\r
-122C; REE; E\r
-122D; RE; C\r
-122E; RO; O\r
-122F; RWA; WA\r
-1230; SA; V\r
-1231; SU; U\r
-1232; SI; I\r
-1233; SAA; A\r
-1234; SEE; E\r
-1235; SE; C\r
-1236; SO; O\r
-1237; SWA; WA\r
-1238; SHA; V\r
-1239; SHU; U\r
-123A; SHI; I\r
-123B; SHAA; A\r
-123C; SHEE; E\r
-123D; SHE; C\r
-123E; SHO; O\r
-123F; SHWA; WA\r
-1240; QA; V\r
-1241; QU; U\r
-1242; QI; I\r
-1243; QAA; A\r
-1244; QEE; E\r
-1245; QE; C\r
-1246; QO; O\r
-1248; QWA; WV\r
-124A; QWI; WI\r
-124B; QWAA; WA\r
-124C; QWEE; WE\r
-124D; QWE; WC\r
-1250; QHA; V\r
-1251; QHU; U\r
-1252; QHI; I\r
-1253; QHAA; A\r
-1254; QHEE; E\r
-1255; QHE; C\r
-1256; QHO; O\r
-1258; QHWA; WV\r
-125A; QHWI; WI\r
-125B; QHWAA; WA\r
-125C; QHWEE; WE\r
-125D; QHWE; WC\r
-1260; BA; V\r
-1261; BU; U\r
-1262; BI; I\r
-1263; BAA; A\r
-1264; BEE; E\r
-1265; BE; C\r
-1266; BO; O\r
-1267; BWA; WA\r
-1268; VA; V\r
-1269; VU; U\r
-126A; VI; I\r
-126B; VAA; A\r
-126C; VEE; E\r
-126D; VE; C\r
-126E; VO; O\r
-126F; VWA; WA\r
-1270; TA; V\r
-1271; TU; U\r
-1272; TI; I\r
-1273; TAA; A\r
-1274; TEE; E\r
-1275; TE; C\r
-1276; TO; O\r
-1277; TWA; WA\r
-1278; CA; V\r
-1279; CU; U\r
-127A; CI; I\r
-127B; CAA; A\r
-127C; CEE; E\r
-127D; CE; C\r
-127E; CO; O\r
-127F; CWA; WA\r
-1280; XA; V\r
-1281; XU; U\r
-1282; XI; I\r
-1283; XAA; A\r
-1284; XEE; E\r
-1285; XE; C\r
-1286; XO; O\r
-1288; XWA; WV\r
-128A; XWI; WI\r
-128B; XWAA; WA\r
-128C; XWEE; WE\r
-128D; XWE; WC\r
-1290; NA; V\r
-1291; NU; U\r
-1292; NI; I\r
-1293; NAA; A\r
-1294; NEE; E\r
-1295; NE; C\r
-1296; NO; O\r
-1297; NWA; WA\r
-1298; NYA; V\r
-1299; NYU; U\r
-129A; NYI; I\r
-129B; NYAA; A\r
-129C; NYEE; E\r
-129D; NYE; C\r
-129E; NYO; O\r
-129F; NYWA; WA\r
-12A0; GLOTTAL A; V\r
-12A1; GLOTTAL U; U\r
-12A2; GLOTTAL I; I\r
-12A3; GLOTTAL AA; A\r
-12A4; GLOTTAL EE; E\r
-12A5; GLOTTAL E; C\r
-12A6; GLOTTAL O; O\r
-12A7; GLOTTAL WA; WA\r
-12A8; KA; V\r
-12A9; KU; U\r
-12AA; KI; I\r
-12AB; KAA; A\r
-12AC; KEE; E\r
-12AD; KE; C\r
-12AE; KO; O\r
-12B0; KWA; WV\r
-12B2; KWI; WI\r
-12B3; KWAA; WA\r
-12B4; KWEE; WE\r
-12B5; KWE; WC\r
-12B8; KXA; V\r
-12B9; KXU; U\r
-12BA; KXI; I\r
-12BB; KXAA; A\r
-12BC; KXEE; E\r
-12BD; KXE; C\r
-12BE; KXO; O\r
-12C0; KXWA; WV\r
-12C2; KXWI; WI\r
-12C3; KXWAA; WA\r
-12C4; KXWEE; WE\r
-12C5; KXWE; WC\r
-12C8; WA; V\r
-12C9; WU; U\r
-12CA; WI; I\r
-12CB; WAA; A\r
-12CC; WEE; E\r
-12CD; WE; C\r
-12CE; WO; O\r
-12D0; PHARYNGEAL A; V\r
-12D1; PHARYNGEAL U; U\r
-12D2; PHARYNGEAL I; I\r
-12D3; PHARYNGEAL AA; A\r
-12D4; PHARYNGEAL EE; E\r
-12D5; PHARYNGEAL E; C\r
-12D6; PHARYNGEAL O; O\r
-12D8; ZA; V\r
-12D9; ZU; U\r
-12DA; ZI; I\r
-12DB; ZAA; A\r
-12DC; ZEE; E\r
-12DD; ZE; C\r
-12DE; ZO; O\r
-12DF; ZWA; WA\r
-12E0; ZHA; V\r
-12E1; ZHU; U\r
-12E2; ZHI; I\r
-12E3; ZHAA; A\r
-12E4; ZHEE; E\r
-12E5; ZHE; C\r
-12E6; ZHO; O\r
-12E7; ZHWA; WA\r
-12E8; YA; V\r
-12E9; YU; U\r
-12EA; YI; I\r
-12EB; YAA; A\r
-12EC; YEE; E\r
-12ED; YE; C\r
-12EE; YO; O\r
-12F0; DA; V\r
-12F1; DU; U\r
-12F2; DI; I\r
-12F3; DAA; A\r
-12F4; DEE; E\r
-12F5; DE; C\r
-12F6; DO; O\r
-12F7; DWA; WA\r
-12F8; DDA; V\r
-12F9; DDU; U\r
-12FA; DDI; I\r
-12FB; DDAA; A\r
-12FC; DDEE; E\r
-12FD; DDE; C\r
-12FE; DDO; O\r
-12FF; DDWA; WA\r
-1300; JA; V\r
-1301; JU; U\r
-1302; JI; I\r
-1303; JAA; A\r
-1304; JEE; E\r
-1305; JE; C\r
-1306; JO; O\r
-1307; JWA; WA\r
-1308; GA; V\r
-1309; GU; U\r
-130A; GI; I\r
-130B; GAA; A\r
-130C; GEE; E\r
-130D; GE; C\r
-130E; GO; O\r
-1310; GWA; WV\r
-1312; GWI; WI\r
-1313; GWAA; WA\r
-1314; GWEE; WE\r
-1315; GWE; WC\r
-1318; GGA; V\r
-1319; GGU; U\r
-131A; GGI; I\r
-131B; GGAA; A\r
-131C; GGEE; E\r
-131D; GGE; C\r
-131E; GGO; O\r
-1320; THA; V\r
-1321; THU; U\r
-1322; THI; I\r
-1323; THAA; A\r
-1324; THEE; E\r
-1325; THE; C\r
-1326; THO; O\r
-1327; THWA; WA\r
-1328; CHA; V\r
-1329; CHU; U\r
-132A; CHI; I\r
-132B; CHAA; A\r
-132C; CHEE; E\r
-132D; CHE; C\r
-132E; CHO; O\r
-132F; CHWA; WA\r
-1330; PHA; V\r
-1331; PHU; U\r
-1332; PHI; I\r
-1333; PHAA; A\r
-1334; PHEE; E\r
-1335; PHE; C\r
-1336; PHO; O\r
-1337; PHWA; WA\r
-1338; TSA; V\r
-1339; TSU; U\r
-133A; TSI; I\r
-133B; TSAA; A\r
-133C; TSEE; E\r
-133D; TSE; C\r
-133E; TSO; O\r
-133F; TSWA; WA\r
-1340; TZA; V\r
-1341; TZU; U\r
-1342; TZI; I\r
-1343; TZAA; A\r
-1344; TZEE; E\r
-1345; TZE; C\r
-1346; TZO; O\r
-1348; FA; V\r
-1349; FU; U\r
-134A; FI; I\r
-134B; FAA; A\r
-134C; FEE; E\r
-134D; FE; C\r
-134E; FO; O\r
-134F; FWA; WA\r
-1350; PA; V\r
-1351; PU; U\r
-1352; PI; I\r
-1353; PAA; A\r
-1354; PEE; E\r
-1355; PE; C\r
-1356; PO; O\r
-1357; PWA; WA\r
-#\r
-# Cherokee\r
-#\r
-13A0; A; A\r
-13A1; E; E\r
-13A2; I; I\r
-13A3; O; O\r
-13A4; U; U\r
-13A5; V; V\r
-13A6; GA; A \r
-13A7; KA; A \r
-13A8; GE; E\r
-13A9; GI; I\r
-13AA; GO; O\r
-13AB; GU; U\r
-13AC; GV; V\r
-13AD; HA; A\r
-13AE; HE; E\r
-13AF; HI; I\r
-13B0; HO; O\r
-13B1; HU; U\r
-13B2; HV; V\r
-13B3; LA; A\r
-13B4; LE; E\r
-13B5; LI; I\r
-13B6; LO; O\r
-13B7; LU; U\r
-13B8; LV; V\r
-13B9; MA; A\r
-13BA; ME; E\r
-13BB; MI; I\r
-13BC; MO; O\r
-13BD; MU; U\r
-13BE; NA; A\r
-13BF; HNA; A\r
-13C0; NAH; C\r
-13C1; NE; E\r
-13C2; NI; I\r
-13C3; NO; O\r
-13C4; NU; U\r
-13C5; NV; V\r
-13C6; QUA; A\r
-13C7; QUE; E\r
-13C8; QUI; I\r
-13C9; QUO; O\r
-13CA; QUU; U\r
-13CB; QUV; V\r
-13CC; SA; A\r
-13CD; S; C\r
-13CE; SE; E\r
-13CF; SI; I\r
-13D0; SO; O\r
-13D1; SU; U\r
-13D2; SV; V\r
-13D3; DA; A\r
-13D4; TA; A\r
-13D5; DE; E\r
-13D6; TE; E\r
-13D7; DI; I\r
-13D8; TI; I\r
-13D9; DO; O\r
-13DA; DU; U\r
-13DB; DV; V\r
-13DC; DLA; A\r
-13DD; TLA; A\r
-13DE; TLE; E\r
-13DF; TLI; I\r
-13E0; TLO; O\r
-13E1; TLU; U\r
-13E2; TLV; V\r
-13E3; TSA; A\r
-13E4; TSE; E\r
-13E5; TSI; I\r
-13E6; TSO; O\r
-13E7; TSU; U\r
-13E8; TSV; V\r
-13E9; WA; A\r
-13EA; WE; E\r
-13EB; WI; I\r
-13EC; WO; O\r
-13ED; WU; U\r
-13EE; WV; V\r
-13EF; YA; A\r
-13F0; YE; E\r
-13F1; YI; I\r
-13F2; YO; O\r
-13F3; YU; U\r
-13F4; YV; V\r
-#\r
-#      1400    Unified Canadian Aboriginal Syllabics   167F\r
-#\r
-1401; E; E\r
-1402; AAI; AAI\r
-1403; I; I\r
-1404; II; II\r
-1405; O; O\r
-1406; OO; OO\r
-1407; Y-CREE OO; OO\r
-1408; CARRIER EE; EE\r
-1409; CARRIER I; I\r
-140A; A; A\r
-140B; AA; AA\r
-140C; WE; WE\r
-140D; WEST-CREE WE; WE\r
-140E; WI; WI\r
-140F; WEST-CREE WI; WI\r
-1410; WII; WII\r
-1411; WEST-CREE WII; WII\r
-1412; WO; WO\r
-1413; WEST-CREE WO; WO\r
-1414; WOO; WOO\r
-1415; WEST-CREE WOO; WOO\r
-1416; NASKAPI WOO; WOO\r
-1417; WA; WA\r
-1418; WEST-CREE WA; WA\r
-1419; WAA; WAA\r
-141A; WEST-CREE WAA; WAA\r
-141B; NASKAPI WAA; WAA\r
-141C; AI; AI\r
-141D; Y-CREE W; C\r
-142B; EN; C\r
-142C; IN; C\r
-142D; ON; C\r
-142E; AN; C\r
-142F; PE; E\r
-1430; PAAI; AAI\r
-1431; PI; I\r
-1432; PII; II\r
-1433; PO; O\r
-1434; POO; OO\r
-1435; Y-CREE POO; OO\r
-1436; CARRIER HEE; EE\r
-1437; CARRIER HI; I\r
-1438; PA; A\r
-1439; PAA; AA\r
-143A; PWE; WE\r
-143B; WEST-CREE PWE; WE\r
-143C; PWI; WI\r
-143D; WEST-CREE PWI; WI\r
-143E; PWII; WII\r
-143F; WEST-CREE PWII; WII\r
-1440; PWO; WO\r
-1441; WEST-CREE PWO; WO\r
-1442; PWOO; WOO\r
-1443; WEST-CREE PWOO; WOO\r
-1444; PWA; WA\r
-1445; WEST-CREE PWA; WA\r
-1446; PWAA; WAA\r
-1447; WEST-CREE PWAA; WAA\r
-1448; Y-CREE PWAA; WAA\r
-1449; P; C\r
-144A; WEST-CREE P; C\r
-144B; CARRIER H; C\r
-144C; TE; E\r
-144D; TAAI; AAI\r
-144E; TI; I\r
-144F; TII; II\r
-1450; TO; O\r
-1451; TOO; OO\r
-1452; Y-CREE TOO; OO\r
-1453; CARRIER DEE; EE\r
-1454; CARRIER DI; I\r
-1455; TA; A\r
-1456; TAA; AA\r
-1457; TWE; WE\r
-1458; WEST-CREE TWE; WE\r
-1459; TWI; WI\r
-145A; WEST-CREE TWI; WI\r
-145B; TWII; WII\r
-145C; WEST-CREE TWII; WII\r
-145D; TWO; WO\r
-145E; WEST-CREE TWO; WO\r
-145F; TWOO; WOO\r
-1460; WEST-CREE TWOO; WOO\r
-1461; TWA; WA\r
-1462; WEST-CREE TWA; WA\r
-1463; TWAA; WAA\r
-1464; WEST-CREE TWAA; WAA\r
-1465; NASKAPI TWAA; WAA\r
-1466; T; C \r
-1467; TTE; E \r
-1468; TTI; I\r
-1469; TTO; O\r
-146A; TTA; A\r
-146B; KE; E\r
-146C; KAAI; AAI\r
-146D; KI; I\r
-146E; KII; II\r
-146F; KO; O\r
-1470; KOO; OO\r
-1471; Y-CREE KOO; OO\r
-1472; KA; A\r
-1473; KAA; AA\r
-1474; KWE; WE\r
-1475; WEST-CREE KWE; WE\r
-1476; KWI; WI\r
-1477; WEST-CREE KWI; WI\r
-1478; KWII; WII\r
-1479; WEST-CREE KWII; WII\r
-147A; KWO; WO\r
-147B; WEST-CREE KWO; WO\r
-147C; KWOO; WOO\r
-147D; WEST-CREE KWOO; WOO\r
-147E; KWA; WA\r
-147F; WEST-CREE KWA; WA\r
-1480; KWAA; WAA\r
-1481; WEST-CREE KWAA; WAA\r
-1482; NASKAPI KWAA; WAA\r
-1483; K; C\r
-1484; KW; WC\r
-1485; SOUTH-SLAVEY KEH; C\r
-1486; SOUTH-SLAVEY KIH; C\r
-1487; SOUTH-SLAVEY KOH; C\r
-1488; SOUTH-SLAVEY KAH; C\r
-1489; CE; E\r
-148A; CAAI; AAI\r
-148B; CI; I\r
-148C; CII; II\r
-148D; CO; O\r
-148E; COO; OO\r
-148F; Y-CREE COO; OO\r
-1490; CA; A\r
-1491; CAA; AA\r
-1492; CWE; WE\r
-1493; WEST-CREE CWE; WE\r
-1494; CWI; WI\r
-1495; WEST-CREE CWI; WI\r
-1496; CWII; WII\r
-1497; WEST-CREE CWII; WII\r
-1498; CWO; WO\r
-1499; WEST-CREE CWO; WO\r
-149A; CWOO; WOO\r
-149B; WEST-CREE CWOO; WOO\r
-149C; CWA; WA\r
-149D; WEST-CREE CWA; WA\r
-149E; CWAA; WAA\r
-149F; WEST-CREE CWAA; WAA\r
-14A0; NASKAPI CWAA; WAA\r
-14A1; C; C\r
-14A2; SAYISI TH; \r
-14A3; ME; E\r
-14A4; MAAI; AAI\r
-14A5; MI; I\r
-14A6; MII; II\r
-14A7; MO; O\r
-14A8; MOO; OO\r
-14A9; Y-CREE MOO; OO\r
-14AA; MA; A\r
-14AB; MAA; AA\r
-14AC; MWE; WE\r
-14AD; WEST-CREE MWE; WE\r
-14AE; MWI; WI\r
-14AF; WEST-CREE MWI; WI\r
-14B0; MWII; WII\r
-14B1; WEST-CREE MWII; WII\r
-14B2; MWO; WO\r
-14B3; WEST-CREE MWO; WO\r
-14B4; MWOO; WOO\r
-14B5; WEST-CREE MWOO; WOO\r
-14B6; MWA; WA\r
-14B7; WEST-CREE MWA; WA\r
-14B8; MWAA; WAA\r
-14B9; WEST-CREE MWAA; WAA\r
-14BA; NASKAPI MWAA; WAA\r
-14BB; M; C\r
-14BC; WEST-CREE M; C\r
-14BD; MH; C\r
-14BE; ATHAPASCAN M; C\r
-14BF; SAYISI M; C\r
-14C0; NE; E\r
-14C1; NAAI; AAI\r
-14C2; NI; I\r
-14C3; NII; II\r
-14C4; NO; O\r
-14C5; NOO; OO\r
-14C6; Y-CREE NOO; OO\r
-14C7; NA; A\r
-14C8; NAA; AA\r
-14C9; NWE; WE\r
-14CA; WEST-CREE NWE; WE\r
-14CB; NWA; WA\r
-14CC; WEST-CREE NWA; WA\r
-14CD; NWAA; WAA\r
-14CE; WEST-CREE NWAA; WAA\r
-14CF; NASKAPI NWAA; WAA\r
-14D0; N; C\r
-14D1; CARRIER NG; C\r
-14D2; NH; C\r
-14D3; LE; E\r
-14D4; LAAI; AAI\r
-14D5; LI; I\r
-14D6; LII; II\r
-14D7; LO; O\r
-14D8; LOO; OO\r
-14D9; Y-CREE LOO; OO\r
-14DA; LA; A\r
-14DB; LAA; AA\r
-14DC; LWE; WE\r
-14DD; WEST-CREE LWE; WE\r
-14DE; LWI; WI\r
-14DF; WEST-CREE LWI; WI\r
-14E0; LWII; WII\r
-14E1; WEST-CREE LWII; WII\r
-14E2; LWO; WO\r
-14E3; WEST-CREE LWO; WO\r
-14E4; LWOO; WOO\r
-14E5; WEST-CREE LWOO; WOO\r
-14E6; LWA; WA\r
-14E7; WEST-CREE LWA; WA\r
-14E8; LWAA; WAA\r
-14E9; WEST-CREE LWAA; WAA\r
-14EA; L; C\r
-14EB; WEST-CREE L; C\r
-14EC; MEDIAL L; C\r
-14ED; SE; E\r
-14EE; SAAI; AAI\r
-14EF; SI; I\r
-14F0; SII; II\r
-14F1; SO; O\r
-14F2; SOO; OO\r
-14F3; Y-CREE SOO; OO\r
-14F4; SA; A\r
-14F5; SAA; AA\r
-14F6; SWE; WE\r
-14F7; WEST-CREE SWE; WE\r
-14F8; SWI; WI\r
-14F9; WEST-CREE SWI; WI\r
-14FA; SWII; WII\r
-14FB; WEST-CREE SWII; WII\r
-14FC; SWO; WO\r
-14FD; WEST-CREE SWO; WO\r
-14FE; SWOO; WOO\r
-14FF; WEST-CREE SWOO; WOO\r
-1500; SWA; WA\r
-1501; WEST-CREE SWA; WA\r
-1502; SWAA; WAA\r
-1503; WEST-CREE SWAA; WAA\r
-1504; NASKAPI SWAA; WAA\r
-1505; S; C\r
-1506; ATHAPASCAN S; C\r
-1507; SW; WC\r
-1508; BLACKFOOT S; C\r
-1509; MOOSE-CREE SK;C \r
-150A; NASKAPI SKW; C\r
-150B; NASKAPI S-W; C\r
-150C; NASKAPI SPWA; WA\r
-150D; NASKAPI STWA; WA\r
-150E; NASKAPI SKWA; WA\r
-150F; NASKAPI SCWA; WA\r
-1510; SHE; E\r
-1511; SHI; I\r
-1512; SHII; II\r
-1513; SHO; O\r
-1514; SHOO; OO\r
-1515; SHA; A\r
-1516; SHAA; AA\r
-1517; SHWE; WE\r
-1518; WEST-CREE SHWE; WE\r
-1519; SHWI; WI\r
-151A; WEST-CREE SHWI; WI\r
-151B; SHWII; WII\r
-151C; WEST-CREE SHWII; WII\r
-151D; SHWO; WO\r
-151E; WEST-CREE SHWO; WO\r
-151F; SHWOO; WOO\r
-1520; WEST-CREE SHWOO; WOO\r
-1521; SHWA; WA\r
-1522; WEST-CREE SHWA; WA\r
-1523; SHWAA; WAA\r
-1524; WEST-CREE SHWAA; WAA\r
-1525; SH; C\r
-1526; YE; E\r
-1527; YAAI; AAI\r
-1528; YI; I\r
-1529; YII; II\r
-152A; YO; O\r
-152B; YOO; OO\r
-152C; Y-CREE YOO; OO\r
-152D; YA; A\r
-152E; YAA; AA\r
-152F; YWE; WE\r
-1530; WEST-CREE YWE; WE\r
-1531; YWI; WI\r
-1532; WEST-CREE YWI; WI\r
-1533; YWII; WII\r
-1534; WEST-CREE YWII; WII\r
-1535; YWO; WO\r
-1536; WEST-CREE YWO; WO\r
-1537; YWOO; WOO\r
-1538; WEST-CREE YWOO; WOO\r
-1539; YWA; WA\r
-153A; WEST-CREE YWA; WA\r
-153B; YWAA; WAA\r
-153C; WEST-CREE YWAA; WAA\r
-153D; NASKAPI YWAA; WAA\r
-153E; Y; C\r
-153F; BIBLE-CREE Y; C\r
-1540; WEST-CREE Y; C\r
-1541; SAYISI YI; I\r
-1542; RE; E\r
-1543; R-CREE RE; E\r
-1544; WEST-CREE LE; E\r
-1545; RAAI; AAI\r
-1546; RI; I\r
-1547; RII; II\r
-1548; RO; O\r
-1549; ROO; OO\r
-154A; WEST-CREE LO; O\r
-154B; RA; A\r
-154C; RAA; AA\r
-154D; WEST-CREE LA; A\r
-154E; RWAA; WAA\r
-154F; WEST-CREE RWAA; WAA\r
-1550; R; C\r
-1551; WEST-CREE R; C\r
-1552; MEDIAL R; C\r
-1553; FE; E\r
-1554; FAAI; AAI\r
-1555; FI; I\r
-1556; FII; II\r
-1557; FO; O\r
-1558; FOO; OO\r
-1559; FA; A\r
-155A; FAA; AA\r
-155B; FWAA; WAA\r
-155C; WEST-CREE FWAA; WAA\r
-155D; F; C\r
-155E; THE; E\r
-155F; N-CREE THE; E\r
-1560; THI; I\r
-1561; N-CREE THI; I\r
-1562; THII; II\r
-1563; N-CREE THII; II\r
-1564; THO; O\r
-1565; THOO; OO\r
-1566; THA; A\r
-1567; THAA; AA\r
-1568; THWAA; WAA\r
-1569; WEST-CREE THWAA; WAA\r
-156A; TH; C\r
-156B; TTHE; E\r
-156C; TTHI; I\r
-156D; TTHO; O\r
-156E; TTHA; A\r
-156F; TTH; C\r
-1570; TYE; E\r
-1571; TYI; I\r
-1572; TYO; O\r
-1573; TYA; A\r
-1574; NUNAVIK HE; E\r
-1575; NUNAVIK HI; I\r
-1576; NUNAVIK HII; II\r
-1577; NUNAVIK HO; O\r
-1578; NUNAVIK HOO; OO\r
-1579; NUNAVIK HA; A\r
-157A; NUNAVIK HAA; AA\r
-157B; NUNAVIK H; C\r
-157C; NUNAVUT H; C\r
-157D; HK; C\r
-157E; QAAI; AAI\r
-157F; QI; I\r
-1580; QII; II\r
-1581; QO; O\r
-1582; QOO; OO\r
-1583; QA; A\r
-1584; QAA; AA\r
-1585; Q; C\r
-1586; TLHE; E\r
-1587; TLHI; I\r
-1588; TLHO; O\r
-1589; TLHA; A\r
-158A; WEST-CREE RE; E\r
-158B; WEST-CREE RI; I\r
-158C; WEST-CREE RO; O\r
-158D; WEST-CREE RA; A\r
-158E; NGAAI; AAI\r
-158F; NGI; I\r
-1590; NGII; II\r
-1591; NGO; O\r
-1592; NGOO; OO\r
-1593; NGA; A\r
-1594; NGAA; AA\r
-1595; NG; C\r
-1596; NNG; C\r
-1597; SAYISI SHE; E\r
-1598; SAYISI SHI; I\r
-1599; SAYISI SHO; O\r
-159A; SAYISI SHA; A\r
-159B; WOODS-CREE THE; E\r
-159C; WOODS-CREE THI; I\r
-159D; WOODS-CREE THO; O\r
-159E; WOODS-CREE THA; A\r
-159F; WOODS-CREE TH; C\r
-15A0; LHI; I\r
-15A1; LHII; II\r
-15A2; LHO; O\r
-15A3; LHOO; OO\r
-15A4; LHA; A\r
-15A5; LHAA; AA\r
-15A6; LH; C\r
-15A7; TH-CREE THE; E\r
-15A8; TH-CREE THI; I\r
-15A9; TH-CREE THII; II\r
-15AA; TH-CREE THO; O\r
-15AB; TH-CREE THOO; OO\r
-15AC; TH-CREE THA; A\r
-15AD; TH-CREE THAA; AA\r
-15AE; TH-CREE TH; C\r
-15AF; AIVILIK B; C\r
-15B0; BLACKFOOT E; E\r
-15B1; BLACKFOOT I; I\r
-15B2; BLACKFOOT O; O\r
-15B3; BLACKFOOT A; A\r
-15B4; BLACKFOOT WE; E\r
-15B5; BLACKFOOT WI; I\r
-15B6; BLACKFOOT WO; O\r
-15B7; BLACKFOOT WA; A\r
-15B8; BLACKFOOT NE; E\r
-15B9; BLACKFOOT NI; I\r
-15BA; BLACKFOOT NO; O\r
-15BB; BLACKFOOT NA; A\r
-15BC; BLACKFOOT KE; E\r
-15BD; BLACKFOOT KI; I\r
-15BE; BLACKFOOT KO; O\r
-15BF; BLACKFOOT KA; A\r
-15C0; SAYISI HE; E\r
-15C1; SAYISI HI; I\r
-15C2; SAYISI HO; O\r
-15C3; SAYISI HA; A\r
-15C4; CARRIER GHU; U\r
-15C5; CARRIER GHO; O\r
-15C6; CARRIER GHE; E\r
-15C7; CARRIER GHEE; EE\r
-15C8; CARRIER GHI; I\r
-15C9; CARRIER GHA; A\r
-15CA; CARRIER RU; U\r
-15CB; CARRIER RO; O\r
-15CC; CARRIER RE; E\r
-15CD; CARRIER REE; EE\r
-15CE; CARRIER RI; I\r
-15CF; CARRIER RA; A\r
-15D0; CARRIER WU; U\r
-15D1; CARRIER WO; O\r
-15D2; CARRIER WE; E\r
-15D3; CARRIER WEE; EE\r
-15D4; CARRIER WI; I\r
-15D5; CARRIER WA; A\r
-15D6; CARRIER HWU; WU\r
-15D7; CARRIER HWO; WO\r
-15D8; CARRIER HWE; WE\r
-15D9; CARRIER HWEE; WEE\r
-15DA; CARRIER HWI; WI\r
-15DB; CARRIER HWA; WA\r
-15DC; CARRIER THU; U\r
-15DD; CARRIER THO; O\r
-15DE; CARRIER THE; E\r
-15DF; CARRIER THEE; EE\r
-15E0; CARRIER THI; I\r
-15E1; CARRIER THA; A\r
-15E2; CARRIER TTU; U\r
-15E3; CARRIER TTO; O\r
-15E4; CARRIER TTE; E\r
-15E5; CARRIER TTEE; EE\r
-15E6; CARRIER TTI; I\r
-15E7; CARRIER TTA; A\r
-15E8; CARRIER PU; U\r
-15E9; CARRIER PO; O\r
-15EA; CARRIER PE; E\r
-15EB; CARRIER PEE; EE\r
-15EC; CARRIER PI; I\r
-15ED; CARRIER PA; A\r
-15EE; CARRIER P; \r
-15EF; CARRIER GU; U\r
-15F0; CARRIER GO; O\r
-15F1; CARRIER GE; E\r
-15F2; CARRIER GEE; EE\r
-15F3; CARRIER GI; I\r
-15F4; CARRIER GA; A\r
-15F5; CARRIER KHU; U\r
-15F6; CARRIER KHO; O\r
-15F7; CARRIER KHE; E\r
-15F8; CARRIER KHEE; EE\r
-15F9; CARRIER KHI; I\r
-15FA; CARRIER KHA; A\r
-15FB; CARRIER KKU; U\r
-15FC; CARRIER KKO; O\r
-15FD; CARRIER KKE; E\r
-15FE; CARRIER KKEE; EE\r
-15FF; CARRIER KKI; I\r
-1600; CARRIER KKA; A\r
-1601; CARRIER KK; \r
-1602; CARRIER NU; U\r
-1603; CARRIER NO; O\r
-1604; CARRIER NE; E\r
-1605; CARRIER NEE; EE\r
-1606; CARRIER NI; I\r
-1607; CARRIER NA; A\r
-1608; CARRIER MU; U\r
-1609; CARRIER MO; O\r
-160A; CARRIER ME; E\r
-160B; CARRIER MEE; EE\r
-160C; CARRIER MI; I\r
-160D; CARRIER MA; A\r
-160E; CARRIER YU; U\r
-160F; CARRIER YO; O\r
-1610; CARRIER YE; E\r
-1611; CARRIER YEE; EE\r
-1612; CARRIER YI; I\r
-1613; CARRIER YA; A\r
-1614; CARRIER JU; U\r
-1615; SAYISI JU; U\r
-1616; CARRIER JO; O\r
-1617; CARRIER JE; E\r
-1618; CARRIER JEE; EE\r
-1619; CARRIER JI; I\r
-161A; SAYISI JI; I\r
-161B; CARRIER JA; A\r
-161C; CARRIER JJU; U\r
-161D; CARRIER JJO; O\r
-161E; CARRIER JJE; E\r
-161F; CARRIER JJEE; EE\r
-1620; CARRIER JJI; I\r
-1621; CARRIER JJA; A\r
-1622; CARRIER LU; U\r
-1623; CARRIER LO; O\r
-1624; CARRIER LE; E\r
-1625; CARRIER LEE; EE\r
-1626; CARRIER LI; I\r
-1627; CARRIER LA; A\r
-1628; CARRIER DLU; U\r
-1629; CARRIER DLO; O\r
-162A; CARRIER DLE; E\r
-162B; CARRIER DLEE; EE\r
-162C; CARRIER DLI; I\r
-162D; CARRIER DLA; A\r
-162E; CARRIER LHU; U\r
-162F; CARRIER LHO; O\r
-1630; CARRIER LHE; E\r
-1631; CARRIER LHEE; EE\r
-1632; CARRIER LHI; I\r
-1633; CARRIER LHA; A\r
-1634; CARRIER TLHU; U\r
-1635; CARRIER TLHO; O\r
-1636; CARRIER TLHE; E\r
-1637; CARRIER TLHEE; EE\r
-1638; CARRIER TLHI; I\r
-1639; CARRIER TLHA; A\r
-163A; CARRIER TLU; U\r
-163B; CARRIER TLO; O\r
-163C; CARRIER TLE; E\r
-163D; CARRIER TLEE; EE\r
-163E; CARRIER TLI; I\r
-163F; CARRIER TLA; A\r
-1640; CARRIER ZU; U\r
-1641; CARRIER ZO; O\r
-1642; CARRIER ZE; E\r
-1643; CARRIER ZEE; EE\r
-1644; CARRIER ZI; I\r
-1645; CARRIER ZA; A\r
-1646; CARRIER Z; \r
-1647; CARRIER INITIAL Z; \r
-1648; CARRIER DZU; U\r
-1649; CARRIER DZO; O\r
-164A; CARRIER DZE; E\r
-164B; CARRIER DZEE; EE\r
-164C; CARRIER DZI; I\r
-164D; CARRIER DZA; A\r
-164E; CARRIER SU; U\r
-164F; CARRIER SO; O\r
-1650; CARRIER SE; E\r
-1651; CARRIER SEE; EE\r
-1652; CARRIER SI; I\r
-1653; CARRIER SA; A\r
-1654; CARRIER SHU; U\r
-1655; CARRIER SHO; O\r
-1656; CARRIER SHE; E\r
-1657; CARRIER SHEE; EE\r
-1658; CARRIER SHI; I\r
-1659; CARRIER SHA; A\r
-165A; CARRIER SH; \r
-165B; CARRIER TSU; U\r
-165C; CARRIER TSO; O\r
-165D; CARRIER TSE; E\r
-165E; CARRIER TSEE; EE\r
-165F; CARRIER TSI; I\r
-1660; CARRIER TSA; A\r
-1661; CARRIER CHU; U\r
-1662; CARRIER CHO; O\r
-1663; CARRIER CHE; E\r
-1664; CARRIER CHEE; EE\r
-1665; CARRIER CHI; I\r
-1666; CARRIER CHA; A\r
-1667; CARRIER TTSU; U\r
-1668; CARRIER TTSO; O\r
-1669; CARRIER TTSE; E\r
-166A; CARRIER TTSEE; EE\r
-166B; CARRIER TTSI; I\r
-166C; CARRIER TTSA; A\r
-166F; QAI; AI\r
-1670; NGAI; AI\r
-1671; NNGI; I\r
-1672; NNGII; II\r
-1673; NNGO; O\r
-1674; NNGOO; OO\r
-1675; NNGA; A\r
-1676; NNGAA; AA\r
-#\r
-# Katakana\r
-#\r
-30A1; SMALL A; A\r
-30A2; A; A\r
-30A3; SMALL I; I\r
-30A4; I; I\r
-30A5; SMALL U; U\r
-30A6; U; U\r
-30A7; SMALL E; E\r
-30A8; E; E\r
-30A9; SMALL O; O\r
-30AA; O; O\r
-30AB; KA; A\r
-30AC; GA; A\r
-30AD; KI; I\r
-30AE; GI; I\r
-30AF; KU; U\r
-30B0; GU; U\r
-30B1; KE; E\r
-30B2; GE; E\r
-30B3; KO; O\r
-30B4; GO; O\r
-30B5; SA; A\r
-30B6; ZA; A\r
-30B7; SI; I\r
-30B8; ZI; I\r
-30B9; SU; U\r
-30BA; ZU; U\r
-30BB; SE; E\r
-30BC; ZE; E\r
-30BD; SO; O\r
-30BE; ZO; O\r
-30BF; TA; A\r
-30C0; DA; A\r
-30C1; TI; I\r
-30C2; DI; I\r
-30C3; SMALL TU; U\r
-30C4; TU; U\r
-30C5; DU; U\r
-30C6; TE; E\r
-30C7; DE; E\r
-30C8; TO; O\r
-30C9; DO; O\r
-30CA; NA; A\r
-30CB; NI; I\r
-30CC; NU; U\r
-30CD; NE; E\r
-30CE; NO; O\r
-30CF; HA; A\r
-30D0; BA; A\r
-30D1; PA; A\r
-30D2; HI; I\r
-30D3; BI; I\r
-30D4; PI; I\r
-30D5; HU; U\r
-30D6; BU; U\r
-30D7; PU; U\r
-30D8; HE; E\r
-30D9; BE; E\r
-30DA; PE; E\r
-30DB; HO; O\r
-30DC; BO; O\r
-30DD; PO; O\r
-30DE; MA; A\r
-30DF; MI; I\r
-30E0; MU; U\r
-30E1; ME; E\r
-30E2; MO; O\r
-30E3; SMALL YA; A\r
-30E4; YA; A\r
-30E5; SMALL YU; U\r
-30E6; YU; U\r
-30E7; SMALL YO; O\r
-30E8; YO; O\r
-30E9; RA; A\r
-30EA; RI; I\r
-30EB; RU; U\r
-30EC; RE; E\r
-30ED; RO; O\r
-30EE; SMALL WA; A\r
-30EF; WA; A\r
-30F0; WI; I\r
-30F1; WE; E\r
-30F2; WO; O\r
-30F3; N; C\r
-30F4; VU; U\r
-30F5; SMALL KA; A\r
-30F6; SMALL KE; E\r
-30F7; VA; A\r
-30F8; VI; I\r
-30F9; VE; E\r
-30FA; VO; O\r
-32D0; CIRCLED KATAKANA A; A\r
-32D1; CIRCLED KATAKANA I; I\r
-32D2; CIRCLED KATAKANA U; U\r
-32D3; CIRCLED KATAKANA E; E\r
-32D4; CIRCLED KATAKANA O; O\r
-32D5; CIRCLED KATAKANA KA; A\r
-32D6; CIRCLED KATAKANA KI; I\r
-32D7; CIRCLED KATAKANA KU; U\r
-32D8; CIRCLED KATAKANA KE; E\r
-32D9; CIRCLED KATAKANA KO; O\r
-32DA; CIRCLED KATAKANA SA; A\r
-32DB; CIRCLED KATAKANA SI; I\r
-32DC; CIRCLED KATAKANA SU; U\r
-32DD; CIRCLED KATAKANA SE; E\r
-32DE; CIRCLED KATAKANA SO; O\r
-32DF; CIRCLED KATAKANA TA; A\r
-32E0; CIRCLED KATAKANA TI; I\r
-32E1; CIRCLED KATAKANA TU; U\r
-32E2; CIRCLED KATAKANA TE; E\r
-32E3; CIRCLED KATAKANA TO; O\r
-32E4; CIRCLED KATAKANA NA; A\r
-32E5; CIRCLED KATAKANA NI; I\r
-32E6; CIRCLED KATAKANA NU; U\r
-32E7; CIRCLED KATAKANA NE; E\r
-32E8; CIRCLED KATAKANA NO; O\r
-32E9; CIRCLED KATAKANA HA; A\r
-32EA; CIRCLED KATAKANA HI; I\r
-32EB; CIRCLED KATAKANA HU; U\r
-32EC; CIRCLED KATAKANA HE; E\r
-32ED; CIRCLED KATAKANA HO; O\r
-32EE; CIRCLED KATAKANA MA; A\r
-32EF; CIRCLED KATAKANA MI; I\r
-32F0; CIRCLED KATAKANA MU; U\r
-32F1; CIRCLED KATAKANA ME; E\r
-32F2; CIRCLED KATAKANA MO; O\r
-32F3; CIRCLED KATAKANA YA; A\r
-32F4; CIRCLED KATAKANA YU; U\r
-32F5; CIRCLED KATAKANA YO; O\r
-32F6; CIRCLED KATAKANA RA; A\r
-32F7; CIRCLED KATAKANA RI; I\r
-32F8; CIRCLED KATAKANA RU; U\r
-32F9; CIRCLED KATAKANA RE; E\r
-32FA; CIRCLED KATAKANA RO; O\r
-32FB; CIRCLED KATAKANA WA; A\r
-32FC; CIRCLED KATAKANA WI; I\r
-32FD; CIRCLED KATAKANA WE; E\r
-32FE; CIRCLED KATAKANA WO; O\r
-#\r
-# Katakana\r
-#\r
-FF66; HALFWIDTH WO; O\r
-FF67; HALFWIDTH SMALL A; A\r
-FF68; HALFWIDTH SMALL I; I\r
-FF69; HALFWIDTH SMALL U; U\r
-FF6A; HALFWIDTH SMALL E; E\r
-FF6B; HALFWIDTH SMALL O; O\r
-FF6C; HALFWIDTH SMALL YA; A\r
-FF6D; HALFWIDTH SMALL YU; U\r
-FF6E; HALFWIDTH SMALL YO; O\r
-FF6F; HALFWIDTH SMALL TU; U\r
-FF71; HALFWIDTH A; A\r
-FF72; HALFWIDTH I; I\r
-FF73; HALFWIDTH U; U\r
-FF74; HALFWIDTH E; E\r
-FF75; HALFWIDTH O; O\r
-FF76; HALFWIDTH KA; A\r
-FF77; HALFWIDTH KI; I\r
-FF78; HALFWIDTH KU; U\r
-FF79; HALFWIDTH KE; E\r
-FF7A; HALFWIDTH KO; O\r
-FF7B; HALFWIDTH SA; A\r
-FF7C; HALFWIDTH SI; I\r
-FF7D; HALFWIDTH SU; U\r
-FF7E; HALFWIDTH SE; E\r
-FF7F; HALFWIDTH SO; O\r
-FF80; HALFWIDTH TA; A\r
-FF81; HALFWIDTH TI; I\r
-FF82; HALFWIDTH TU; U\r
-FF83; HALFWIDTH TE; E\r
-FF84; HALFWIDTH TO; O\r
-FF85; HALFWIDTH NA; A\r
-FF86; HALFWIDTH NI; I\r
-FF87; HALFWIDTH NU; U\r
-FF88; HALFWIDTH NE; E\r
-FF89; HALFWIDTH NO; O\r
-FF8A; HALFWIDTH HA; A\r
-FF8B; HALFWIDTH HI; I\r
-FF8C; HALFWIDTH HU; U\r
-FF8D; HALFWIDTH HE; E\r
-FF8E; HALFWIDTH HO; O\r
-FF8F; HALFWIDTH MA; A\r
-FF90; HALFWIDTH MI; I\r
-FF91; HALFWIDTH MU; U\r
-FF92; HALFWIDTH ME; E\r
-FF93; HALFWIDTH MO; O\r
-FF94; HALFWIDTH YA; A\r
-FF95; HALFWIDTH YU; U\r
-FF96; HALFWIDTH YO; O\r
-FF97; HALFWIDTH RA; A\r
-FF98; HALFWIDTH RI; I\r
-FF99; HALFWIDTH RU; U\r
-FF9A; HALFWIDTH RE; E\r
-FF9B; HALFWIDTH RO; O\r
-FF9C; HALFWIDTH WA; A\r
-FF9D; HALFWIDTH N; C\r
-#\r
-# Hiragana\r
-#\r
-3041; SMALL A; A\r
-3042; A; A\r
-3043; SMALL I; I\r
-3044; I; I\r
-3045; SMALL U; U\r
-3046; U; U\r
-3047; SMALL E; E\r
-3048; E; E\r
-3049; SMALL O; O\r
-304A; O; O\r
-304B; KA; A\r
-304C; GA; A\r
-304D; KI; I\r
-304E; GI; I\r
-304F; KU; U\r
-3050; GU; U\r
-3051; KE; E\r
-3052; GE; E\r
-3053; KO; O\r
-3054; GO; O\r
-3055; SA; A\r
-3056; ZA; A\r
-3057; SI; I\r
-3058; ZI; I\r
-3059; SU; U\r
-305A; ZU; U\r
-305B; SE; E\r
-305C; ZE; E\r
-305D; SO; O\r
-305E; ZO; O\r
-305F; TA; A\r
-3060; DA; A\r
-3061; TI; I\r
-3062; DI; I\r
-3063; SMALL TU; U\r
-3064; TU; U\r
-3065; DU; U\r
-3066; TE; E\r
-3067; DE; E\r
-3068; TO; O\r
-3069; DO; O\r
-306A; NA; A\r
-306B; NI; I\r
-306C; NU; U\r
-306D; NE; E\r
-306E; NO; O\r
-306F; HA; A\r
-3070; BA; A\r
-3071; PA; A\r
-3072; HI; I\r
-3073; BI; I\r
-3074; PI; I\r
-3075; HU; U\r
-3076; BU; U\r
-3077; PU; U\r
-3078; HE; E\r
-3079; BE; E\r
-307A; PE; E\r
-307B; HO; O\r
-307C; BO; O\r
-307D; PO; O\r
-307E; MA; A\r
-307F; MI; I\r
-3080; MU; U\r
-3081; ME; E\r
-3082; MO; O\r
-3083; SMALL YA; A\r
-3084; YA; A\r
-3085; SMALL YU; U\r
-3086; YU; U\r
-3087; SMALL YO; O\r
-3088; YO; O\r
-3089; RA; A\r
-308A; RI; I\r
-308B; RU; U\r
-308C; RE; E\r
-308D; RO; O\r
-308E; SMALL WA; A\r
-308F; WA; A\r
-3090; WI; I\r
-3091; WE; E\r
-3092; WO; O\r
-3093; N; N\r
-3094; VU; U\r
+################################################################################
+#
+#   V: as  "u" in "but" (often represented with schwa or small uppercase lambda)
+#   U: as "oo" in "fool"
+#   I: as "ea" in "meat"
+#   A: as  "a" in "father"
+#   E: as  "a" in "hate"
+#   C: the consonant form having no vowel element
+#   O: as  "o" in "note"
+#
+#   Vowel identifiers are assumed short, doubled identifiers are considered long
+#   (following Cushitic rules).  Dipthong syllables are identified with "W" as
+#   per Ethiopic and Canadian syllabary character names.
+#   
+#
+#   WV  WVV  WU  WUU  WI  WII  WA  WAA  WAI  WAAI WE  WEE  WC  WO  WOO
+#
+#    V   VV   U   UU   I   II   A   AA   AI   AAI  E   EE   C   O   OO
+# 
+################################################################################
+
+#
+# Ethiopic
+#
+1200; HA; V
+1201; HU; U
+1202; HI; I
+1203; HAA; A
+1204; HEE; E
+1205; HE; C
+1206; HO; O
+1208; LA; V
+1209; LU; U
+120A; LI; I
+120B; LAA; A
+120C; LEE; E
+120D; LE; C
+120E; LO; O
+120F; LWA; WA
+1210; HHA; V
+1211; HHU; U
+1212; HHI; I
+1213; HHAA; A
+1214; HHEE; E
+1215; HHE; C
+1216; HHO; O
+1217; HHWA; WA
+1218; MA; V
+1219; MU; U
+121A; MI; I
+121B; MAA; A
+121C; MEE; E
+121D; ME; C
+121E; MO; O
+121F; MWA; WA
+1220; SZA; V
+1221; SZU; U
+1222; SZI; I
+1223; SZAA; A
+1224; SZEE; E
+1225; SZE; C
+1226; SZO; O
+1227; SZWA; WA
+1228; RA; V
+1229; RU; U
+122A; RI; I
+122B; RAA; A
+122C; REE; E
+122D; RE; C
+122E; RO; O
+122F; RWA; WA
+1230; SA; V
+1231; SU; U
+1232; SI; I
+1233; SAA; A
+1234; SEE; E
+1235; SE; C
+1236; SO; O
+1237; SWA; WA
+1238; SHA; V
+1239; SHU; U
+123A; SHI; I
+123B; SHAA; A
+123C; SHEE; E
+123D; SHE; C
+123E; SHO; O
+123F; SHWA; WA
+1240; QA; V
+1241; QU; U
+1242; QI; I
+1243; QAA; A
+1244; QEE; E
+1245; QE; C
+1246; QO; O
+1248; QWA; WV
+124A; QWI; WI
+124B; QWAA; WA
+124C; QWEE; WE
+124D; QWE; WC
+1250; QHA; V
+1251; QHU; U
+1252; QHI; I
+1253; QHAA; A
+1254; QHEE; E
+1255; QHE; C
+1256; QHO; O
+1258; QHWA; WV
+125A; QHWI; WI
+125B; QHWAA; WA
+125C; QHWEE; WE
+125D; QHWE; WC
+1260; BA; V
+1261; BU; U
+1262; BI; I
+1263; BAA; A
+1264; BEE; E
+1265; BE; C
+1266; BO; O
+1267; BWA; WA
+1268; VA; V
+1269; VU; U
+126A; VI; I
+126B; VAA; A
+126C; VEE; E
+126D; VE; C
+126E; VO; O
+126F; VWA; WA
+1270; TA; V
+1271; TU; U
+1272; TI; I
+1273; TAA; A
+1274; TEE; E
+1275; TE; C
+1276; TO; O
+1277; TWA; WA
+1278; CA; V
+1279; CU; U
+127A; CI; I
+127B; CAA; A
+127C; CEE; E
+127D; CE; C
+127E; CO; O
+127F; CWA; WA
+1280; XA; V
+1281; XU; U
+1282; XI; I
+1283; XAA; A
+1284; XEE; E
+1285; XE; C
+1286; XO; O
+1288; XWA; WV
+128A; XWI; WI
+128B; XWAA; WA
+128C; XWEE; WE
+128D; XWE; WC
+1290; NA; V
+1291; NU; U
+1292; NI; I
+1293; NAA; A
+1294; NEE; E
+1295; NE; C
+1296; NO; O
+1297; NWA; WA
+1298; NYA; V
+1299; NYU; U
+129A; NYI; I
+129B; NYAA; A
+129C; NYEE; E
+129D; NYE; C
+129E; NYO; O
+129F; NYWA; WA
+12A0; GLOTTAL A; V
+12A1; GLOTTAL U; U
+12A2; GLOTTAL I; I
+12A3; GLOTTAL AA; A
+12A4; GLOTTAL EE; E
+12A5; GLOTTAL E; C
+12A6; GLOTTAL O; O
+12A7; GLOTTAL WA; WA
+12A8; KA; V
+12A9; KU; U
+12AA; KI; I
+12AB; KAA; A
+12AC; KEE; E
+12AD; KE; C
+12AE; KO; O
+12B0; KWA; WV
+12B2; KWI; WI
+12B3; KWAA; WA
+12B4; KWEE; WE
+12B5; KWE; WC
+12B8; KXA; V
+12B9; KXU; U
+12BA; KXI; I
+12BB; KXAA; A
+12BC; KXEE; E
+12BD; KXE; C
+12BE; KXO; O
+12C0; KXWA; WV
+12C2; KXWI; WI
+12C3; KXWAA; WA
+12C4; KXWEE; WE
+12C5; KXWE; WC
+12C8; WA; V
+12C9; WU; U
+12CA; WI; I
+12CB; WAA; A
+12CC; WEE; E
+12CD; WE; C
+12CE; WO; O
+12D0; PHARYNGEAL A; V
+12D1; PHARYNGEAL U; U
+12D2; PHARYNGEAL I; I
+12D3; PHARYNGEAL AA; A
+12D4; PHARYNGEAL EE; E
+12D5; PHARYNGEAL E; C
+12D6; PHARYNGEAL O; O
+12D8; ZA; V
+12D9; ZU; U
+12DA; ZI; I
+12DB; ZAA; A
+12DC; ZEE; E
+12DD; ZE; C
+12DE; ZO; O
+12DF; ZWA; WA
+12E0; ZHA; V
+12E1; ZHU; U
+12E2; ZHI; I
+12E3; ZHAA; A
+12E4; ZHEE; E
+12E5; ZHE; C
+12E6; ZHO; O
+12E7; ZHWA; WA
+12E8; YA; V
+12E9; YU; U
+12EA; YI; I
+12EB; YAA; A
+12EC; YEE; E
+12ED; YE; C
+12EE; YO; O
+12F0; DA; V
+12F1; DU; U
+12F2; DI; I
+12F3; DAA; A
+12F4; DEE; E
+12F5; DE; C
+12F6; DO; O
+12F7; DWA; WA
+12F8; DDA; V
+12F9; DDU; U
+12FA; DDI; I
+12FB; DDAA; A
+12FC; DDEE; E
+12FD; DDE; C
+12FE; DDO; O
+12FF; DDWA; WA
+1300; JA; V
+1301; JU; U
+1302; JI; I
+1303; JAA; A
+1304; JEE; E
+1305; JE; C
+1306; JO; O
+1307; JWA; WA
+1308; GA; V
+1309; GU; U
+130A; GI; I
+130B; GAA; A
+130C; GEE; E
+130D; GE; C
+130E; GO; O
+1310; GWA; WV
+1312; GWI; WI
+1313; GWAA; WA
+1314; GWEE; WE
+1315; GWE; WC
+1318; GGA; V
+1319; GGU; U
+131A; GGI; I
+131B; GGAA; A
+131C; GGEE; E
+131D; GGE; C
+131E; GGO; O
+1320; THA; V
+1321; THU; U
+1322; THI; I
+1323; THAA; A
+1324; THEE; E
+1325; THE; C
+1326; THO; O
+1327; THWA; WA
+1328; CHA; V
+1329; CHU; U
+132A; CHI; I
+132B; CHAA; A
+132C; CHEE; E
+132D; CHE; C
+132E; CHO; O
+132F; CHWA; WA
+1330; PHA; V
+1331; PHU; U
+1332; PHI; I
+1333; PHAA; A
+1334; PHEE; E
+1335; PHE; C
+1336; PHO; O
+1337; PHWA; WA
+1338; TSA; V
+1339; TSU; U
+133A; TSI; I
+133B; TSAA; A
+133C; TSEE; E
+133D; TSE; C
+133E; TSO; O
+133F; TSWA; WA
+1340; TZA; V
+1341; TZU; U
+1342; TZI; I
+1343; TZAA; A
+1344; TZEE; E
+1345; TZE; C
+1346; TZO; O
+1348; FA; V
+1349; FU; U
+134A; FI; I
+134B; FAA; A
+134C; FEE; E
+134D; FE; C
+134E; FO; O
+134F; FWA; WA
+1350; PA; V
+1351; PU; U
+1352; PI; I
+1353; PAA; A
+1354; PEE; E
+1355; PE; C
+1356; PO; O
+1357; PWA; WA
+#
+# Cherokee
+#
+13A0; A; A
+13A1; E; E
+13A2; I; I
+13A3; O; O
+13A4; U; U
+13A5; V; V
+13A6; GA; A 
+13A7; KA; A 
+13A8; GE; E
+13A9; GI; I
+13AA; GO; O
+13AB; GU; U
+13AC; GV; V
+13AD; HA; A
+13AE; HE; E
+13AF; HI; I
+13B0; HO; O
+13B1; HU; U
+13B2; HV; V
+13B3; LA; A
+13B4; LE; E
+13B5; LI; I
+13B6; LO; O
+13B7; LU; U
+13B8; LV; V
+13B9; MA; A
+13BA; ME; E
+13BB; MI; I
+13BC; MO; O
+13BD; MU; U
+13BE; NA; A
+13BF; HNA; A
+13C0; NAH; C
+13C1; NE; E
+13C2; NI; I
+13C3; NO; O
+13C4; NU; U
+13C5; NV; V
+13C6; QUA; A
+13C7; QUE; E
+13C8; QUI; I
+13C9; QUO; O
+13CA; QUU; U
+13CB; QUV; V
+13CC; SA; A
+13CD; S; C
+13CE; SE; E
+13CF; SI; I
+13D0; SO; O
+13D1; SU; U
+13D2; SV; V
+13D3; DA; A
+13D4; TA; A
+13D5; DE; E
+13D6; TE; E
+13D7; DI; I
+13D8; TI; I
+13D9; DO; O
+13DA; DU; U
+13DB; DV; V
+13DC; DLA; A
+13DD; TLA; A
+13DE; TLE; E
+13DF; TLI; I
+13E0; TLO; O
+13E1; TLU; U
+13E2; TLV; V
+13E3; TSA; A
+13E4; TSE; E
+13E5; TSI; I
+13E6; TSO; O
+13E7; TSU; U
+13E8; TSV; V
+13E9; WA; A
+13EA; WE; E
+13EB; WI; I
+13EC; WO; O
+13ED; WU; U
+13EE; WV; V
+13EF; YA; A
+13F0; YE; E
+13F1; YI; I
+13F2; YO; O
+13F3; YU; U
+13F4; YV; V
+#
+#      1400    Unified Canadian Aboriginal Syllabics   167F
+#
+1401; E; E
+1402; AAI; AAI
+1403; I; I
+1404; II; II
+1405; O; O
+1406; OO; OO
+1407; Y-CREE OO; OO
+1408; CARRIER EE; EE
+1409; CARRIER I; I
+140A; A; A
+140B; AA; AA
+140C; WE; WE
+140D; WEST-CREE WE; WE
+140E; WI; WI
+140F; WEST-CREE WI; WI
+1410; WII; WII
+1411; WEST-CREE WII; WII
+1412; WO; WO
+1413; WEST-CREE WO; WO
+1414; WOO; WOO
+1415; WEST-CREE WOO; WOO
+1416; NASKAPI WOO; WOO
+1417; WA; WA
+1418; WEST-CREE WA; WA
+1419; WAA; WAA
+141A; WEST-CREE WAA; WAA
+141B; NASKAPI WAA; WAA
+141C; AI; AI
+141D; Y-CREE W; C
+142B; EN; C
+142C; IN; C
+142D; ON; C
+142E; AN; C
+142F; PE; E
+1430; PAAI; AAI
+1431; PI; I
+1432; PII; II
+1433; PO; O
+1434; POO; OO
+1435; Y-CREE POO; OO
+1436; CARRIER HEE; EE
+1437; CARRIER HI; I
+1438; PA; A
+1439; PAA; AA
+143A; PWE; WE
+143B; WEST-CREE PWE; WE
+143C; PWI; WI
+143D; WEST-CREE PWI; WI
+143E; PWII; WII
+143F; WEST-CREE PWII; WII
+1440; PWO; WO
+1441; WEST-CREE PWO; WO
+1442; PWOO; WOO
+1443; WEST-CREE PWOO; WOO
+1444; PWA; WA
+1445; WEST-CREE PWA; WA
+1446; PWAA; WAA
+1447; WEST-CREE PWAA; WAA
+1448; Y-CREE PWAA; WAA
+1449; P; C
+144A; WEST-CREE P; C
+144B; CARRIER H; C
+144C; TE; E
+144D; TAAI; AAI
+144E; TI; I
+144F; TII; II
+1450; TO; O
+1451; TOO; OO
+1452; Y-CREE TOO; OO
+1453; CARRIER DEE; EE
+1454; CARRIER DI; I
+1455; TA; A
+1456; TAA; AA
+1457; TWE; WE
+1458; WEST-CREE TWE; WE
+1459; TWI; WI
+145A; WEST-CREE TWI; WI
+145B; TWII; WII
+145C; WEST-CREE TWII; WII
+145D; TWO; WO
+145E; WEST-CREE TWO; WO
+145F; TWOO; WOO
+1460; WEST-CREE TWOO; WOO
+1461; TWA; WA
+1462; WEST-CREE TWA; WA
+1463; TWAA; WAA
+1464; WEST-CREE TWAA; WAA
+1465; NASKAPI TWAA; WAA
+1466; T; C 
+1467; TTE; E 
+1468; TTI; I
+1469; TTO; O
+146A; TTA; A
+146B; KE; E
+146C; KAAI; AAI
+146D; KI; I
+146E; KII; II
+146F; KO; O
+1470; KOO; OO
+1471; Y-CREE KOO; OO
+1472; KA; A
+1473; KAA; AA
+1474; KWE; WE
+1475; WEST-CREE KWE; WE
+1476; KWI; WI
+1477; WEST-CREE KWI; WI
+1478; KWII; WII
+1479; WEST-CREE KWII; WII
+147A; KWO; WO
+147B; WEST-CREE KWO; WO
+147C; KWOO; WOO
+147D; WEST-CREE KWOO; WOO
+147E; KWA; WA
+147F; WEST-CREE KWA; WA
+1480; KWAA; WAA
+1481; WEST-CREE KWAA; WAA
+1482; NASKAPI KWAA; WAA
+1483; K; C
+1484; KW; WC
+1485; SOUTH-SLAVEY KEH; C
+1486; SOUTH-SLAVEY KIH; C
+1487; SOUTH-SLAVEY KOH; C
+1488; SOUTH-SLAVEY KAH; C
+1489; CE; E
+148A; CAAI; AAI
+148B; CI; I
+148C; CII; II
+148D; CO; O
+148E; COO; OO
+148F; Y-CREE COO; OO
+1490; CA; A
+1491; CAA; AA
+1492; CWE; WE
+1493; WEST-CREE CWE; WE
+1494; CWI; WI
+1495; WEST-CREE CWI; WI
+1496; CWII; WII
+1497; WEST-CREE CWII; WII
+1498; CWO; WO
+1499; WEST-CREE CWO; WO
+149A; CWOO; WOO
+149B; WEST-CREE CWOO; WOO
+149C; CWA; WA
+149D; WEST-CREE CWA; WA
+149E; CWAA; WAA
+149F; WEST-CREE CWAA; WAA
+14A0; NASKAPI CWAA; WAA
+14A1; C; C
+14A2; SAYISI TH; 
+14A3; ME; E
+14A4; MAAI; AAI
+14A5; MI; I
+14A6; MII; II
+14A7; MO; O
+14A8; MOO; OO
+14A9; Y-CREE MOO; OO
+14AA; MA; A
+14AB; MAA; AA
+14AC; MWE; WE
+14AD; WEST-CREE MWE; WE
+14AE; MWI; WI
+14AF; WEST-CREE MWI; WI
+14B0; MWII; WII
+14B1; WEST-CREE MWII; WII
+14B2; MWO; WO
+14B3; WEST-CREE MWO; WO
+14B4; MWOO; WOO
+14B5; WEST-CREE MWOO; WOO
+14B6; MWA; WA
+14B7; WEST-CREE MWA; WA
+14B8; MWAA; WAA
+14B9; WEST-CREE MWAA; WAA
+14BA; NASKAPI MWAA; WAA
+14BB; M; C
+14BC; WEST-CREE M; C
+14BD; MH; C
+14BE; ATHAPASCAN M; C
+14BF; SAYISI M; C
+14C0; NE; E
+14C1; NAAI; AAI
+14C2; NI; I
+14C3; NII; II
+14C4; NO; O
+14C5; NOO; OO
+14C6; Y-CREE NOO; OO
+14C7; NA; A
+14C8; NAA; AA
+14C9; NWE; WE
+14CA; WEST-CREE NWE; WE
+14CB; NWA; WA
+14CC; WEST-CREE NWA; WA
+14CD; NWAA; WAA
+14CE; WEST-CREE NWAA; WAA
+14CF; NASKAPI NWAA; WAA
+14D0; N; C
+14D1; CARRIER NG; C
+14D2; NH; C
+14D3; LE; E
+14D4; LAAI; AAI
+14D5; LI; I
+14D6; LII; II
+14D7; LO; O
+14D8; LOO; OO
+14D9; Y-CREE LOO; OO
+14DA; LA; A
+14DB; LAA; AA
+14DC; LWE; WE
+14DD; WEST-CREE LWE; WE
+14DE; LWI; WI
+14DF; WEST-CREE LWI; WI
+14E0; LWII; WII
+14E1; WEST-CREE LWII; WII
+14E2; LWO; WO
+14E3; WEST-CREE LWO; WO
+14E4; LWOO; WOO
+14E5; WEST-CREE LWOO; WOO
+14E6; LWA; WA
+14E7; WEST-CREE LWA; WA
+14E8; LWAA; WAA
+14E9; WEST-CREE LWAA; WAA
+14EA; L; C
+14EB; WEST-CREE L; C
+14EC; MEDIAL L; C
+14ED; SE; E
+14EE; SAAI; AAI
+14EF; SI; I
+14F0; SII; II
+14F1; SO; O
+14F2; SOO; OO
+14F3; Y-CREE SOO; OO
+14F4; SA; A
+14F5; SAA; AA
+14F6; SWE; WE
+14F7; WEST-CREE SWE; WE
+14F8; SWI; WI
+14F9; WEST-CREE SWI; WI
+14FA; SWII; WII
+14FB; WEST-CREE SWII; WII
+14FC; SWO; WO
+14FD; WEST-CREE SWO; WO
+14FE; SWOO; WOO
+14FF; WEST-CREE SWOO; WOO
+1500; SWA; WA
+1501; WEST-CREE SWA; WA
+1502; SWAA; WAA
+1503; WEST-CREE SWAA; WAA
+1504; NASKAPI SWAA; WAA
+1505; S; C
+1506; ATHAPASCAN S; C
+1507; SW; WC
+1508; BLACKFOOT S; C
+1509; MOOSE-CREE SK;C 
+150A; NASKAPI SKW; C
+150B; NASKAPI S-W; C
+150C; NASKAPI SPWA; WA
+150D; NASKAPI STWA; WA
+150E; NASKAPI SKWA; WA
+150F; NASKAPI SCWA; WA
+1510; SHE; E
+1511; SHI; I
+1512; SHII; II
+1513; SHO; O
+1514; SHOO; OO
+1515; SHA; A
+1516; SHAA; AA
+1517; SHWE; WE
+1518; WEST-CREE SHWE; WE
+1519; SHWI; WI
+151A; WEST-CREE SHWI; WI
+151B; SHWII; WII
+151C; WEST-CREE SHWII; WII
+151D; SHWO; WO
+151E; WEST-CREE SHWO; WO
+151F; SHWOO; WOO
+1520; WEST-CREE SHWOO; WOO
+1521; SHWA; WA
+1522; WEST-CREE SHWA; WA
+1523; SHWAA; WAA
+1524; WEST-CREE SHWAA; WAA
+1525; SH; C
+1526; YE; E
+1527; YAAI; AAI
+1528; YI; I
+1529; YII; II
+152A; YO; O
+152B; YOO; OO
+152C; Y-CREE YOO; OO
+152D; YA; A
+152E; YAA; AA
+152F; YWE; WE
+1530; WEST-CREE YWE; WE
+1531; YWI; WI
+1532; WEST-CREE YWI; WI
+1533; YWII; WII
+1534; WEST-CREE YWII; WII
+1535; YWO; WO
+1536; WEST-CREE YWO; WO
+1537; YWOO; WOO
+1538; WEST-CREE YWOO; WOO
+1539; YWA; WA
+153A; WEST-CREE YWA; WA
+153B; YWAA; WAA
+153C; WEST-CREE YWAA; WAA
+153D; NASKAPI YWAA; WAA
+153E; Y; C
+153F; BIBLE-CREE Y; C
+1540; WEST-CREE Y; C
+1541; SAYISI YI; I
+1542; RE; E
+1543; R-CREE RE; E
+1544; WEST-CREE LE; E
+1545; RAAI; AAI
+1546; RI; I
+1547; RII; II
+1548; RO; O
+1549; ROO; OO
+154A; WEST-CREE LO; O
+154B; RA; A
+154C; RAA; AA
+154D; WEST-CREE LA; A
+154E; RWAA; WAA
+154F; WEST-CREE RWAA; WAA
+1550; R; C
+1551; WEST-CREE R; C
+1552; MEDIAL R; C
+1553; FE; E
+1554; FAAI; AAI
+1555; FI; I
+1556; FII; II
+1557; FO; O
+1558; FOO; OO
+1559; FA; A
+155A; FAA; AA
+155B; FWAA; WAA
+155C; WEST-CREE FWAA; WAA
+155D; F; C
+155E; THE; E
+155F; N-CREE THE; E
+1560; THI; I
+1561; N-CREE THI; I
+1562; THII; II
+1563; N-CREE THII; II
+1564; THO; O
+1565; THOO; OO
+1566; THA; A
+1567; THAA; AA
+1568; THWAA; WAA
+1569; WEST-CREE THWAA; WAA
+156A; TH; C
+156B; TTHE; E
+156C; TTHI; I
+156D; TTHO; O
+156E; TTHA; A
+156F; TTH; C
+1570; TYE; E
+1571; TYI; I
+1572; TYO; O
+1573; TYA; A
+1574; NUNAVIK HE; E
+1575; NUNAVIK HI; I
+1576; NUNAVIK HII; II
+1577; NUNAVIK HO; O
+1578; NUNAVIK HOO; OO
+1579; NUNAVIK HA; A
+157A; NUNAVIK HAA; AA
+157B; NUNAVIK H; C
+157C; NUNAVUT H; C
+157D; HK; C
+157E; QAAI; AAI
+157F; QI; I
+1580; QII; II
+1581; QO; O
+1582; QOO; OO
+1583; QA; A
+1584; QAA; AA
+1585; Q; C
+1586; TLHE; E
+1587; TLHI; I
+1588; TLHO; O
+1589; TLHA; A
+158A; WEST-CREE RE; E
+158B; WEST-CREE RI; I
+158C; WEST-CREE RO; O
+158D; WEST-CREE RA; A
+158E; NGAAI; AAI
+158F; NGI; I
+1590; NGII; II
+1591; NGO; O
+1592; NGOO; OO
+1593; NGA; A
+1594; NGAA; AA
+1595; NG; C
+1596; NNG; C
+1597; SAYISI SHE; E
+1598; SAYISI SHI; I
+1599; SAYISI SHO; O
+159A; SAYISI SHA; A
+159B; WOODS-CREE THE; E
+159C; WOODS-CREE THI; I
+159D; WOODS-CREE THO; O
+159E; WOODS-CREE THA; A
+159F; WOODS-CREE TH; C
+15A0; LHI; I
+15A1; LHII; II
+15A2; LHO; O
+15A3; LHOO; OO
+15A4; LHA; A
+15A5; LHAA; AA
+15A6; LH; C
+15A7; TH-CREE THE; E
+15A8; TH-CREE THI; I
+15A9; TH-CREE THII; II
+15AA; TH-CREE THO; O
+15AB; TH-CREE THOO; OO
+15AC; TH-CREE THA; A
+15AD; TH-CREE THAA; AA
+15AE; TH-CREE TH; C
+15AF; AIVILIK B; C
+15B0; BLACKFOOT E; E
+15B1; BLACKFOOT I; I
+15B2; BLACKFOOT O; O
+15B3; BLACKFOOT A; A
+15B4; BLACKFOOT WE; E
+15B5; BLACKFOOT WI; I
+15B6; BLACKFOOT WO; O
+15B7; BLACKFOOT WA; A
+15B8; BLACKFOOT NE; E
+15B9; BLACKFOOT NI; I
+15BA; BLACKFOOT NO; O
+15BB; BLACKFOOT NA; A
+15BC; BLACKFOOT KE; E
+15BD; BLACKFOOT KI; I
+15BE; BLACKFOOT KO; O
+15BF; BLACKFOOT KA; A
+15C0; SAYISI HE; E
+15C1; SAYISI HI; I
+15C2; SAYISI HO; O
+15C3; SAYISI HA; A
+15C4; CARRIER GHU; U
+15C5; CARRIER GHO; O
+15C6; CARRIER GHE; E
+15C7; CARRIER GHEE; EE
+15C8; CARRIER GHI; I
+15C9; CARRIER GHA; A
+15CA; CARRIER RU; U
+15CB; CARRIER RO; O
+15CC; CARRIER RE; E
+15CD; CARRIER REE; EE
+15CE; CARRIER RI; I
+15CF; CARRIER RA; A
+15D0; CARRIER WU; U
+15D1; CARRIER WO; O
+15D2; CARRIER WE; E
+15D3; CARRIER WEE; EE
+15D4; CARRIER WI; I
+15D5; CARRIER WA; A
+15D6; CARRIER HWU; WU
+15D7; CARRIER HWO; WO
+15D8; CARRIER HWE; WE
+15D9; CARRIER HWEE; WEE
+15DA; CARRIER HWI; WI
+15DB; CARRIER HWA; WA
+15DC; CARRIER THU; U
+15DD; CARRIER THO; O
+15DE; CARRIER THE; E
+15DF; CARRIER THEE; EE
+15E0; CARRIER THI; I
+15E1; CARRIER THA; A
+15E2; CARRIER TTU; U
+15E3; CARRIER TTO; O
+15E4; CARRIER TTE; E
+15E5; CARRIER TTEE; EE
+15E6; CARRIER TTI; I
+15E7; CARRIER TTA; A
+15E8; CARRIER PU; U
+15E9; CARRIER PO; O
+15EA; CARRIER PE; E
+15EB; CARRIER PEE; EE
+15EC; CARRIER PI; I
+15ED; CARRIER PA; A
+15EE; CARRIER P; 
+15EF; CARRIER GU; U
+15F0; CARRIER GO; O
+15F1; CARRIER GE; E
+15F2; CARRIER GEE; EE
+15F3; CARRIER GI; I
+15F4; CARRIER GA; A
+15F5; CARRIER KHU; U
+15F6; CARRIER KHO; O
+15F7; CARRIER KHE; E
+15F8; CARRIER KHEE; EE
+15F9; CARRIER KHI; I
+15FA; CARRIER KHA; A
+15FB; CARRIER KKU; U
+15FC; CARRIER KKO; O
+15FD; CARRIER KKE; E
+15FE; CARRIER KKEE; EE
+15FF; CARRIER KKI; I
+1600; CARRIER KKA; A
+1601; CARRIER KK; 
+1602; CARRIER NU; U
+1603; CARRIER NO; O
+1604; CARRIER NE; E
+1605; CARRIER NEE; EE
+1606; CARRIER NI; I
+1607; CARRIER NA; A
+1608; CARRIER MU; U
+1609; CARRIER MO; O
+160A; CARRIER ME; E
+160B; CARRIER MEE; EE
+160C; CARRIER MI; I
+160D; CARRIER MA; A
+160E; CARRIER YU; U
+160F; CARRIER YO; O
+1610; CARRIER YE; E
+1611; CARRIER YEE; EE
+1612; CARRIER YI; I
+1613; CARRIER YA; A
+1614; CARRIER JU; U
+1615; SAYISI JU; U
+1616; CARRIER JO; O
+1617; CARRIER JE; E
+1618; CARRIER JEE; EE
+1619; CARRIER JI; I
+161A; SAYISI JI; I
+161B; CARRIER JA; A
+161C; CARRIER JJU; U
+161D; CARRIER JJO; O
+161E; CARRIER JJE; E
+161F; CARRIER JJEE; EE
+1620; CARRIER JJI; I
+1621; CARRIER JJA; A
+1622; CARRIER LU; U
+1623; CARRIER LO; O
+1624; CARRIER LE; E
+1625; CARRIER LEE; EE
+1626; CARRIER LI; I
+1627; CARRIER LA; A
+1628; CARRIER DLU; U
+1629; CARRIER DLO; O
+162A; CARRIER DLE; E
+162B; CARRIER DLEE; EE
+162C; CARRIER DLI; I
+162D; CARRIER DLA; A
+162E; CARRIER LHU; U
+162F; CARRIER LHO; O
+1630; CARRIER LHE; E
+1631; CARRIER LHEE; EE
+1632; CARRIER LHI; I
+1633; CARRIER LHA; A
+1634; CARRIER TLHU; U
+1635; CARRIER TLHO; O
+1636; CARRIER TLHE; E
+1637; CARRIER TLHEE; EE
+1638; CARRIER TLHI; I
+1639; CARRIER TLHA; A
+163A; CARRIER TLU; U
+163B; CARRIER TLO; O
+163C; CARRIER TLE; E
+163D; CARRIER TLEE; EE
+163E; CARRIER TLI; I
+163F; CARRIER TLA; A
+1640; CARRIER ZU; U
+1641; CARRIER ZO; O
+1642; CARRIER ZE; E
+1643; CARRIER ZEE; EE
+1644; CARRIER ZI; I
+1645; CARRIER ZA; A
+1646; CARRIER Z; 
+1647; CARRIER INITIAL Z; 
+1648; CARRIER DZU; U
+1649; CARRIER DZO; O
+164A; CARRIER DZE; E
+164B; CARRIER DZEE; EE
+164C; CARRIER DZI; I
+164D; CARRIER DZA; A
+164E; CARRIER SU; U
+164F; CARRIER SO; O
+1650; CARRIER SE; E
+1651; CARRIER SEE; EE
+1652; CARRIER SI; I
+1653; CARRIER SA; A
+1654; CARRIER SHU; U
+1655; CARRIER SHO; O
+1656; CARRIER SHE; E
+1657; CARRIER SHEE; EE
+1658; CARRIER SHI; I
+1659; CARRIER SHA; A
+165A; CARRIER SH; 
+165B; CARRIER TSU; U
+165C; CARRIER TSO; O
+165D; CARRIER TSE; E
+165E; CARRIER TSEE; EE
+165F; CARRIER TSI; I
+1660; CARRIER TSA; A
+1661; CARRIER CHU; U
+1662; CARRIER CHO; O
+1663; CARRIER CHE; E
+1664; CARRIER CHEE; EE
+1665; CARRIER CHI; I
+1666; CARRIER CHA; A
+1667; CARRIER TTSU; U
+1668; CARRIER TTSO; O
+1669; CARRIER TTSE; E
+166A; CARRIER TTSEE; EE
+166B; CARRIER TTSI; I
+166C; CARRIER TTSA; A
+166F; QAI; AI
+1670; NGAI; AI
+1671; NNGI; I
+1672; NNGII; II
+1673; NNGO; O
+1674; NNGOO; OO
+1675; NNGA; A
+1676; NNGAA; AA
+#
+# Katakana
+#
+30A1; SMALL A; A
+30A2; A; A
+30A3; SMALL I; I
+30A4; I; I
+30A5; SMALL U; U
+30A6; U; U
+30A7; SMALL E; E
+30A8; E; E
+30A9; SMALL O; O
+30AA; O; O
+30AB; KA; A
+30AC; GA; A
+30AD; KI; I
+30AE; GI; I
+30AF; KU; U
+30B0; GU; U
+30B1; KE; E
+30B2; GE; E
+30B3; KO; O
+30B4; GO; O
+30B5; SA; A
+30B6; ZA; A
+30B7; SI; I
+30B8; ZI; I
+30B9; SU; U
+30BA; ZU; U
+30BB; SE; E
+30BC; ZE; E
+30BD; SO; O
+30BE; ZO; O
+30BF; TA; A
+30C0; DA; A
+30C1; TI; I
+30C2; DI; I
+30C3; SMALL TU; U
+30C4; TU; U
+30C5; DU; U
+30C6; TE; E
+30C7; DE; E
+30C8; TO; O
+30C9; DO; O
+30CA; NA; A
+30CB; NI; I
+30CC; NU; U
+30CD; NE; E
+30CE; NO; O
+30CF; HA; A
+30D0; BA; A
+30D1; PA; A
+30D2; HI; I
+30D3; BI; I
+30D4; PI; I
+30D5; HU; U
+30D6; BU; U
+30D7; PU; U
+30D8; HE; E
+30D9; BE; E
+30DA; PE; E
+30DB; HO; O
+30DC; BO; O
+30DD; PO; O
+30DE; MA; A
+30DF; MI; I
+30E0; MU; U
+30E1; ME; E
+30E2; MO; O
+30E3; SMALL YA; A
+30E4; YA; A
+30E5; SMALL YU; U
+30E6; YU; U
+30E7; SMALL YO; O
+30E8; YO; O
+30E9; RA; A
+30EA; RI; I
+30EB; RU; U
+30EC; RE; E
+30ED; RO; O
+30EE; SMALL WA; A
+30EF; WA; A
+30F0; WI; I
+30F1; WE; E
+30F2; WO; O
+30F3; N; C
+30F4; VU; U
+30F5; SMALL KA; A
+30F6; SMALL KE; E
+30F7; VA; A
+30F8; VI; I
+30F9; VE; E
+30FA; VO; O
+32D0; CIRCLED KATAKANA A; A
+32D1; CIRCLED KATAKANA I; I
+32D2; CIRCLED KATAKANA U; U
+32D3; CIRCLED KATAKANA E; E
+32D4; CIRCLED KATAKANA O; O
+32D5; CIRCLED KATAKANA KA; A
+32D6; CIRCLED KATAKANA KI; I
+32D7; CIRCLED KATAKANA KU; U
+32D8; CIRCLED KATAKANA KE; E
+32D9; CIRCLED KATAKANA KO; O
+32DA; CIRCLED KATAKANA SA; A
+32DB; CIRCLED KATAKANA SI; I
+32DC; CIRCLED KATAKANA SU; U
+32DD; CIRCLED KATAKANA SE; E
+32DE; CIRCLED KATAKANA SO; O
+32DF; CIRCLED KATAKANA TA; A
+32E0; CIRCLED KATAKANA TI; I
+32E1; CIRCLED KATAKANA TU; U
+32E2; CIRCLED KATAKANA TE; E
+32E3; CIRCLED KATAKANA TO; O
+32E4; CIRCLED KATAKANA NA; A
+32E5; CIRCLED KATAKANA NI; I
+32E6; CIRCLED KATAKANA NU; U
+32E7; CIRCLED KATAKANA NE; E
+32E8; CIRCLED KATAKANA NO; O
+32E9; CIRCLED KATAKANA HA; A
+32EA; CIRCLED KATAKANA HI; I
+32EB; CIRCLED KATAKANA HU; U
+32EC; CIRCLED KATAKANA HE; E
+32ED; CIRCLED KATAKANA HO; O
+32EE; CIRCLED KATAKANA MA; A
+32EF; CIRCLED KATAKANA MI; I
+32F0; CIRCLED KATAKANA MU; U
+32F1; CIRCLED KATAKANA ME; E
+32F2; CIRCLED KATAKANA MO; O
+32F3; CIRCLED KATAKANA YA; A
+32F4; CIRCLED KATAKANA YU; U
+32F5; CIRCLED KATAKANA YO; O
+32F6; CIRCLED KATAKANA RA; A
+32F7; CIRCLED KATAKANA RI; I
+32F8; CIRCLED KATAKANA RU; U
+32F9; CIRCLED KATAKANA RE; E
+32FA; CIRCLED KATAKANA RO; O
+32FB; CIRCLED KATAKANA WA; A
+32FC; CIRCLED KATAKANA WI; I
+32FD; CIRCLED KATAKANA WE; E
+32FE; CIRCLED KATAKANA WO; O
+#
+# Katakana
+#
+FF66; HALFWIDTH WO; O
+FF67; HALFWIDTH SMALL A; A
+FF68; HALFWIDTH SMALL I; I
+FF69; HALFWIDTH SMALL U; U
+FF6A; HALFWIDTH SMALL E; E
+FF6B; HALFWIDTH SMALL O; O
+FF6C; HALFWIDTH SMALL YA; A
+FF6D; HALFWIDTH SMALL YU; U
+FF6E; HALFWIDTH SMALL YO; O
+FF6F; HALFWIDTH SMALL TU; U
+FF71; HALFWIDTH A; A
+FF72; HALFWIDTH I; I
+FF73; HALFWIDTH U; U
+FF74; HALFWIDTH E; E
+FF75; HALFWIDTH O; O
+FF76; HALFWIDTH KA; A
+FF77; HALFWIDTH KI; I
+FF78; HALFWIDTH KU; U
+FF79; HALFWIDTH KE; E
+FF7A; HALFWIDTH KO; O
+FF7B; HALFWIDTH SA; A
+FF7C; HALFWIDTH SI; I
+FF7D; HALFWIDTH SU; U
+FF7E; HALFWIDTH SE; E
+FF7F; HALFWIDTH SO; O
+FF80; HALFWIDTH TA; A
+FF81; HALFWIDTH TI; I
+FF82; HALFWIDTH TU; U
+FF83; HALFWIDTH TE; E
+FF84; HALFWIDTH TO; O
+FF85; HALFWIDTH NA; A
+FF86; HALFWIDTH NI; I
+FF87; HALFWIDTH NU; U
+FF88; HALFWIDTH NE; E
+FF89; HALFWIDTH NO; O
+FF8A; HALFWIDTH HA; A
+FF8B; HALFWIDTH HI; I
+FF8C; HALFWIDTH HU; U
+FF8D; HALFWIDTH HE; E
+FF8E; HALFWIDTH HO; O
+FF8F; HALFWIDTH MA; A
+FF90; HALFWIDTH MI; I
+FF91; HALFWIDTH MU; U
+FF92; HALFWIDTH ME; E
+FF93; HALFWIDTH MO; O
+FF94; HALFWIDTH YA; A
+FF95; HALFWIDTH YU; U
+FF96; HALFWIDTH YO; O
+FF97; HALFWIDTH RA; A
+FF98; HALFWIDTH RI; I
+FF99; HALFWIDTH RU; U
+FF9A; HALFWIDTH RE; E
+FF9B; HALFWIDTH RO; O
+FF9C; HALFWIDTH WA; A
+FF9D; HALFWIDTH N; C
+#
+# Hiragana
+#
+3041; SMALL A; A
+3042; A; A
+3043; SMALL I; I
+3044; I; I
+3045; SMALL U; U
+3046; U; U
+3047; SMALL E; E
+3048; E; E
+3049; SMALL O; O
+304A; O; O
+304B; KA; A
+304C; GA; A
+304D; KI; I
+304E; GI; I
+304F; KU; U
+3050; GU; U
+3051; KE; E
+3052; GE; E
+3053; KO; O
+3054; GO; O
+3055; SA; A
+3056; ZA; A
+3057; SI; I
+3058; ZI; I
+3059; SU; U
+305A; ZU; U
+305B; SE; E
+305C; ZE; E
+305D; SO; O
+305E; ZO; O
+305F; TA; A
+3060; DA; A
+3061; TI; I
+3062; DI; I
+3063; SMALL TU; U
+3064; TU; U
+3065; DU; U
+3066; TE; E
+3067; DE; E
+3068; TO; O
+3069; DO; O
+306A; NA; A
+306B; NI; I
+306C; NU; U
+306D; NE; E
+306E; NO; O
+306F; HA; A
+3070; BA; A
+3071; PA; A
+3072; HI; I
+3073; BI; I
+3074; PI; I
+3075; HU; U
+3076; BU; U
+3077; PU; U
+3078; HE; E
+3079; BE; E
+307A; PE; E
+307B; HO; O
+307C; BO; O
+307D; PO; O
+307E; MA; A
+307F; MI; I
+3080; MU; U
+3081; ME; E
+3082; MO; O
+3083; SMALL YA; A
+3084; YA; A
+3085; SMALL YU; U
+3086; YU; U
+3087; SMALL YO; O
+3088; YO; O
+3089; RA; A
+308A; RI; I
+308B; RU; U
+308C; RE; E
+308D; RO; O
+308E; SMALL WA; A
+308F; WA; A
+3090; WI; I
+3091; WE; E
+3092; WO; O
+3093; N; N
+3094; VU; U
index 6d6c0eb..f06b893 100644 (file)
@@ -4,6 +4,8 @@ if (ord('A') != 193) { # make things more pragmatic for EBCDIC folk
 
 $utf8::hint_bits = 0x00800000;
 
+our $VERSION = '1.00';
+
 sub import {
     $^H |= $utf8::hint_bits;
     $enc{caller()} = $_[1] if $_[1];
index 0ace551..d39f197 100644 (file)
@@ -2,6 +2,8 @@ package vars;
 
 require 5.002;
 
+our $VERSION = '1.00';
+
 # The following require can't be removed during maintenance
 # releases, sadly, because of the risk of buggy code that does
 # require Carp; Carp::croak "..."; without brackets dying
@@ -10,6 +12,7 @@ require 5.002;
 require Carp if $] < 5.00450;
 
 use warnings::register;
+require strict;
 
 sub import {
     my $callpack = caller;
@@ -26,6 +29,8 @@ sub import {
                Carp::croak("Can't declare individual elements of hash or array");
            } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
                warnings::warn("No need to declare built-in vars");
+            } elsif  ( $^H &= strict::bits('vars') ) {
+              Carp::croak("'$ch$sym' is not a valid variable name under strict vars");
            }
        }
         *{"${callpack}::$sym"} =
index 2517239..e341641 100644 (file)
@@ -5,6 +5,8 @@
 
 package warnings;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 warnings - Perl pragma to control optional warnings
@@ -39,7 +41,7 @@ warnings - Perl pragma to control optional warnings
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-A number of functions are provided to assist module authors. 
+A number of functions are provided to assist module authors.
 
 =over 4
 
@@ -295,7 +297,7 @@ sub bits {
            $mask |= $DeadBits{$word} if $fatal ;
        }
        else
-          { croak("unknown warnings category '$word'")}  
+          { croak("unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -341,13 +343,13 @@ sub __chk
            unless defined $offset;
     }
     else {
-        $category = (caller(1))[0] ; 
+        $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
         croak("package '$category' not registered for warnings")
            unless defined $offset ;
     }
 
-    my $this_pkg = (caller(1))[0] ; 
+    my $this_pkg = (caller(1))[0] ;
     my $i = 2 ;
     my $pkg ;
 
@@ -361,11 +363,11 @@ sub __chk
         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
             last if $pkg ne $this_pkg ;
         }
-        $i = 2 
+        $i = 2
             if !$pkg || $pkg eq $this_pkg ;
     }
 
-    my $callers_bitmask = (caller($i))[9] ; 
+    my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
@@ -390,7 +392,7 @@ sub warn
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
     carp($message) ;
@@ -405,12 +407,12 @@ sub warnif
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
 
-    return 
+    return
         unless defined $callers_bitmask &&
                (vec($callers_bitmask, $offset, 1) ||
                vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 
index f98075a..d40da36 100644 (file)
@@ -1,5 +1,7 @@
 package warnings::register ;
 
+our $VERSION = '1.00';
+
 =pod
 
 =head1 NAME
index a02a298..6a30fc6 100644 (file)
@@ -73,7 +73,8 @@ if ($PLATFORM eq 'aix') {
 }
 elsif ($PLATFORM eq 'win32') {
     $CCTYPE = "MSVC" unless defined $CCTYPE;
-    foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) {
+    foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym,
+               $pp_sym, $globvar_sym, $perlio_sym) {
        s!^!..\\!;
     }
 }
@@ -87,7 +88,7 @@ unless ($PLATFORM eq 'win32') {
        }
        if ($PLATFORM eq 'os2') {
            $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/;
-           $ARCHNAME = $1 if /^(?:archname)='(.+)'$/;
+           $ARCHNAME =    $1 if /^(?:archname)='(.+)'$/;
        }
     }
     close(CFG);
@@ -96,12 +97,9 @@ unless ($PLATFORM eq 'win32') {
 open(CFG,$config_h) || die "Cannot open $config_h: $!\n";
 while (<CFG>) {
     $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
-    $define{$1} = 1 if /^\s*#\s*define\s+(USE_5005THREADS)\b/;
-    $define{$1} = 1 if /^\s*#\s*define\s+(USE_ITHREADS)\b/;
-    $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/;
     $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/;
-    $define{$1} = 1 if /^\s*#\s*define\s+(PERL_IMPLICIT_SYS)\b/;
-    $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/;
+    $define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/;
+    $define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/;
 }
 close(CFG);
 
@@ -134,7 +132,7 @@ if ($define{PERL_OBJECT}) {
 
 if ($PLATFORM eq 'win32') {
     warn join(' ',keys %define)."\n";
-    print "LIBRARY Perl56\n";
+    print "LIBRARY Perl57\n";
     print "DESCRIPTION 'Perl interpreter'\n";
     print "EXPORTS\n";
     if ($define{PERL_IMPLICIT_SYS}) {
@@ -145,16 +143,7 @@ if ($PLATFORM eq 'win32') {
 elsif ($PLATFORM eq 'os2') {
     ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
     $v .= '-thread' if $ARCHNAME =~ /-thread/;
-    #$sum = 0;
-    #for (split //, $v) {
-    #  $sum = ($sum * 33) + ord;
-    #  $sum &= 0xffffff;
-    #}
-    #$sum += $sum >> 5;
-    #$sum &= 0xffff;
-    #$sum = printf '%X', $sum;
     ($dll = $define{PERL_DLL}) =~ s/\.dll$//i;
-    # print STDERR "'$dll' <= '$define{PERL_DLL}'\n";
     print <<"---EOP---";
 LIBRARY '$dll' INITINSTANCE TERMINSTANCE
 DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter'
@@ -314,7 +303,6 @@ elsif ($PLATFORM eq 'os2') {
 
 unless ($define{'DEBUGGING'}) {
     skip_symbols [qw(
-                   Perl_deb
                    Perl_deb_growlevel
                    Perl_debop
                    Perl_debprofdump
@@ -572,6 +560,8 @@ while (<DATA>) {
 
 if ($PLATFORM eq 'win32') {
     foreach my $symbol (qw(
+                           setuid
+                           setgid
                            boot_DynaLoader
                            Perl_init_os_extras
                            Perl_thread_create
@@ -579,35 +569,6 @@ if ($PLATFORM eq 'win32') {
                            RunPerl
                            win32_errno
                            win32_environ
-                           win32_stdin
-                           win32_stdout
-                           win32_stderr
-                           win32_ferror
-                           win32_feof
-                           win32_strerror
-                           win32_fprintf
-                           win32_printf
-                           win32_vfprintf
-                           win32_vprintf
-                           win32_fread
-                           win32_fwrite
-                           win32_fopen
-                           win32_fdopen
-                           win32_freopen
-                           win32_fclose
-                           win32_fputs
-                           win32_fputc
-                           win32_ungetc
-                           win32_getc
-                           win32_fileno
-                           win32_clearerr
-                           win32_fflush
-                           win32_ftell
-                           win32_fseek
-                           win32_fgetpos
-                           win32_fsetpos
-                           win32_rewind
-                           win32_tmpfile
                            win32_abort
                            win32_fstat
                            win32_stat
@@ -678,17 +639,6 @@ if ($PLATFORM eq 'win32') {
                            win32_getenv
                            win32_putenv
                            win32_perror
-                           win32_setbuf
-                           win32_setvbuf
-                           win32_flushall
-                           win32_fcloseall
-                           win32_fgets
-                           win32_gets
-                           win32_fgetc
-                           win32_putc
-                           win32_puts
-                           win32_getchar
-                           win32_putchar
                            win32_malloc
                            win32_calloc
                            win32_realloc
@@ -720,6 +670,47 @@ if ($PLATFORM eq 'win32') {
                            win32_getpid
                            win32_crypt
                            win32_dynaload
+
+                           win32_stdin
+                           win32_stdout
+                           win32_stderr
+                           win32_ferror
+                           win32_feof
+                           win32_strerror
+                           win32_fprintf
+                           win32_printf
+                           win32_vfprintf
+                           win32_vprintf
+                           win32_fread
+                           win32_fwrite
+                           win32_fopen
+                           win32_fdopen
+                           win32_freopen
+                           win32_fclose
+                           win32_fputs
+                           win32_fputc
+                           win32_ungetc
+                           win32_getc
+                           win32_fileno
+                           win32_clearerr
+                           win32_fflush
+                           win32_ftell
+                           win32_fseek
+                           win32_fgetpos
+                           win32_fsetpos
+                           win32_rewind
+                           win32_tmpfile
+                           win32_setbuf
+                           win32_setvbuf
+                           win32_flushall
+                           win32_fcloseall
+                           win32_fgets
+                           win32_gets
+                           win32_fgetc
+                           win32_putc
+                           win32_puts
+                           win32_getchar
+                           win32_putchar
                           ))
     {
        try_symbol($symbol);
@@ -797,3 +788,38 @@ perl_destruct
 perl_free
 perl_parse
 perl_run
+PerlIO_define_layer
+PerlIOBuf_set_ptrcnt
+PerlIOBuf_get_cnt
+PerlIOBuf_get_ptr
+PerlIOBuf_bufsiz
+PerlIOBuf_setlinebuf
+PerlIOBase_clearerr
+PerlIOBase_error
+PerlIOBase_eof
+PerlIOBuf_tell
+PerlIOBuf_seek
+PerlIOBuf_write
+PerlIOBuf_unread
+PerlIOBuf_read
+PerlIOBuf_reopen
+PerlIOBuf_open
+PerlIOBuf_fdopen
+PerlIOBase_fileno
+PerlIOBuf_pushed
+PerlIOBuf_fill
+PerlIOBuf_flush
+PerlIOBase_close
+PerlIO_define_layer
+PerlIO_pending
+PerlIO_unread
+PerlIO_push
+PerlIO_apply_layers
+perlsio_binmode
+PerlIO_binmode
+PerlIO_init
+PerlIO_tmpfile
+PerlIO_setpos
+PerlIO_getpos
+PerlIO_vsprintf
+PerlIO_sprintf
index 7584000..0f668cd 100644 (file)
--- a/malloc.c
+++ b/malloc.c
      # Fatal error reporting function
      croak(format, arg)                        warn(idem) + exit(1)
   
+     # Fatal error reporting function
+     croak2(format, arg1, arg2)                warn2(idem) + exit(1)
+  
      # Error reporting function
      warn(format, arg)                 fprintf(stderr, idem)
 
+     # Error reporting function
+     warn2(format, arg1, arg2)         fprintf(stderr, idem)
+
      # Locking/unlocking for MT operation
      MALLOC_LOCK                       MUTEX_LOCK(&PL_malloc_mutex)
      MALLOC_UNLOCK                     MUTEX_UNLOCK(&PL_malloc_mutex)
 #  include "perl.h"
 #  if defined(PERL_IMPLICIT_CONTEXT)
 #    define croak      Perl_croak_nocontext
+#    define croak2     Perl_croak_nocontext
 #    define warn       Perl_warn_nocontext
+#    define warn2      Perl_warn_nocontext
+#  else
+#    define croak2     croak
+#    define warn2      warn
 #  endif
 #else
 #  ifdef PERL_FOR_X2P
 #  ifndef croak                                /* make depend */
 #    define croak(mess, arg) (warn((mess), (arg)), exit(1))
 #  endif 
+#  ifndef croak2                       /* make depend */
+#    define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1))
+#  endif 
 #  ifndef warn
 #    define warn(mess, arg) fprintf(stderr, (mess), (arg))
 #  endif 
+#  ifndef warn2
+#    define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2))
+#  endif 
 #  ifdef DEBUG_m
 #    undef DEBUG_m
 #  endif 
@@ -441,6 +458,11 @@ union      overhead {
        double  strut;                  /* alignment problems */
 #endif
        struct {
+/*
+ * Keep the ovu_index and ovu_magic in this order, having a char
+ * field first gives alignment indigestion in some systems, such as
+ * MachTen.
+ */
                u_char  ovu_index;      /* bucket # */
                u_char  ovu_magic;      /* magic number */
 #ifdef RCHECK
@@ -838,11 +860,7 @@ static void*       get_from_bigger_buckets(int bucket, MEM_SIZE size);
 static union overhead *getpages        (MEM_SIZE needed, int *nblksp, int bucket);
 static int     getpages_adjacent(MEM_SIZE require);
 
-#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
-
-#  ifndef BIG_SIZE
-#    define BIG_SIZE (1<<16)           /* 64K */
-#  endif 
+#ifdef PERL_CORE
 
 #ifdef I_MACH_CTHREADS
 #  undef  MUTEX_LOCK
@@ -851,18 +869,66 @@ static int        getpages_adjacent(MEM_SIZE require);
 #  define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
 #endif
 
+#ifndef BITS_IN_PTR
+#  define BITS_IN_PTR (8*PTRSIZE)
+#endif
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^i.  The
+ * smallest allocatable block is 8 bytes.  The overhead information
+ * precedes the data area returned to the user.
+ */
+#define        NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
+static union overhead *nextf[NBUCKETS];
+
+#if defined(PURIFY) && !defined(USE_PERL_SBRK)
+#  define USE_PERL_SBRK
+#endif
+
+#ifdef USE_PERL_SBRK
+# define sbrk(a) Perl_sbrk(a)
+Malloc_t Perl_sbrk (int size);
+#else
+# ifndef HAS_SBRK_PROTO /* <unistd.h> usually takes care of this */
+extern Malloc_t sbrk(int);
+# endif
+#endif
+
+#ifdef DEBUGGING_MSTATS
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+static u_int nmalloc[NBUCKETS];
+static  u_int sbrk_slack;
+static  u_int start_slack;
+#else  /* !( defined DEBUGGING_MSTATS ) */
+#  define sbrk_slack   0
+#endif
+
+static u_int goodsbrk;
+
+# ifdef PERL_EMERGENCY_SBRK
+
+#  ifndef BIG_SIZE
+#    define BIG_SIZE (1<<16)           /* 64K */
+#  endif
+
 static char *emergency_buffer;
 static MEM_SIZE emergency_buffer_size;
+static int no_mem;     /* 0 if the last request for more memory succeeded.
+                          Otherwise the size of the failing request. */
 
 static Malloc_t
 emergency_sbrk(MEM_SIZE size)
 {
     MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
 
-    if (size >= BIG_SIZE) {
-       /* Give the possibility to recover: */
+    if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) {
+       /* Give the possibility to recover, but avoid an infinite cycle. */
        MALLOC_UNLOCK;
-       croak("Out of memory during \"large\" request for %i bytes", size);
+       no_mem = size;
+       croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
     }
 
     if (emergency_buffer_size >= rsize) {
@@ -910,55 +976,15 @@ emergency_sbrk(MEM_SIZE size)
     }
   do_croak:
     MALLOC_UNLOCK;
-    croak("Out of memory during request for %i bytes", size);
+    croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
     /* NOTREACHED */
     return Nullch;
 }
 
-#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
+# else /*  !defined(PERL_EMERGENCY_SBRK) */
 #  define emergency_sbrk(size) -1
-#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
-
-#ifndef BITS_IN_PTR
-#  define BITS_IN_PTR (8*PTRSIZE)
-#endif
-
-/*
- * nextf[i] is the pointer to the next free block of size 2^i.  The
- * smallest allocatable block is 8 bytes.  The overhead information
- * precedes the data area returned to the user.
- */
-#define        NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
-static union overhead *nextf[NBUCKETS];
-
-#if defined(PURIFY) && !defined(USE_PERL_SBRK)
-#  define USE_PERL_SBRK
-#endif
-
-#ifdef USE_PERL_SBRK
-#define sbrk(a) Perl_sbrk(a)
-Malloc_t Perl_sbrk (int size);
-#else 
-#ifdef DONT_DECLARE_STD
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-#else
-extern Malloc_t sbrk(int);
-#endif
-#endif
-
-#ifdef DEBUGGING_MSTATS
-/*
- * nmalloc[i] is the difference between the number of mallocs and frees
- * for a given block size.
- */
-static u_int nmalloc[NBUCKETS];
-static  u_int sbrk_slack;
-static  u_int start_slack;
-#endif
-
-static u_int goodsbrk;
+# endif
+#endif /* ifdef PERL_CORE */
 
 #ifdef DEBUGGING
 #undef ASSERT
@@ -1035,7 +1061,32 @@ Perl_malloc(register size_t nbytes)
                {
                    dTHX;
                    if (!PL_nomemok) {
-                       PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC)
+                       PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+#else
+                       char buff[80];
+                       char *eb = buff + sizeof(buff) - 1;
+                       char *s = eb;
+                       size_t n = nbytes;
+
+                       PerlIO_puts(PerlIO_stderr(),"Out of memory during request for ");
+#if defined(DEBUGGING) || defined(RCHECK)
+                       n = size;
+#endif
+                       *s = 0;                 
+                       do {
+                           *--s = '0' + (n % 10);
+                       } while (n /= 10);
+                       PerlIO_puts(PerlIO_stderr(),s);
+                       PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is ");
+                       s = eb;
+                       n = goodsbrk + sbrk_slack;
+                       do {
+                           *--s = '0' + (n % 10);
+                       } while (n /= 10);
+                       PerlIO_puts(PerlIO_stderr(),s);
+                       PerlIO_puts(PerlIO_stderr()," bytes!\n");
+#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */
                        my_exit(1);
                    }
                }
@@ -1343,6 +1394,9 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
        sbrked_remains = require - needed;
        last_op = cp;
     }
+#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
+    no_mem = 0;
+#endif
     last_sbrk_top = cp + require;
 #ifdef DEBUGGING_MSTATS
     goodsbrk += require;
diff --git a/mg.c b/mg.c
index bec0a82..99600a4 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1,6 +1,6 @@
 /*    mg.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #define PERL_IN_MG_C
 #include "perl.h"
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-# include <unistd.h>
-#endif
-
 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
 #  ifndef NGROUPS
 #    define NGROUPS 32
@@ -44,7 +39,6 @@ struct magic_state {
 STATIC void
 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 {
-    dTHR;
     MGS* mgs;
     assert(SvMAGICAL(sv));
 
@@ -96,7 +90,6 @@ Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 int
 Perl_mg_get(pTHX_ SV *sv)
 {
-    dTHR;
     I32 mgs_ix;
     MAGIC* mg;
     MAGIC** mgp;
@@ -139,7 +132,6 @@ Do magic after a value is assigned to the SV.  See C<sv_magic>.
 int
 Perl_mg_set(pTHX_ SV *sv)
 {
-    dTHR;
     I32 mgs_ix;
     MAGIC* mg;
     MAGIC* nextmg;
@@ -200,7 +192,7 @@ Perl_mg_size(pTHX_ SV *sv)
 {
     MAGIC* mg;
     I32 len;
-    
+
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
        MGVTBL* vtbl = mg->mg_virtual;
        if (vtbl && vtbl->svt_len) {
@@ -269,6 +261,8 @@ MAGIC*
 Perl_mg_find(pTHX_ SV *sv, int type)
 {
     MAGIC* mg;
+    if (!sv)
+        return 0;
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
        if (mg->mg_type == type)
            return mg;
@@ -339,7 +333,6 @@ Perl_mg_free(pTHX_ SV *sv)
 U32
 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register REGEXP *rx;
 
     if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
@@ -348,14 +341,13 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
        else                    /* @- */
            return rx->lastparen;
     }
-    
+
     return (U32)-1;
 }
 
 int
 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register I32 paren;
     register I32 s;
     register I32 i;
@@ -374,6 +366,11 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
                    i = t;
                else                    /* @- */
                    i = s;
+               
+               if (i > 0 && DO_UTF8(PL_reg_sv)) {
+                   char *b = rx->subbeg;
+                   i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+               }
                sv_setiv(sv,i);
            }
     }
@@ -383,7 +380,6 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     Perl_croak(aTHX_ PL_no_modify);
     /* NOT REACHED */
     return 0;
@@ -392,7 +388,6 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 U32
 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register I32 paren;
     register I32 i;
     register REGEXP *rx;
@@ -403,7 +398,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
     case '5': case '6': case '7': case '8': case '9': case '&':
        if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
 
-           paren = atoi(mg->mg_ptr);
+           paren = atoi(mg->mg_ptr); /* $& is in [0] */
          getparen:
            if (paren <= rx->nparens &&
                (s1 = rx->startp[paren]) != -1 &&
@@ -411,17 +406,15 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
            {
                i = t1 - s1;
              getlen:
-               if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
-                   char *s = rx->subbeg + s1;
+               if (i > 0 && DO_UTF8(PL_reg_sv)) {
+                   char *s    = rx->subbeg + s1;
                    char *send = rx->subbeg + t1;
-                   i = 0;
-                   while (s < send) {
-                       s += UTF8SKIP(s);
-                       i++;
-                   }
+
+                   i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
                }
-               if (i >= 0)
-                   return i;
+               if (i < 0)
+                   Perl_croak(aTHX_ "panic: magic_len: %d", i);
+               return i;
            }
        }
        return 0;
@@ -456,10 +449,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
            }
        }
        return 0;
-    case ',':
-       return (STRLEN)PL_ofslen;
-    case '\\':
-       return (STRLEN)PL_orslen;
     }
     magic_get(sv,mg);
     if (!SvPOK(sv) && SvNIOK(sv)) {
@@ -474,7 +463,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register I32 paren;
     register char *s;
     register I32 i;
@@ -498,7 +486,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef MACOS_TRADITIONAL
        {
            char msg[256];
-           
+       
            sv_setnv(sv,(double)gMacPerl_OSErr);
            sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");     
        }
@@ -563,15 +551,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        else
            sv_setsv(sv, &PL_sv_undef);
        break;
-    case '\017':               /* ^O */
-       sv_setpv(sv, PL_osname);
+    case '\017':               /* ^O & ^OPEN */
+       if (*(mg->mg_ptr+1) == '\0')
+           sv_setpv(sv, PL_osname);
+       else if (strEQ(mg->mg_ptr, "\017PEN")) {
+           if (!PL_compiling.cop_io)
+               sv_setsv(sv, &PL_sv_undef);
+            else {
+               sv_setsv(sv, PL_compiling.cop_io);
+           }
+       }
        break;
     case '\020':               /* ^P */
        sv_setiv(sv, (IV)PL_perldb);
        break;
     case '\023':               /* ^S */
        {
-           dTHR;
            if (PL_lex_state != LEX_NOTPARSING)
                (void)SvOK_off(sv);
            else if (PL_in_eval)
@@ -596,10 +591,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
             }
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
                sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
-           }    
+           }
             else {
                sv_setsv(sv, PL_compiling.cop_warnings);
-           }    
+           }
            SvPOK_only(sv);
        }
        else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
@@ -614,7 +609,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
             * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
             * XXX Does the new way break anything?
             */
-           paren = atoi(mg->mg_ptr);
+           paren = atoi(mg->mg_ptr); /* $& is in [0] */
          getparen:
            if (paren <= rx->nparens &&
                (s1 = rx->startp[paren]) != -1 &&
@@ -633,7 +628,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                        PL_tainted = FALSE;
                    }
                    sv_setpvn(sv, s, i);
-                   if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE)
+                   if (DO_UTF8(PL_reg_sv))
                        SvUTF8_on(sv);
                    else
                        SvUTF8_off(sv);
@@ -725,10 +720,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
        break;
     case ',':
-       sv_setpvn(sv,PL_ofs,PL_ofslen);
        break;
     case '\\':
-       sv_setpvn(sv,PL_ors,PL_orslen);
        break;
     case '#':
        sv_setpv(sv,PL_ofmt);
@@ -895,7 +888,6 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
 #if defined(VMS)
     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
 #else
-    dTHR;
     if (PL_localizing) {
        HE* entry;
        STRLEN n_a;
@@ -936,12 +928,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
            cur += len+1;
     }
     FreeEnvironmentStrings(envv);
-#   else
-#      ifdef __CYGWIN__
-    I32 i;
-    for (i = 0; environ[i]; i++)
-       safesysfree(environ[i]);
 #      else
+#ifdef USE_ENVIRON_ARRAY
 #          ifndef PERL_USE_SAFE_PUTENV
     I32 i;
 
@@ -951,10 +939,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
        for (i = 0; environ[i]; i++)
            safesysfree(environ[i]);
 #          endif /* PERL_USE_SAFE_PUTENV */
-#      endif /* __CYGWIN__ */
 
     environ[0] = Nullch;
 
+#endif /* USE_ENVIRON_ARRAY */
 #      endif /* WIN32 */
 #   endif /* PERL_IMPLICIT_SYS */
 #endif /* VMS */
@@ -1009,7 +997,6 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register char *s;
     I32 i;
     SV** svp;
@@ -1126,7 +1113,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
        hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
     }
     return 0;
-}          
+}
 
 /* caller is responsible for stack switching/cleanup */
 STATIC int
@@ -1137,7 +1124,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
     PUSHMARK(SP);
     EXTEND(SP, n);
     PUSHs(SvTIED_obj(sv, mg));
-    if (n > 1) { 
+    if (n > 1) {
        if (mg->mg_ptr) {
            if (mg->mg_len >= 0)
                PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
@@ -1205,7 +1192,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
 
 U32
 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
-{         
+{
     dSP;
     U32 retval = 0;
 
@@ -1267,12 +1254,11 @@ int
 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
 {
     return magic_methpack(sv,mg,"EXISTS");
-} 
+}
 
 int
 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     OP *o;
     I32 i;
     GV* gv;
@@ -1291,7 +1277,6 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
     return 0;
 }
@@ -1299,7 +1284,6 @@ Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
     return 0;
 }
@@ -1308,11 +1292,10 @@ int
 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
 {
     SV* lsv = LvTARG(sv);
-    
+
     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
        mg = mg_find(lsv, 'g');
        if (mg && mg->mg_len >= 0) {
-           dTHR;
            I32 i = mg->mg_len;
            if (DO_UTF8(lsv))
                sv_pos_b2u(lsv, &i);
@@ -1331,10 +1314,9 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
     SSize_t pos;
     STRLEN len;
     STRLEN ulen = 0;
-    dTHR;
 
     mg = 0;
-    
+
     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
        mg = mg_find(lsv, 'g');
     if (!mg) {
@@ -1435,14 +1417,20 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 {
     STRLEN len;
     char *tmps = SvPV(sv,len);
-    sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+    if (DO_UTF8(sv)) {
+       sv_utf8_upgrade(LvTARG(sv));
+       sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+       SvUTF8_on(LvTARG(sv));
+    }
+    else
+        sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+
     return 0;
 }
 
 int
 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     TAINT_IF((mg->mg_len & 1) ||
             ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
     return 0;
@@ -1451,7 +1439,6 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     if (PL_localizing) {
        if (PL_localizing == 1)
            mg->mg_len <<= 1;
@@ -1510,7 +1497,6 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
                targ = AvARRAY(av)[LvTARGOFF(sv)];
        }
        if (targ && targ != &PL_sv_undef) {
-           dTHR;               /* just for SvREFCNT_dec */
            /* somebody else defined it for us */
            SvREFCNT_dec(LvTARG(sv));
            LvTARG(sv) = SvREFCNT_inc(targ);
@@ -1541,7 +1527,6 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
 void
 Perl_vivify_defelem(pTHX_ SV *sv)
 {
-    dTHR;                      /* just for SvREFCNT_inc and SvREFCNT_dec*/
     MAGIC *mg;
     SV *value = Nullsv;
 
@@ -1665,7 +1650,6 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     register char *s;
     I32 i;
     STRLEN len;
@@ -1714,12 +1698,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            PL_inplace = Nullch;
        break;
     case '\017':       /* ^O */
-       if (PL_osname)
-           Safefree(PL_osname);
-       if (SvOK(sv))
-           PL_osname = savepv(SvPV(sv,len));
-       else
-           PL_osname = Nullch;
+       if (*(mg->mg_ptr+1) == '\0') {
+           if (PL_osname)
+               Safefree(PL_osname);
+           if (SvOK(sv))
+               PL_osname = savepv(SvPV(sv,len));
+           else
+               PL_osname = Nullch;
+       }
+       else if (strEQ(mg->mg_ptr, "\017PEN")) {
+           if (!PL_compiling.cop_io)
+               PL_compiling.cop_io = newSVsv(sv);
+           else
+               sv_setsv(PL_compiling.cop_io,sv);
+       }
        break;
     case '\020':       /* ^P */
        PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
@@ -1737,7 +1729,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        if (*(mg->mg_ptr+1) == '\0') {
            if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
                i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
-               PL_dowarn = (PL_dowarn & ~G_WARN_ON) 
+               PL_dowarn = (PL_dowarn & ~G_WARN_ON)
                                | (i ? G_WARN_ON : G_WARN_OFF) ;
            }
        }
@@ -1833,21 +1825,24 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        PL_rs = SvREFCNT_inc(PL_nrs);
        break;
     case '\\':
-       if (PL_ors)
-           Safefree(PL_ors);
+       if (PL_ors_sv)
+           SvREFCNT_dec(PL_ors_sv);
        if (SvOK(sv) || SvGMAGICAL(sv)) {
-           s = SvPV(sv,PL_orslen);
-           PL_ors = savepvn(s,PL_orslen);
+           PL_ors_sv = newSVsv(sv);
        }
        else {
-           PL_ors = Nullch;
-           PL_orslen = 0;
+           PL_ors_sv = Nullsv;
        }
        break;
     case ',':
-       if (PL_ofs)
-           Safefree(PL_ofs);
-       PL_ofs = savepv(SvPV(sv, PL_ofslen));
+       if (PL_ofs_sv)
+           SvREFCNT_dec(PL_ofs_sv);
+       if (SvOK(sv) || SvGMAGICAL(sv)) {
+           PL_ofs_sv = newSVsv(sv);
+       }
+       else {
+           PL_ofs_sv = Nullsv;
+       }
        break;
     case '#':
        if (PL_ofmt)
@@ -2043,7 +2038,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                if (PL_origargv[i] == s + 1
 #ifdef OS2
                    || PL_origargv[i] == s + 2
-#endif 
+#endif
                   )
                {
                    ++s;
@@ -2056,7 +2051,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            if (PL_origenviron && (PL_origenviron[0] == s + 1
 #ifdef OS2
                                || (PL_origenviron[0] == s + 9 && (s += 8))
-#endif 
+#endif
               )) {
                my_setenv("NoNe  SuCh", Nullch);
                                            /* force copy of environment */
@@ -2105,7 +2100,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
 {
-    dTHR;
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
                          PTR2UV(thr), PTR2UV(sv));)
@@ -2159,7 +2153,7 @@ Perl_sighandler(int sig)
 #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
     PERL_SET_THX(aTHXo);       /* fake TLS, see above */
 #endif
-    
+
     if (PL_savestack_ix + 15 <= PL_savestack_max)
        flags |= 1;
     if (PL_markstack_ptr < PL_markstack_max - 2)
@@ -2180,7 +2174,7 @@ Perl_sighandler(int sig)
        o_save_i = PL_savestack_ix;
        SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
     }
-    if (flags & 4) 
+    if (flags & 4)
        PL_markstack_ptr++;             /* Protect mark. */
     if (flags & 8) {
        PL_retstack_ix++;
@@ -2189,7 +2183,7 @@ Perl_sighandler(int sig)
     if (flags & 16)
        PL_scopestack_ix += 1;
     /* sv_2cv is too complicated, try a simpler variant first: */
-    if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) 
+    if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
        || SvTYPE(cv) != SVt_PVCV)
        cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
 
@@ -2223,16 +2217,16 @@ Perl_sighandler(int sig)
 cleanup:
     if (flags & 1)
        PL_savestack_ix -= 8; /* Unprotect save in progress. */
-    if (flags & 4) 
+    if (flags & 4)
        PL_markstack_ptr--;
-    if (flags & 8) 
+    if (flags & 8)
        PL_retstack_ix--;
     if (flags & 16)
        PL_scopestack_ix -= 1;
     if (flags & 64)
        SvREFCNT_dec(sv);
     PL_op = myop;                      /* Apparently not needed... */
-    
+
     PL_Sv = tSv;                       /* Restore global temporaries. */
     PL_Xpv = tXpv;
     return;
@@ -2246,7 +2240,6 @@ cleanup:
 static void
 restore_magic(pTHXo_ void *p)
 {
-    dTHR;
     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
     SV* sv = mgs->mgs_sv;
 
@@ -2288,7 +2281,6 @@ restore_magic(pTHXo_ void *p)
 static void
 unwind_handler_stack(pTHXo_ void *p)
 {
-    dTHR;
     U32 flags = *(U32*)p;
 
     if (flags & 1)
diff --git a/mg.h b/mg.h
index ad50f5a..0048803 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -1,6 +1,6 @@
 /*    mg.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 8efbd31..18b9c07 100644 (file)
@@ -59,7 +59,7 @@ sub writemain{
        my($mname, $cname);
        ($mname = $pname) =~ s!/!::!g;
        ($cname = $pname) =~ s!/!__!g;
-       print "EXTERN_C void boot_${cname} (CV* cv);\n";
+        print "EXTERN_C void boot_${cname} (pTHX_ CV* cv);\n";
     }
 
     my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s );
index 256a638..fa7ba99 100644 (file)
--- a/nostdio.h
+++ b/nostdio.h
@@ -1,8 +1,13 @@
-/* This is an 1st attempt to stop other include files pulling 
+/*
+ * Strong denial of stdio - make all stdio calls (we can think of) errors
+ */
+/* This is an 1st attempt to stop other include files pulling
    in real <stdio.h>.
    A more ambitious set of possible symbols can be found in
    sfio.h (inside an _cplusplus gard).
+   It is completely pointless as we have already included it ourselves.
 */
+
 #if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) && !defined(__STDIO_LOADED)
 #define _STDIO_H
 #define _STDIO_INCLUDED
@@ -13,14 +18,98 @@ struct _FILE;
 
 #define _CANNOT "CANNOT"
 
-#undef stdin
-#undef stdout
-#undef stderr
-#undef getc
-#undef putc
 #undef clearerr
-#undef fflush
+#undef fclose
+#undef fdopen
 #undef feof
 #undef ferror
+#undef fflush
+#undef fgetc
+#undef fgetpos
+#undef fgets
 #undef fileno
+#undef flockfile
+#undef fopen
+#undef fprintf
+#undef fputc
+#undef fputs
+#undef fread
+#undef freopen
+#undef fscanf
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef ftrylockfile
+#undef funlockfile
+#undef fwrite
+#undef getc
+#undef getc_unlocked
+#undef getw
+#undef pclose
+#undef popen
+#undef putc
+#undef putc_unlocked
+#undef putw
+#undef rewind
+#undef setbuf
+#undef setvbuf
+#undef stderr
+#undef stdin
+#undef stdout
+#undef tmpfile
+#undef ungetc
+#undef vfprintf
 
+#define fprintf    _CANNOT _fprintf_
+#define stdin      _CANNOT _stdin_
+#define stdout     _CANNOT _stdout_
+#define stderr     _CANNOT _stderr_
+#ifndef OS2
+#define tmpfile()  _CANNOT _tmpfile_
+#endif
+#define fclose(f)  _CANNOT _fclose_
+#define fflush(f)  _CANNOT _fflush_
+#define fopen(p,m)  _CANNOT _fopen_
+#define freopen(p,m,f)  _CANNOT _freopen_
+#define setbuf(f,b)  _CANNOT _setbuf_
+#define setvbuf(f,b,x,s)  _CANNOT _setvbuf_
+#define fscanf  _CANNOT _fscanf_
+#define vfprintf(f,fmt,a)  _CANNOT _vfprintf_
+#define fgetc(f)  _CANNOT _fgetc_
+#define fgets(s,n,f)  _CANNOT _fgets_
+#define fputc(c,f)  _CANNOT _fputc_
+#define fputs(s,f)  _CANNOT _fputs_
+#define getc(f)  _CANNOT _getc_
+#define putc(c,f)  _CANNOT _putc_
+#ifndef OS2
+#define ungetc(c,f)  _CANNOT _ungetc_
+#endif
+#define fread(b,s,c,f)  _CANNOT _fread_
+#define fwrite(b,s,c,f)  _CANNOT _fwrite_
+#define fgetpos(f,p)  _CANNOT _fgetpos_
+#define fseek(f,o,w)  _CANNOT _fseek_
+#define fsetpos(f,p)  _CANNOT _fsetpos_
+#define ftell(f)  _CANNOT _ftell_
+#define rewind(f)  _CANNOT _rewind_
+#define clearerr(f)  _CANNOT _clearerr_
+#define feof(f)  _CANNOT _feof_
+#define ferror(f)  _CANNOT _ferror_
+#define __filbuf(f)  _CANNOT __filbuf_
+#define __flsbuf(c,f)  _CANNOT __flsbuf_
+#define _filbuf(f)  _CANNOT _filbuf_
+#define _flsbuf(c,f)  _CANNOT _flsbuf_
+#define fdopen(fd,p)  _CANNOT _fdopen_
+#define fileno(f)  _CANNOT _fileno_
+#if SFIO_VERSION < 20000101L
+#define flockfile(f)  _CANNOT _flockfile_
+#define ftrylockfile(f)  _CANNOT _ftrylockfile_
+#define funlockfile(f)  _CANNOT _funlockfile_
+#endif
+#define getc_unlocked(f)  _CANNOT _getc_unlocked_
+#define putc_unlocked(c,f)  _CANNOT _putc_unlocked_
+#define popen(c,m)  _CANNOT _popen_
+#define getw(f)  _CANNOT _getw_
+#define putw(v,f)  _CANNOT _putw_
+#ifndef OS2
+#define pclose(f)  _CANNOT _pclose_
+#endif
index bc04f03..60c6e90 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_Gv_AMupdate       pPerl->Perl_Gv_AMupdate
 #undef  Gv_AMupdate
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#undef  Perl_gv_handler
+#define Perl_gv_handler                pPerl->Perl_gv_handler
+#undef  gv_handler
+#define gv_handler             Perl_gv_handler
 #undef  Perl_apply_attrs_string
 #define Perl_apply_attrs_string        pPerl->Perl_apply_attrs_string
 #undef  apply_attrs_string
 #define Perl_regdump           pPerl->Perl_regdump
 #undef  regdump
 #define regdump                        Perl_regdump
+#undef  Perl_regclass_swash
+#define Perl_regclass_swash    pPerl->Perl_regclass_swash
+#undef  regclass_swash
+#define regclass_swash         Perl_regclass_swash
 #undef  Perl_pregexec
 #define Perl_pregexec          pPerl->Perl_pregexec
 #undef  pregexec
 #define Perl_save_re_context   pPerl->Perl_save_re_context
 #undef  save_re_context
 #define save_re_context                Perl_save_re_context
+#undef  Perl_save_padsv
+#define Perl_save_padsv                pPerl->Perl_save_padsv
+#undef  save_padsv
+#define save_padsv             Perl_save_padsv
 #undef  Perl_save_sptr
 #define Perl_save_sptr         pPerl->Perl_save_sptr
 #undef  save_sptr
 #define Perl_sv_unref          pPerl->Perl_sv_unref
 #undef  sv_unref
 #define sv_unref               Perl_sv_unref
+#undef  Perl_sv_unref_flags
+#define Perl_sv_unref_flags    pPerl->Perl_sv_unref_flags
+#undef  sv_unref_flags
+#define sv_unref_flags         Perl_sv_unref_flags
 #undef  Perl_sv_untaint
 #define Perl_sv_untaint                pPerl->Perl_sv_untaint
 #undef  sv_untaint
 #define Perl_utf16_to_utf8_reversed    pPerl->Perl_utf16_to_utf8_reversed
 #undef  utf16_to_utf8_reversed
 #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed
+#undef  Perl_utf8_length
+#define Perl_utf8_length       pPerl->Perl_utf8_length
+#undef  utf8_length
+#define utf8_length            Perl_utf8_length
 #undef  Perl_utf8_distance
 #define Perl_utf8_distance     pPerl->Perl_utf8_distance
 #undef  utf8_distance
 #define Perl_bytes_to_utf8     pPerl->Perl_bytes_to_utf8
 #undef  bytes_to_utf8
 #define bytes_to_utf8          Perl_bytes_to_utf8
+#undef  Perl_utf8_to_uv_simple
+#define Perl_utf8_to_uv_simple pPerl->Perl_utf8_to_uv_simple
+#undef  utf8_to_uv_simple
+#define utf8_to_uv_simple      Perl_utf8_to_uv_simple
 #undef  Perl_utf8_to_uv
 #define Perl_utf8_to_uv                pPerl->Perl_utf8_to_uv
 #undef  utf8_to_uv
 #define utf8_to_uv             Perl_utf8_to_uv
-#undef  Perl_utf8_to_uv_chk
-#define Perl_utf8_to_uv_chk    pPerl->Perl_utf8_to_uv_chk
-#undef  utf8_to_uv_chk
-#define utf8_to_uv_chk         Perl_utf8_to_uv_chk
 #undef  Perl_uv_to_utf8
 #define Perl_uv_to_utf8                pPerl->Perl_uv_to_utf8
 #undef  uv_to_utf8
 #define Perl_whichsig          pPerl->Perl_whichsig
 #undef  whichsig
 #define whichsig               Perl_whichsig
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
 #else
 #endif
 #if defined(MYMALLOC)
 #define Perl_sv_force_normal   pPerl->Perl_sv_force_normal
 #undef  sv_force_normal
 #define sv_force_normal                Perl_sv_force_normal
+#undef  Perl_sv_force_normal_flags
+#define Perl_sv_force_normal_flags     pPerl->Perl_sv_force_normal_flags
+#undef  sv_force_normal_flags
+#define sv_force_normal_flags  Perl_sv_force_normal_flags
 #undef  Perl_tmps_grow
 #define Perl_tmps_grow         pPerl->Perl_tmps_grow
 #undef  tmps_grow
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #  if defined(DEBUGGING)
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+#  endif
 #endif
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
 #if 0
diff --git a/op.c b/op.c
index 84a1df9..379b0b9 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1,6 +1,6 @@
 /*    op.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -107,13 +107,12 @@ S_no_bareword_allowed(pTHX_ OP *o)
 PADOFFSET
 Perl_pad_allocmy(pTHX_ char *name)
 {
-    dTHR;
     PADOFFSET off;
     SV *sv;
 
     if (!(PL_in_my == KEY_our ||
          isALPHA(name[1]) ||
-         (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
+         (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
          (name[1] == '_' && (int)strlen(name) > 2)))
     {
        if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
@@ -238,7 +237,6 @@ STATIC PADOFFSET
 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
            I32 cx_ix, I32 saweval, U32 flags)
 {
-    dTHR;
     CV *cv;
     I32 off;
     SV *sv;
@@ -385,7 +383,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 PADOFFSET
 Perl_pad_findmy(pTHX_ char *name)
 {
-    dTHR;
     I32 off;
     I32 pendoff = 0;
     SV *sv;
@@ -448,7 +445,6 @@ Perl_pad_findmy(pTHX_ char *name)
 void
 Perl_pad_leavemy(pTHX_ I32 fill)
 {
-    dTHR;
     I32 off;
     SV **svp = AvARRAY(PL_comppad_name);
     SV *sv;
@@ -468,7 +464,6 @@ Perl_pad_leavemy(pTHX_ I32 fill)
 PADOFFSET
 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 {
-    dTHR;
     SV *sv;
     I32 retval;
 
@@ -520,7 +515,6 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 SV *
 Perl_pad_sv(pTHX_ PADOFFSET po)
 {
-    dTHR;
 #ifdef USE_THREADS
     DEBUG_X(PerlIO_printf(Perl_debug_log,
                          "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
@@ -537,7 +531,6 @@ Perl_pad_sv(pTHX_ PADOFFSET po)
 void
 Perl_pad_free(pTHX_ PADOFFSET po)
 {
-    dTHR;
     if (!PL_curpad)
        return;
     if (AvARRAY(PL_comppad) != PL_curpad)
@@ -565,7 +558,6 @@ Perl_pad_free(pTHX_ PADOFFSET po)
 void
 Perl_pad_swipe(pTHX_ PADOFFSET po)
 {
-    dTHR;
     if (AvARRAY(PL_comppad) != PL_curpad)
        Perl_croak(aTHX_ "panic: pad_swipe curpad");
     if (!po)
@@ -595,7 +587,6 @@ void
 Perl_pad_reset(pTHX)
 {
 #ifdef USE_BROKEN_PAD_RESET
-    dTHR;
     register I32 po;
 
     if (AvARRAY(PL_comppad) != PL_curpad)
@@ -624,7 +615,6 @@ Perl_pad_reset(pTHX)
 PADOFFSET
 Perl_find_threadsv(pTHX_ const char *name)
 {
-    dTHR;
     char *p;
     PADOFFSET key;
     SV **svp;
@@ -853,6 +843,8 @@ S_cop_free(pTHX_ COP* cop)
 #endif
     if (! specialWARN(cop->cop_warnings))
        SvREFCNT_dec(cop->cop_warnings);
+    if (! specialCopIO(cop->cop_io))
+       SvREFCNT_dec(cop->cop_io);
 }
 
 STATIC void
@@ -909,7 +901,6 @@ STATIC OP *
 S_scalarboolean(pTHX_ OP *o)
 {
     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
-       dTHR;
        if (ckWARN(WARN_SYNTAX)) {
            line_t oldline = CopLINE(PL_curcop);
 
@@ -1005,10 +996,7 @@ Perl_scalarvoid(pTHX_ OP *o)
        || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
                                      || o->op_targ == OP_SETSTATE
                                      || o->op_targ == OP_DBSTATE)))
-    {
-       dTHR;
        PL_curcop = (COP*)o;            /* for warning below */
-    }
 
     /* assumes no premature commitment */
     want = o->op_flags & OPf_WANT;
@@ -1125,12 +1113,17 @@ Perl_scalarvoid(pTHX_ OP *o)
        if (cSVOPo->op_private & OPpCONST_STRICT)
            no_bareword_allowed(o);
        else {
-           dTHR;
            if (ckWARN(WARN_VOID)) {
                useless = "a constant";
                if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
                    useless = 0;
                else if (SvPOK(sv)) {
+                  /* perl4's way of mixing documentation and code
+                     (before the invention of POD) was based on a
+                     trick to mix nroff and perl code. The trick was
+                     built upon these three nroff macros being used in
+                     void context. The pink camel has the details in
+                     the script wrapman near page 319. */
                    if (strnEQ(SvPVX(sv), "di", 2) ||
                        strnEQ(SvPVX(sv), "ds", 2) ||
                        strnEQ(SvPVX(sv), "ig", 2))
@@ -1194,11 +1187,8 @@ Perl_scalarvoid(pTHX_ OP *o)
        }
        break;
     }
-    if (useless) {
-       dTHR;
-       if (ckWARN(WARN_VOID))
-           Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
-    }
+    if (useless && ckWARN(WARN_VOID))
+       Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
     return o;
 }
 
@@ -1299,7 +1289,6 @@ Perl_scalarseq(pTHX_ OP *o)
             o->op_type == OP_LEAVE ||
             o->op_type == OP_LEAVETRY)
        {
-           dTHR;
            for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
                if (kid->op_sibling) {
                    scalarvoid(kid);
@@ -1330,7 +1319,6 @@ S_modkids(pTHX_ OP *o, I32 type)
 OP *
 Perl_mod(pTHX_ OP *o, I32 type)
 {
-    dTHR;
     OP *kid;
     STRLEN n_a;
 
@@ -1348,6 +1336,31 @@ Perl_mod(pTHX_ OP *o, I32 type)
        PL_modcount++;
        return o;
     case OP_CONST:
+        if (o->op_private & (OPpCONST_BARE) && 
+                !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
+            SV *sv = ((SVOP*)o)->op_sv;
+            GV *gv;
+
+            /* Could be a filehandle */
+            if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
+                OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
+                op_free(o);
+                o = gvio;
+            } else {
+                /* OK, it's a sub */
+                OP* enter;
+                gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
+
+                enter = newUNOP(OP_ENTERSUB,0, 
+                        newUNOP(OP_RV2CV, 0, 
+                            newGVOP(OP_GV, 0, gv)
+                        ));
+                enter->op_private |= OPpLVAL_INTRO;
+                op_free(o);
+                o = enter;
+            }
+            break;
+        }
        if (!(o->op_private & (OPpCONST_ARYBASE)))
            goto nomod;
        if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
@@ -1965,7 +1978,6 @@ Perl_sawparens(pTHX_ OP *o)
 OP *
 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
 {
-    dTHR;
     OP *o;
 
     if (ckWARN(WARN_MISC) &&
@@ -2052,7 +2064,6 @@ Perl_save_hints(pTHX)
 int
 Perl_block_start(pTHX_ int full)
 {
-    dTHR;
     int retval = PL_savestack_ix;
 
     SAVEI32(PL_comppad_name_floor);
@@ -2075,13 +2086,17 @@ Perl_block_start(pTHX_ int full)
         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
         SAVEFREESV(PL_compiling.cop_warnings) ;
     }
+    SAVESPTR(PL_compiling.cop_io);
+    if (! specialCopIO(PL_compiling.cop_io)) {
+        PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
+        SAVEFREESV(PL_compiling.cop_io) ;
+    }
     return retval;
 }
 
 OP*
 Perl_block_end(pTHX_ I32 floor, OP *seq)
 {
-    dTHR;
     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
     OP* retval = scalarseq(seq);
     LEAVE_SCOPE(floor);
@@ -2109,7 +2124,6 @@ S_newDEFSVOP(pTHX)
 void
 Perl_newPROG(pTHX_ OP *o)
 {
-    dTHR;
     if (PL_in_eval) {
        if (PL_eval_root)
                return;
@@ -2154,10 +2168,9 @@ Perl_localize(pTHX_ OP *o, I32 lex)
     if (o->op_flags & OPf_PARENS)
        list(o);
     else {
-       dTHR;
        if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
            char *s;
-           for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
+           for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
            if (*s == ';' || *s == '=')
                Perl_warner(aTHX_ WARN_PARENTHESIS,
                            "Parentheses missing around \"%s\" list",
@@ -2192,7 +2205,6 @@ Perl_jmaybe(pTHX_ OP *o)
 OP *
 Perl_fold_constants(pTHX_ register OP *o)
 {
-    dTHR;
     register OP *curop;
     I32 type = o->op_type;
     SV *sv;
@@ -2268,13 +2280,11 @@ Perl_fold_constants(pTHX_ register OP *o)
        if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
            type != OP_NEGATE)
        {
-           IV iv = SvIV(sv);
-           if ((NV)iv == SvNV(sv)) {
-               SvREFCNT_dec(sv);
-               sv = newSViv(iv);
-           }
-           else
-               SvIOK_off(sv);                  /* undo SvIV() damage */
+#ifdef PERL_PRESERVE_IVUV
+           /* Only bother to attempt to fold to IV if
+              most operators will benefit  */
+           SvIV_please(sv);
+#endif
        }
        return newSVOP(OP_CONST, 0, sv);
     }
@@ -2310,7 +2320,6 @@ Perl_fold_constants(pTHX_ register OP *o)
 OP *
 Perl_gen_constant_list(pTHX_ register OP *o)
 {
-    dTHR;
     register OP *curop;
     I32 oldtmps_floor = PL_tmps_floor;
 
@@ -2437,6 +2446,8 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
        if (type == OP_LIST) {  /* already a PUSHMARK there */
            first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
            ((LISTOP*)last)->op_first->op_sibling = first;
+            if (!(first->op_flags & OPf_PARENS))
+                last->op_flags &= ~OPf_PARENS;
        }
        else {
            if (!(last->op_flags & OPf_KIDS)) {
@@ -2621,7 +2632,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        SV* transv = 0;
        U8* tend = t + tlen;
        U8* rend = r + rlen;
-       I32 ulen;
+       STRLEN ulen;
        U32 tfirst = 1;
        U32 tlast = 0;
        I32 tdiff;
@@ -2639,8 +2650,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
 
        if (complement) {
-           U8 tmpbuf[UTF8_MAXLEN];
+           U8 tmpbuf[UTF8_MAXLEN+1];
            U8** cp;
+           I32* cl;
            UV nextmin = 0;
            New(1109, cp, tlen, U8*);
            i = 0;
@@ -2656,7 +2668,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            qsort(cp, i, sizeof(U8*), utf8compare);
            for (j = 0; j < i; j++) {
                U8 *s = cp[j];
-               UV val = utf8_to_uv_chk(s, &ulen, 0);
+               I32 cur = j < i ? cp[j+1] - s : tend - s;
+               UV  val = utf8_to_uv(s, cur, &ulen, 0);
                s += ulen;
                diff = val - nextmin;
                if (diff > 0) {
@@ -2669,7 +2682,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                    }
                }
                if (*s == 0xff)
-                   val = utf8_to_uv_chk(s+1, &ulen, 0);
+                   val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
                if (val >= nextmin)
                    nextmin = val + 1;
            }
@@ -2696,10 +2709,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        while (t < tend || tfirst <= tlast) {
            /* see if we need more "t" chars */
            if (tfirst > tlast) {
-               tfirst = (I32)utf8_to_uv_chk(t, &ulen, 0);
+               tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
                t += ulen;
                if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
-                   tlast = (I32)utf8_to_uv_chk(++t, &ulen, 0);
+                   t++;
+                   tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
                    t += ulen;
                }
                else
@@ -2709,10 +2723,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            /* now see if we need more "r" chars */
            if (rfirst > rlast) {
                if (r < rend) {
-                   rfirst = (I32)utf8_to_uv_chk(r, &ulen, 0);
+                   rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
                    r += ulen;
                    if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
-                       rlast = (I32)utf8_to_uv_chk(++r, &ulen, 0);
+                       r++;
+                       rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
                        r += ulen;
                    }
                    else
@@ -2850,7 +2865,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 OP *
 Perl_newPMOP(pTHX_ I32 type, I32 flags)
 {
-    dTHR;
     PMOP *pmop;
 
     NewOp(1101, pmop, 1, PMOP);
@@ -2877,7 +2891,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
 OP *
 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 {
-    dTHR;
     PMOP *pm;
     LOGOP *rcop;
     I32 repl_has_vars = 0;
@@ -2897,7 +2910,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
            p = SvPV(pat, plen);
            pm->op_pmflags |= PMf_SKIPWHITE;
        }
-       if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
+       if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
            pm->op_pmdynflags |= PMdf_UTF8;
        pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
        if (strEQ("\\s+", pm->op_pmregexp->precomp))
@@ -3068,7 +3081,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
 OP *
 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
 {
-    dTHR;
 #ifdef USE_ITHREADS
     GvIN_PAD_on(gv);
     return newPADOP(type, flags, SvREFCNT_inc(gv));
@@ -3097,7 +3109,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
 void
 Perl_package(pTHX_ OP *o)
 {
-    dTHR;
     SV *sv;
 
     save_hptr(&PL_curstash);
@@ -3359,7 +3370,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
     }
 
     if (list_assignment(left)) {
-       dTHR;
        OP *curop;
 
        PL_modcount = 0;
@@ -3500,7 +3510,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 OP *
 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 {
-    dTHR;
     U32 seq = intro_my();
     register COP *cop;
 
@@ -3531,6 +3540,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
         cop->cop_warnings = PL_curcop->cop_warnings ;
     else
         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+    if (specialCopIO(PL_curcop->cop_io))
+        cop->cop_io = PL_curcop->cop_io;
+    else
+        cop->cop_io = newSVsv(PL_curcop->cop_io) ;
 
 
     if (PL_copline == NOLINE)
@@ -3589,7 +3602,6 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
 STATIC OP *
 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 {
-    dTHR;
     LOGOP *logop;
     OP *o;
     OP *first = *firstp;
@@ -3701,7 +3713,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 OP *
 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 {
-    dTHR;
     LOGOP *logop;
     OP *start;
     OP *o;
@@ -3755,7 +3766,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 OP *
 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
 {
-    dTHR;
     LOGOP *range;
     OP *flip;
     OP *flop;
@@ -3802,7 +3812,6 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
 OP *
 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
 {
-    dTHR;
     OP* listop;
     OP* o;
     int once = block && block->op_flags & OPf_SPECIAL &&
@@ -3858,7 +3867,6 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
 OP *
 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
 {
-    dTHR;
     OP *redo;
     OP *next = 0;
     OP *listop;
@@ -3899,7 +3907,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
 
     if (cont) {
        next = LINKLIST(cont);
-       loopflags |= OPpLOOP_CONTINUE;
     }
     if (expr) {
        OP *unstack = newOP(OP_UNSTACK, 0);
@@ -4052,7 +4059,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
 OP*
 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 {
-    dTHR;
     OP *o;
     STRLEN n_a;
 
@@ -4079,7 +4085,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
-    dTHR;
 #ifdef USE_THREADS
     if (CvMUTEXP(cv)) {
        MUTEX_DESTROY(CvMUTEXP(cv));
@@ -4112,6 +4117,10 @@ Perl_cv_undef(pTHX_ CV *cv)
     CvGV(cv) = Nullgv;
     SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
+    if (CvCONST(cv)) {
+       SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
+       CvCONST_off(cv);
+    }
     if (CvPADLIST(cv)) {
        /* may be during global destruction */
        if (SvREFCNT(CvPADLIST(cv))) {
@@ -4185,7 +4194,6 @@ S_cv_dump(pTHX_ CV *cv)
 STATIC CV *
 S_cv_clone2(pTHX_ CV *proto, CV *outside)
 {
-    dTHR;
     AV* av;
     I32 ix;
     AV* protopadlist = CvPADLIST(proto);
@@ -4312,6 +4320,15 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 #endif
 
     LEAVE;
+
+    if (CvCONST(cv)) {
+       SV* const_sv = op_const_sv(CvSTART(cv), cv);
+       assert(const_sv);
+       /* constant sub () { $x } closing over $x - see lib/constant.pm */
+       SvREFCNT_dec(cv);
+       cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
+    }
+
     return cv;
 }
 
@@ -4328,8 +4345,6 @@ Perl_cv_clone(pTHX_ CV *proto)
 void
 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
 {
-    dTHR;
-
     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
        SV* msg = sv_newmortal();
        SV* name = Nullsv;
@@ -4350,12 +4365,25 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
     }
 }
 
+static void const_sv_xsub(pTHXo_ CV* cv);
+
+/*
+=for apidoc cv_const_sv
+
+If C<cv> is a constant sub eligible for inlining. returns the constant
+value returned by the sub.  Otherwise, returns NULL.
+
+Constant subs can be created with C<newCONSTSUB> or as described in
+L<perlsub/"Constant Functions">.
+
+=cut
+*/
 SV *
 Perl_cv_const_sv(pTHX_ CV *cv)
 {
-    if (!cv || !SvPOK(cv) || SvCUR(cv))
+    if (!cv || !CvCONST(cv))
        return Nullsv;
-    return op_const_sv(CvSTART(cv), cv);
+    return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
 SV *
@@ -4374,8 +4402,12 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 
        if (sv && o->op_next == o)
            return sv;
-       if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
-           continue;
+       if (o->op_next != o) {
+           if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
+               continue;
+           if (type == OP_DBSTATE)
+               continue;
+       }
        if (type == OP_LEAVESUB || type == OP_RETURN)
            break;
        if (sv)
@@ -4385,7 +4417,17 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
        else if ((type == OP_PADSV || type == OP_CONST) && cv) {
            AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
            sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
-           if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
+           if (!sv)
+               return Nullsv;
+           if (CvCONST(cv)) {
+               /* We get here only from cv_clone2() while creating a closure.
+                  Copy the const value here instead of in cv_clone2 so that
+                  SvREADONLY_on doesn't lead to problems when leaving
+                  scope.
+               */
+               sv = newSVsv(sv);
+           }
+           if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
                return Nullsv;
        }
        else
@@ -4419,7 +4461,6 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 CV *
 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
-    dTHR;
     STRLEN n_a;
     char *name;
     char *aname;
@@ -4427,6 +4468,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
+    SV *const_sv;
 
     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
@@ -4465,12 +4507,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        SvREFCNT_dec(PL_compcv);
        cv = PL_compcv = NULL;
        PL_sub_generation++;
-       goto noblock;
+       goto done;
     }
 
-    if (!name || GvCVGEN(gv))
-       cv = Nullcv;
-    else if ((cv = GvCV(gv))) {
+    cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
+
+    if (!block || !ps || *ps || attrs)
+       const_sv = Nullsv;
+    else
+       const_sv = op_const_sv(block, Nullcv);
+
+    if (cv) {
         bool exists = CvROOT(cv) || CvXSUB(cv);
         /* if the subroutine doesn't exist and wasn't pre-declared
          * with a prototype, assume it will be AUTOLOADed,
@@ -4480,8 +4527,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            cv_ckproto(cv, gv, ps);
        /* already defined (or promised)? */
        if (exists || GvASSUMECV(gv)) {
-           SV* const_sv;
-           bool const_changed = TRUE;
            if (!block && !attrs) {
                /* just a "sub foo;" when &foo is already defined */
                SAVEFREESV(PL_compcv);
@@ -4490,24 +4535,42 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            /* ahem, death to those who redefine active sort subs */
            if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
                Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
-           if (!block)
-               goto withattrs;
-           if ((const_sv = cv_const_sv(cv)))
-               const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
-            if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE))
-           {
-               line_t oldline = CopLINE(PL_curcop);
-               CopLINE_set(PL_curcop, PL_copline);
-               Perl_warner(aTHX_ WARN_REDEFINE,
-                       const_sv ? "Constant subroutine %s redefined"
-                                : "Subroutine %s redefined", name);
-               CopLINE_set(PL_curcop, oldline);
+           if (block) {
+               if (ckWARN(WARN_REDEFINE)
+                   || (CvCONST(cv)
+                       && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
+               {
+                   line_t oldline = CopLINE(PL_curcop);
+                   CopLINE_set(PL_curcop, PL_copline);
+                   Perl_warner(aTHX_ WARN_REDEFINE,
+                       CvCONST(cv) ? "Constant subroutine %s redefined"
+                                   : "Subroutine %s redefined", name);
+                   CopLINE_set(PL_curcop, oldline);
+               }
+               SvREFCNT_dec(cv);
+               cv = Nullcv;
            }
-           SvREFCNT_dec(cv);
-           cv = Nullcv;
        }
     }
-  withattrs:
+    if (const_sv) {
+       SvREFCNT_inc(const_sv);
+       if (cv) {
+           assert(!CvROOT(cv) && !CvCONST(cv));
+           sv_setpv((SV*)cv, "");  /* prototype is "" */
+           CvXSUBANY(cv).any_ptr = const_sv;
+           CvXSUB(cv) = const_sv_xsub;
+           CvCONST_on(cv);
+       }
+       else {
+           GvCV(gv) = Nullcv;
+           cv = newCONSTSUB(NULL, name, const_sv);
+       }
+       op_free(block);
+       SvREFCNT_dec(PL_compcv);
+       PL_compcv = NULL;
+       PL_sub_generation++;
+       goto done;
+    }
     if (attrs) {
        HV *stash;
        SV *rcv;
@@ -4591,12 +4654,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            }
        }
     }
-    if (!block) {
-      noblock:
-       PL_copline = NOLINE;
-       LEAVE_SCOPE(floor);
-       return cv;
-    }
+    if (!block)
+       goto done;
 
     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
        av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
@@ -4635,6 +4694,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                PL_curpad[ix] = Nullsv;
            }
        }
+       assert(!CvCONST(cv));
+       if (ps && !*ps && op_const_sv(block, cv))
+           CvCONST_on(cv);
     }
     else {
        AV *av = newAV();                       /* Will be @_ */
@@ -4750,10 +4812,10 @@ eligible for inlining at compile-time.
 =cut
 */
 
-void
+CV *
 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
 {
-    dTHR;
+    CV* cv;
 
     ENTER;
 
@@ -4774,15 +4836,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
 #endif
     }
 
-    newATTRSUB(
-       start_subparse(FALSE, 0),
-       newSVOP(OP_CONST, 0, newSVpv(name,0)),
-       newSVOP(OP_CONST, 0, &PL_sv_no),        /* SvPV(&PL_sv_no) == "" -- GMB */
-       Nullop,
-       newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
-    );
+    cv = newXS(name, const_sv_xsub, __FILE__);
+    CvXSUBANY(cv).any_ptr = sv;
+    CvCONST_on(cv);
+    sv_setpv((SV*)cv, "");  /* prototype is "" */
 
     LEAVE;
+
+    return cv;
 }
 
 /*
@@ -4796,7 +4857,6 @@ Used by C<xsubpp> to hook up XSUBs as Perl subs.
 CV *
 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
 {
-    dTHR;
     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
     register CV *cv;
 
@@ -4814,7 +4874,10 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
                line_t oldline = CopLINE(PL_curcop);
                if (PL_copline != NOLINE)
                    CopLINE_set(PL_curcop, PL_copline);
-               Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name);
+               Perl_warner(aTHX_ WARN_REDEFINE,
+                           CvCONST(cv) ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined"
+                           ,name);
                CopLINE_set(PL_curcop, oldline);
            }
            SvREFCNT_dec(cv);
@@ -4895,7 +4958,6 @@ done:
 void
 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 {
-    dTHR;
     register CV *cv;
     char *name;
     GV *gv;
@@ -4993,8 +5055,6 @@ Perl_oopsAV(pTHX_ OP *o)
 OP *
 Perl_oopsHV(pTHX_ OP *o)
 {
-    dTHR;
-
     switch (o->op_type) {
     case OP_PADSV:
     case OP_PADAV:
@@ -5291,7 +5351,6 @@ Perl_ck_gvconst(pTHX_ register OP *o)
 OP *
 Perl_ck_rvconst(pTHX_ register OP *o)
 {
-    dTHR;
     SVOP *kid = (SVOP*)cUNOPo->op_first;
 
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
@@ -5392,6 +5451,7 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 #else
            kid->op_sv = SvREFCNT_inc(gv);
 #endif
+           kid->op_private = 0;
            kid->op_ppaddr = PL_ppaddr[OP_GV];
        }
     }
@@ -5401,7 +5461,6 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 OP *
 Perl_ck_ftst(pTHX_ OP *o)
 {
-    dTHR;
     I32 type = o->op_type;
 
     if (o->op_flags & OPf_REF) {
@@ -5439,7 +5498,6 @@ Perl_ck_ftst(pTHX_ OP *o)
 OP *
 Perl_ck_fun(pTHX_ OP *o)
 {
-    dTHR;
     register OP *kid;
     OP **tokid;
     OP *sibl;
@@ -5764,7 +5822,6 @@ Perl_ck_lfun(pTHX_ OP *o)
 OP *
 Perl_ck_defined(pTHX_ OP *o)           /* 19990527 MJD */
 {
-    dTHR;
     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
        switch (cUNOPo->op_first->op_type) {
        case OP_RV2AV:
@@ -6135,7 +6192,6 @@ Perl_ck_sort(pTHX_ OP *o)
 STATIC void
 S_simplify_sort(pTHX_ OP *o)
 {
-    dTHR;
     register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
     OP *k;
     int reversed;
@@ -6269,7 +6325,6 @@ Perl_ck_join(pTHX_ OP *o)
 OP *
 Perl_ck_subr(pTHX_ OP *o)
 {
-    dTHR;
     OP *prev = ((cUNOPo->op_first->op_sibling)
             ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
     OP *o2 = prev->op_sibling;
@@ -6484,7 +6539,6 @@ Perl_ck_substr(pTHX_ OP *o)
 void
 Perl_peep(pTHX_ register OP *o)
 {
-    dTHR;
     register OP* oldop = 0;
     STRLEN n_a;
     OP *last_composite = Nullop;
@@ -6520,7 +6574,7 @@ Perl_peep(pTHX_ register OP *o)
                PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
                if (SvPADTMP(cSVOPo->op_sv)) {
                    /* If op_sv is already a PADTMP then it is being used by
-                    * another pad, so make a copy. */
+                    * some pad, so make a copy. */
                    sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
                    SvREADONLY_on(PL_curpad[ix]);
                    SvREFCNT_dec(cSVOPo->op_sv);
@@ -6529,6 +6583,8 @@ Perl_peep(pTHX_ register OP *o)
                    SvREFCNT_dec(PL_curpad[ix]);
                    SvPADTMP_on(cSVOPo->op_sv);
                    PL_curpad[ix] = cSVOPo->op_sv;
+                   /* XXX I don't know how this isn't readonly already. */
+                   SvREADONLY_on(PL_curpad[ix]);
                }
                cSVOPo->op_sv = Nullsv;
                o->op_targ = ix;
@@ -6646,8 +6702,14 @@ Perl_peep(pTHX_ register OP *o)
 
        case OP_ENTERLOOP:
            o->op_seq = PL_op_seqmax++;
+           while (cLOOP->op_redoop->op_type == OP_NULL)
+               cLOOP->op_redoop = cLOOP->op_redoop->op_next;
            peep(cLOOP->op_redoop);
+           while (cLOOP->op_nextop->op_type == OP_NULL)
+               cLOOP->op_nextop = cLOOP->op_nextop->op_next;
            peep(cLOOP->op_nextop);
+           while (cLOOP->op_lastop->op_type == OP_NULL)
+               cLOOP->op_lastop = cLOOP->op_lastop->op_next;
            peep(cLOOP->op_lastop);
            break;
 
@@ -6655,6 +6717,9 @@ Perl_peep(pTHX_ register OP *o)
        case OP_MATCH:
        case OP_SUBST:
            o->op_seq = PL_op_seqmax++;
+           while (cPMOP->op_pmreplstart && 
+                  cPMOP->op_pmreplstart->op_type == OP_NULL)
+               cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
            peep(cPMOP->op_pmreplstart);
            break;
 
@@ -6696,6 +6761,8 @@ Perl_peep(pTHX_ register OP *o)
            svp = cSVOPx_svp(((BINOP*)o)->op_last);
            if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
                key = SvPV(sv, keylen);
+               if (SvUTF8(sv))
+                 keylen = -keylen;
                lexname = newSVpvn_share(key, keylen, 0);
                SvREFCNT_dec(sv);
                *svp = lexname;
@@ -6714,6 +6781,8 @@ Perl_peep(pTHX_ register OP *o)
            if (!fields || !GvHV(*fields))
                break;
            key = SvPV(*svp, keylen);
+           if (SvUTF8(*svp))
+               keylen = -keylen;
            indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
            if (!indsvp) {
                Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
@@ -6779,6 +6848,8 @@ Perl_peep(pTHX_ register OP *o)
                 key_op = (SVOP*)key_op->op_sibling) {
                svp = cSVOPx_svp(key_op);
                key = SvPV(*svp, keylen);
+               if (SvUTF8(*svp))
+                   keylen = -keylen;
                indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
                if (!indsvp) {
                    Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
@@ -6843,3 +6914,15 @@ Perl_peep(pTHX_ register OP *o)
     }
     LEAVE;
 }
+
+#include "XSUB.h"
+
+/* Efficient sub that returns a constant scalar value. */
+static void
+const_sv_xsub(pTHXo_ CV* cv)
+{
+    dXSARGS;
+    EXTEND(sp, 1);
+    ST(0) = (SV*)XSANY.any_ptr;
+    XSRETURN(1);
+}
diff --git a/op.h b/op.h
index 55b85a5..7dc118e 100644 (file)
--- a/op.h
+++ b/op.h
@@ -1,6 +1,6 @@
 /*    op.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -139,9 +139,6 @@ Deprecated.  Use C<GIMME_V> instead.
 /* Private for OP_REPEAT */
 #define OPpREPEAT_DOLIST       64      /* List replication. */
 
-/* Private for OP_LEAVELOOP */
-#define OPpLOOP_CONTINUE       64      /* a continue block is present */
-
 /* Private for OP_RV2?V, OP_?ELEM */
 #define OPpDEREF               (32|64) /* Want ref to something: */
 #define OPpDEREF_AV            32      /*   Want ref to AV. */
@@ -250,6 +247,9 @@ struct pmop {
 #define PMdf_USED      0x01            /* pm has been used once already */
 #define PMdf_TAINTED   0x02            /* pm compiled from tainted pattern */
 #define PMdf_UTF8      0x04            /* pm compiled from utf8 data */
+#define PMdf_DYN_UTF8  0x08
+
+#define PMdf_CMP_UTF8  (PMdf_UTF8|PMdf_DYN_UTF8)
 
 #define PMf_RETAINT    0x0001          /* taint $1 etc. if target tainted */
 #define PMf_ONCE       0x0002          /* use pattern only once per reset */
index 43d98ae..22bffb8 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -1,5 +1,6 @@
 #!/usr/bin/perl
 
+chmod 0666, "opcode.h", "opnames.h";
 unlink "opcode.h", "opnames.h";
 open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
 open(ON, ">opnames.h") || die "Can't create opnames.h: $!\n";
@@ -56,7 +57,9 @@ for (@ops) {
 }
 print ON "\t", &tab(3,"OP_max"), "\n";
 print ON "} opcode;\n";
-print ON "\n#define MAXO ", scalar @ops, "\n\n"; 
+print ON "\n#define MAXO ", scalar @ops, "\n";
+print ON "#define OP_phoney_INPUT_ONLY -1\n";
+print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n";
 
 # Emit op names and descriptions.
 
index ba28f68..16b2f02 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -359,6 +359,8 @@ typedef enum opcode {
 } opcode;
 
 #define MAXO 351
+#define OP_phoney_INPUT_ONLY -1
+#define OP_phoney_OUTPUT_ONLY -2
 
 
 #define OP_IS_SOCKET(op)       \
index 3568028..0b8837f 100644 (file)
@@ -4,7 +4,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
     'NAME'     => 'OS2::ExtAttr',
     'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION
-    MAN3PODS   => ' ',         # Pods will be built by installman.
+    MAN3PODS   => {},  # Pods will be built by installman.
     'LIBS'     => [''],   # e.g., '-lm' 
     'DEFINE'   => '',     # e.g., '-DHAVE_SOMETHING' 
     'INC'      => '',     # e.g., '-I/usr/include/other' 
index 3952168..2d4a6a7 100644 (file)
@@ -4,7 +4,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
     'NAME'     => 'OS2::PrfDB',
     'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION
-    MAN3PODS   => ' ',         # Pods will be built by installman.
+    MAN3PODS   => {},  # Pods will be built by installman.
     'LIBS'     => [''],   # e.g., '-lm' 
     'DEFINE'   => '',     # e.g., '-DHAVE_SOMETHING' 
     'INC'      => '',     # e.g., '-I/usr/include/other' 
index d324063..9c97ad0 100644 (file)
@@ -4,7 +4,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
     'NAME'     => 'OS2::Process',
     VERSION_FROM=> 'Process.pm',
-    MAN3PODS   => ' ',         # Pods will be built by installman.
+    MAN3PODS   => {},  # Pods will be built by installman.
     'LIBS'     => [''],   # e.g., '-lm' 
     'DEFINE'   => '',     # e.g., '-DHAVE_SOMETHING' 
     'INC'      => '',     # e.g., '-I/usr/include/other' 
index fe2403d..fb91688 100644 (file)
@@ -3,7 +3,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
              NAME => 'OS2::DLL',
              VERSION => '0.01',
-             MAN3PODS  => ' ',         # Pods will be built by installman.
+             MAN3PODS  => {},  # Pods will be built by installman.
              XSPROTOARG => '-noprototypes',
              PERL_MALLOC_OK => 1,
 );
index 6648b2c..178ef7b 100644 (file)
@@ -3,7 +3,7 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
              NAME => 'OS2::REXX',
              VERSION => '0.22',
-             MAN3PODS  => ' ',         # Pods will be built by installman.
+             MAN3PODS  => {},  # Pods will be built by installman.
              XSPROTOARG => '-noprototypes',
              PERL_MALLOC_OK => 1,
 );
index 1dc20d3..b196ea1 100644 (file)
@@ -46,7 +46,6 @@ static long incompartment;
 static SV*
 exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
 {
-    dTHR;
     HMODULE hRexx, hRexxAPI;
     BYTE    buf[200];
     LONG    APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, 
index c324cf2..7fe8113 100644 (file)
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -21,6 +21,8 @@
 #include <process.h>
 #include <fcntl.h>
 
+#define PERLIO_NOT_STDIO 0
+
 #include "EXTERN.h"
 #include "perl.h"
 
@@ -375,7 +377,6 @@ spawn_sighandler(int sig)
 static int
 result(pTHX_ int flag, int pid)
 {
-        dTHR;
        int r, status;
        Signal_t (*ihand)();     /* place to save signal during system() */
        Signal_t (*qhand)();     /* place to save signal during system() */
@@ -467,7 +468,6 @@ static ULONG os2_mytype;
 int
 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 {
-    dTHR;
        int trueflag = flag;
        int rc, pass = 1;
        char *tmps;
@@ -605,8 +605,9 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
                char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
 
                if (scr) {
-                   FILE *file;
-                   char *s = 0, *s1;
+                   PerlIO *file;
+                    SSize_t rd;
+                   char *s = 0, *s1, *s2;
                    int l;
 
                     l = strlen(scr);
@@ -622,14 +623,18 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
                     Safefree(scr);
                     scr = scrbuf;
 
-                   file = fopen(scr, "r");
+                   file = PerlIO_open(scr, "r");
                    PL_Argv[0] = scr;
                    if (!file)
                        goto panic_file;
-                   if (!fgets(buf, sizeof buf, file)) { /* Empty... */
 
+                   rd = PerlIO_read(file, buf, sizeof buf-1);
+                   buf[rd]='\0';
+                   if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
+
+                   if (!rd) { /* Empty... */
                        buf[0] = 0;
-                       fclose(file);
+                       PerlIO_close(file);
                        /* Special case: maybe from -Zexe build, so
                           there is an executable around (contrary to
                           documentation, DosQueryAppType sometimes (?)
@@ -648,7 +653,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
                        } else
                            goto longbuf;
                    }
-                   if (fclose(file) != 0) { /* Failure */
+                   if (PerlIO_close(file) != 0) { /* Failure */
                      panic_file:
                        Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", 
                             scr, Strerror(errno));
@@ -818,7 +823,6 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
 int
 do_spawn3(pTHX_ char *cmd, int execf, int flag)
 {
-    dTHR;
     register char **a;
     register char *s;
     char flags[10];
@@ -946,7 +950,6 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag)
 int
 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
 {
-    dTHR;
     register char **a;
     int rc;
     int flag = P_WAIT, flag_set = 0;
@@ -984,21 +987,18 @@ os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
 int
 os2_do_spawn(pTHX_ char *cmd)
 {
-    dTHR;
     return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
 }
 
 int
 do_spawn_nowait(pTHX_ char *cmd)
 {
-    dTHR;
     return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
 }
 
 bool
 Perl_do_exec(pTHX_ char *cmd)
 {
-    dTHR;
     do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
     return FALSE;
 }
@@ -1006,7 +1006,6 @@ Perl_do_exec(pTHX_ char *cmd)
 bool
 os2exec(pTHX_ char *cmd)
 {
-    dTHR;
     return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
 }
 
@@ -1163,10 +1162,13 @@ tcp1(char *name, int arg)
        ((void (*)(int)) fcn) (arg);
 }
 
+#ifndef HAS_GETHOSTENT         /* Older versions of EMX did not have it... */
 void * gethostent()    { return tcp0("GETHOSTENT");  }
 void * getnetent()     { return tcp0("GETNETENT");   }
 void * getprotoent()   { return tcp0("GETPROTOENT"); }
 void * getservent()    { return tcp0("GETSERVENT");  }
+#endif
+
 void   sethostent(x)   { tcp1("SETHOSTENT",  x); }
 void   setnetent(x)    { tcp1("SETNETENT",   x); }
 void   setprotoent(x)  { tcp1("SETPROTOENT", x); }
@@ -1367,7 +1369,6 @@ os2error(int rc)
 char *
 os2_execname(pTHX)
 {
-  dTHR;
   char buf[300], *p;
 
   if (_execname(buf, sizeof buf) != 0)
index c9719e6..dccd932 100644 (file)
@@ -155,7 +155,6 @@ extern int rc;
            Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc);     \
     } STMT_END
 /*#define THR ((struct thread *) TlsGetValue(PL_thr_key))
-#define dTHR struct thread *thr = THR
 */
 
 #ifdef USE_SLOW_THREAD_SPECIFIC
index b9d0dc4..5030553 100644 (file)
@@ -70,7 +70,7 @@
 #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
 static char    *local_patches[] = {
         NULL
-       ,"DEVEL7368"
+       ,"DEVEL8341"
        ,NULL
 };
 
diff --git a/perl.c b/perl.c
index cb2cb14..4911e79 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,6 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-2000 Larry Wall
+ *    Copyright (c) 1987-2001 Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -157,7 +157,7 @@ perl_construct(pTHXx)
 
 #ifdef MULTIPLICITY
     init_interp();
-    PL_perl_destruct_level = 1; 
+    PL_perl_destruct_level = 1;
 #else
    if (PL_perl_destruct_level > 0)
        init_interp();
@@ -298,7 +298,6 @@ Shuts down a Perl interpreter.  See L<perlembed>.
 void
 perl_destruct(pTHXx)
 {
-    dTHR;
     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
     I32 last_sv_count;
     HV *hv;
@@ -344,7 +343,7 @@ perl_destruct(pTHXx)
            DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "perl_destruct: detaching thread %p\n", t));
            ThrSETSTATE(t, THRf_R_DETACHED);
-           /* 
+           /*
             * We unlock threads_mutex and t->mutex in the opposite order
             * from which we locked them just so that DETACH won't
             * deadlock if it panics. It's only a breach of good style
@@ -434,7 +433,7 @@ perl_destruct(pTHXx)
     if (destruct_level == 0){
 
        DEBUG_P(debprofdump());
-    
+
        /* The exit() function will do everything that needs doing. */
        return;
     }
@@ -474,11 +473,11 @@ perl_destruct(pTHXx)
 
     /* magical thingies */
 
-    Safefree(PL_ofs);          /* $, */
-    PL_ofs = Nullch;
+    SvREFCNT_dec(PL_ofs_sv);   /* $, */
+    PL_ofs_sv = Nullsv;
 
-    Safefree(PL_ors);          /* $\ */
-    PL_ors = Nullch;
+    SvREFCNT_dec(PL_ors_sv);   /* $\ */
+    PL_ors_sv = Nullsv;
 
     SvREFCNT_dec(PL_rs);       /* $/ */
     PL_rs = Nullsv;
@@ -603,6 +602,9 @@ perl_destruct(pTHXx)
     if (!specialWARN(PL_compiling.cop_warnings))
        SvREFCNT_dec(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = Nullsv;
+    if (!specialCopIO(PL_compiling.cop_io))
+       SvREFCNT_dec(PL_compiling.cop_io);
+    PL_compiling.cop_io = Nullsv;
 #ifdef USE_ITHREADS
     Safefree(CopFILE(&PL_compiling));
     CopFILE(&PL_compiling) = Nullch;
@@ -724,7 +726,7 @@ perl_destruct(pTHXx)
     Safefree(PL_psig_name);
     nuke_stacks();
     PL_hints = 0;              /* Reset hints. Should hints be per-interpreter ? */
-    
+
     DEBUG_P(debprofdump());
 #ifdef USE_THREADS
     MUTEX_DESTROY(&PL_strtab_mutex);
@@ -783,10 +785,18 @@ perl_free(pTHXx)
 #if defined(PERL_OBJECT)
     PerlMem_free(this);
 #else
-#  if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
+#  if defined(WIN32)
+#  if defined(PERL_IMPLICIT_SYS)
     void *host = w32_internal_host;
+    if (PerlProc_lasthost()) {
+       PerlIO_cleanup();     
+    }
     PerlMem_free(aTHXx);
     win32_delete_internal_host(host);
+#else
+    PerlIO_cleanup();     
+    PerlMem_free(aTHXx);
+#endif
 #  else
     PerlMem_free(aTHXx);
 #  endif
@@ -813,7 +823,6 @@ Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
 int
 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 {
-    dTHR;
     I32 oldscope;
     int ret;
     dJMPENV;
@@ -836,7 +845,7 @@ setuid perl scripts securely.\n");
 
     PL_origargv = argv;
     PL_origargc = argc;
-#if !defined( VMS) && !defined(EPOC)  /* VMS doesn't have environ array */
+#ifdef  USE_ENVIRON_ARRAY
     PL_origenviron = environ;
 #endif
 
@@ -915,7 +924,6 @@ S_vparse_body(pTHX_ va_list args)
 STATIC void *
 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 {
-    dTHR;
     int argc = PL_origargc;
     char **argv = PL_origargv;
     char *scriptname = NULL;
@@ -986,7 +994,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #ifdef MACOS_TRADITIONAL
            /* ignore -e for Dev:Pseudo argument */
            if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
-               break; 
+               break;
 #endif
            if (PL_euid != PL_uid || PL_egid != PL_gid)
                Perl_croak(aTHX_ "No -e allowed in setuid scripts");
@@ -1267,7 +1275,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 #   else
     SOCKSinit(argv[0]);
 #   endif
-#endif    
+#endif
 
     init_predump_symbols();
     /* init_postdump_symbols not currently designed to be called */
@@ -1346,7 +1354,6 @@ Tells a Perl interpreter to run.  See L<perlembed>.
 int
 perl_run(pTHXx)
 {
-    dTHR;
     I32 oldscope;
     int ret = 0;
     dJMPENV;
@@ -1414,8 +1421,6 @@ S_vrun_body(pTHX_ va_list args)
 STATIC void *
 S_run_body(pTHX_ I32 oldscope)
 {
-    dTHR;
-
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
                     PL_sawampersand ? "Enabling" : "Omitting"));
 
@@ -1434,7 +1439,7 @@ S_run_body(pTHX_ I32 oldscope)
            my_exit(0);
        }
        if (PERLDB_SINGLE && PL_DBsingle)
-           sv_setiv(PL_DBsingle, 1); 
+           sv_setiv(PL_DBsingle, 1);
        if (PL_initav)
            call_list(oldscope, PL_initav);
     }
@@ -1474,10 +1479,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create)
 #ifdef USE_THREADS
     if (name[1] == '\0' && !isALPHA(name[0])) {
        PADOFFSET tmp = find_threadsv(name);
-       if (tmp != NOT_IN_PAD) {
-           dTHR;
+       if (tmp != NOT_IN_PAD)
            return THREADSV(tmp);
-       }
     }
 #endif /* USE_THREADS */
     gv = gv_fetchpv(name, create, SVt_PV);
@@ -1569,7 +1572,7 @@ Performs a callback to the specified Perl sub.  See L<perlcall>.
 
 I32
 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
-              
+
                        /* See G_* flags in cop.h */
                        /* null terminated arg list */
 {
@@ -1694,15 +1697,15 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        {
            register PERL_CONTEXT *cx;
            I32 gimme = GIMME_V;
-           
+       
            ENTER;
            SAVETMPS;
-           
+       
            push_return(Nullop);
            PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
            PUSHEVAL(cx, 0, 0);
            PL_eval_root = PL_op;             /* Only needed so that goto works right. */
-           
+       
            PL_in_eval = EVAL_INEVAL;
            if (flags & G_KEEPERR)
                PL_in_eval |= EVAL_KEEPERR;
@@ -1797,8 +1800,6 @@ S_vcall_body(pTHX_ va_list args)
 STATIC void
 S_call_body(pTHX_ OP *myop, int is_eval)
 {
-    dTHR;
-
     if (PL_op == myop) {
        if (is_eval)
            PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
@@ -1821,7 +1822,7 @@ Tells Perl to C<eval> the string in the SV.
 
 I32
 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
-       
+
                        /* See G_* flags in cop.h */
 {
     dSP;
@@ -2025,13 +2026,12 @@ NULL
 char *
 Perl_moreswitches(pTHX_ char *s)
 {
-    I32 numlen;
+    STRLEN numlen;
     U32 rschar;
 
     switch (*s) {
     case '0':
     {
-       dTHR;
        numlen = 0;                     /* disallow underscores */
        rschar = (U32)scan_oct(s, 4, &numlen);
        SvREFCNT_dec(PL_nrs);
@@ -2095,7 +2095,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef DEBUGGING
        forbid_setid("-D");
        if (isALPHA(s[1])) {
-           static char debopts[] = "psltocPmfrxuLHXDS";
+           static char debopts[] = "psltocPmfrxuLHXDST";
            char *d;
 
            for (s++; *s && (d = strchr(debopts,*s)); s++)
@@ -2107,7 +2107,6 @@ Perl_moreswitches(pTHX_ char *s)
        }
        PL_debug |= 0x80000000;
 #else
-       dTHR;
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ WARN_DEBUGGING,
                   "Recompile perl with -DDEBUGGING to use -D switch\n");
@@ -2117,7 +2116,7 @@ Perl_moreswitches(pTHX_ char *s)
        return s;
     }  
     case 'h':
-       usage(PL_origargv[0]);    
+       usage(PL_origargv[0]);
        PerlProc_exit(0);
     case 'i':
        if (PL_inplace)
@@ -2159,24 +2158,23 @@ Perl_moreswitches(pTHX_ char *s)
     case 'l':
        PL_minus_l = TRUE;
        s++;
-       if (PL_ors)
-           Safefree(PL_ors);
+       if (PL_ors_sv) {
+           SvREFCNT_dec(PL_ors_sv);
+           PL_ors_sv = Nullsv;
+       }
        if (isDIGIT(*s)) {
-           PL_ors = savepv("\n");
-           PL_orslen = 1;
+           PL_ors_sv = newSVpvn("\n",1);
            numlen = 0;                 /* disallow underscores */
-           *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
+           *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
            s += numlen;
        }
        else {
-           dTHR;
            if (RsPARA(PL_nrs)) {
-               PL_ors = "\n\n";
-               PL_orslen = 2;
+               PL_ors_sv = newSVpvn("\n\n",2);
+           }
+           else {
+               PL_ors_sv = newSVsv(PL_nrs);
            }
-           else
-               PL_ors = SvPV(PL_nrs, PL_orslen);
-           PL_ors = savepvn(PL_ors, PL_orslen);
        }
        return s;
     case 'M':
@@ -2261,7 +2259,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 
        PerlIO_printf(PerlIO_stdout(),
-                     "\n\nCopyright 1987-2000, Larry Wall\n");
+                     "\n\nCopyright 1987-2001, Larry Wall\n");
 #ifdef MACOS_TRADITIONAL
        PerlIO_printf(PerlIO_stdout(),
                      "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n");
@@ -2329,16 +2327,16 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
        PerlProc_exit(0);
     case 'w':
        if (! (PL_dowarn & G_WARN_ALL_MASK))
-           PL_dowarn |= G_WARN_ON; 
+           PL_dowarn |= G_WARN_ON;
        s++;
        return s;
     case 'W':
-       PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; 
+       PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
        PL_compiling.cop_warnings = pWARN_ALL ;
        s++;
        return s;
     case 'X':
-       PL_dowarn = G_WARN_ALL_OFF; 
+       PL_dowarn = G_WARN_ALL_OFF;
        PL_compiling.cop_warnings = pWARN_NONE ;
        s++;
        return s;
@@ -2484,7 +2482,6 @@ S_init_interp(pTHX)
 STATIC void
 S_init_main_stash(pTHX)
 {
-    dTHR;
     GV *gv;
 
     /* Note that strtab is a rather special HV.  Assumptions are made
@@ -2496,7 +2493,7 @@ S_init_main_stash(pTHX)
 #endif
     HvSHAREKEYS_off(PL_strtab);                        /* mandatory */
     hv_ksplit(PL_strtab, 512);
-    
+
     PL_curstash = PL_defstash = newHV();
     PL_curstname = newSVpvn("main",4);
     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
@@ -2528,8 +2525,6 @@ S_init_main_stash(pTHX)
 STATIC void
 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 {
-    dTHR;
-
     *fdscript = -1;
 
     if (PL_e_script) {
@@ -2719,7 +2714,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
     check_okay = fstatvfs(fd, &stfs) == 0;
     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
 #   endif /* fstatvfs */
+
 #   if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
         defined(PERL_MOUNT_NOSUID)     && \
         defined(HAS_FSTATFS)           && \
@@ -2789,7 +2784,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
         fclose(mtab);
 #   endif /* getmntent+hasmntopt */
 
-    if (!check_okay) 
+    if (!check_okay)
        Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
     return on_nosuid;
 }
@@ -2823,7 +2818,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
      */
 
 #ifdef DOSUID
-    dTHR;
     char *s, *s2;
 
     if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
@@ -3021,7 +3015,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #else /* !DOSUID */
     if (PL_euid != PL_uid || PL_egid != PL_gid) {      /* (suidperl doesn't exist, in fact) */
 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
-       dTHR;
        PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
        if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
            ||
@@ -3046,7 +3039,7 @@ S_find_beginning(pTHX)
     forbid_setid("-x");
 #ifdef MACOS_TRADITIONAL
     /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
-    
+
     while (PL_doextract || gMacPerl_AlwaysExtract) {
        if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
            if (!gMacPerl_AlwaysExtract)
@@ -3060,7 +3053,7 @@ S_find_beginning(pTHX)
                
            /* Pater peccavi, file does not have #! */
            PerlIO_rewind(PL_rsfp);
-           
+       
            break;
        }
 #else
@@ -3112,7 +3105,6 @@ S_forbid_setid(pTHX_ char *s)
 void
 Perl_init_debugger(pTHX)
 {
-    dTHR;
     HV *ostash = PL_curstash;
 
     PL_curstash = PL_debstash;
@@ -3123,11 +3115,11 @@ Perl_init_debugger(pTHX)
     PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
     sv_upgrade(GvSV(PL_DBsub), SVt_IV);        /* IVX accessed if PERLDB_SUB_NN */
     PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
-    sv_setiv(PL_DBsingle, 0); 
+    sv_setiv(PL_DBsingle, 0);
     PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
-    sv_setiv(PL_DBtrace, 0); 
+    sv_setiv(PL_DBtrace, 0);
     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
-    sv_setiv(PL_DBsignal, 0); 
+    sv_setiv(PL_DBsignal, 0);
     PL_curstash = ostash;
 }
 
@@ -3180,7 +3172,6 @@ Perl_init_stacks(pTHX)
 STATIC void
 S_nuke_stacks(pTHX)
 {
-    dTHR;
     while (PL_curstackinfo->si_next)
        PL_curstackinfo = PL_curstackinfo->si_next;
     while (PL_curstackinfo) {
@@ -3217,7 +3208,6 @@ S_init_lexer(pTHX)
 STATIC void
 S_init_predump_symbols(pTHX)
 {
-    dTHR;
     GV *tmpgv;
     IO *io;
 
@@ -3257,7 +3247,6 @@ S_init_predump_symbols(pTHX)
 STATIC void
 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
-    dTHR;
     char *s;
     SV *sv;
     GV* tmpgv;
@@ -3319,7 +3308,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        GvMULTI_on(PL_envgv);
        hv = GvHVn(PL_envgv);
        hv_magic(hv, PL_envgv, 'E');
-#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
+#ifdef USE_ENVIRON_ARRAY
        /* Note that if the supplied env parameter is actually a copy
           of the global environ then it may now point to free'd memory
           if the environment has been modified since. To avoid this
@@ -3404,7 +3393,7 @@ S_init_perllib(pTHX)
        Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
        if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
            incpush(SvPVX(privdir), TRUE, FALSE);
-           
+       
        SvREFCNT_dec(privdir);
     }
     if (!PL_tainting)
@@ -3413,7 +3402,7 @@ S_init_perllib(pTHX)
 #ifndef PRIVLIB_EXP
 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
 #endif
-#if defined(WIN32) 
+#if defined(WIN32)
     incpush(PRIVLIB_EXP, TRUE, FALSE);
 #else
     incpush(PRIVLIB_EXP, FALSE, FALSE);
@@ -3483,7 +3472,7 @@ S_init_perllib(pTHX)
 #endif
 #ifndef PERLLIB_MANGLE
 #  define PERLLIB_MANGLE(s,n) (s)
-#endif 
+#endif
 
 STATIC void
 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
@@ -3559,7 +3548,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
 #define PERL_ARCH_FMT          "/%s"
 #endif
                /* .../version/archname if -d .../version/archname */
-               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, 
+               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
                                libdir,
                               (int)PERL_REVISION, (int)PERL_VERSION,
                               (int)PERL_SUBVERSION, ARCHNAME);
@@ -3637,6 +3626,7 @@ S_init_main_thread(pTHX)
     thr->tid = 0;
     thr->next = thr;
     thr->prev = thr;
+    thr->thr_done = 0;
     MUTEX_UNLOCK(&PL_threads_mutex);
 
 #ifdef HAVE_THREAD_INTERN
@@ -3651,8 +3641,9 @@ S_init_main_thread(pTHX)
     PERL_SET_THX(thr);
 
     /*
-     * These must come after the SET_THR because sv_setpvn does
-     * SvTAINT and the taint fields require dTHR.
+     * These must come after the thread self setting
+     * because sv_setpvn does SvTAINT and the taint
+     * fields thread selfness being set.
      */
     PL_toptarget = NEWSV(0,0);
     sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3680,7 +3671,6 @@ S_init_main_thread(pTHX)
 void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
-    dTHR;
     SV *atsv;
     line_t oldline = CopLINE(PL_curcop);
     CV *cv;
@@ -3785,8 +3775,6 @@ S_call_list_body(pTHX_ CV *cv)
 void
 Perl_my_exit(pTHX_ U32 status)
 {
-    dTHR;
-
     DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
                          thr, (unsigned long) status));
     switch (status) {
@@ -3822,7 +3810,7 @@ Perl_my_failure_exit(pTHX)
     if (errno & 255)
        STATUS_POSIX_SET(errno);
     else {
-       exitstatus = STATUS_POSIX >> 8; 
+       exitstatus = STATUS_POSIX >> 8;
        if (exitstatus & 255)
            STATUS_POSIX_SET(exitstatus);
        else
@@ -3835,7 +3823,6 @@ Perl_my_failure_exit(pTHX)
 STATIC void
 S_my_exit_jump(pTHX)
 {
-    dTHR;
     register PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
diff --git a/perl.h b/perl.h
index b655e04..6a545e6 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1,6 +1,6 @@
 /*    perl.h
  *
- *    Copyright (c) 1987-2000, Larry Wall
+ *    Copyright (c) 1987-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -183,7 +183,7 @@ class CPerlObj;
 struct perl_thread;
 #    define pTHX       register struct perl_thread *thr
 #    define aTHX       thr
-#    define dTHR       dNOOP
+#    define dTHR       dNOOP /* only backward compatibility */
 #    define dTHXa(a)   pTHX = (struct perl_thread*)a
 #  else
 #    ifndef MULTIPLICITY
@@ -303,7 +303,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
 #endif
 
 #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END
-#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
+#define WITH_THR(s) WITH_THX(s)
 
 /*
  * SOFT_CAST can be used for args to prototyped functions to retain some
@@ -496,12 +496,16 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
 #   include <sys/param.h>
 #endif
 
-
 /* Use all the "standard" definitions? */
 #if defined(STANDARD_C) && defined(I_STDLIB)
 #   include <stdlib.h>
 #endif
 
+/* If this causes problems, set i_unistd=undef in the hint file.  */
+#ifdef I_UNISTD
+#   include <unistd.h>
+#endif
+
 #ifdef PERL_MICRO /* Last chance to export Perl_my_swap */
 #  define MYSWAP
 #endif
@@ -709,10 +713,47 @@ typedef struct perl_mstats perl_mstats_t;
 #endif
 
 #include <errno.h>
-#ifdef HAS_SOCKET
-#   ifdef I_NET_ERRNO
-#     include <net/errno.h>
+
+#if defined(WIN32) && (defined(PERL_OBJECT) || defined(PERL_IMPLICIT_SYS) || defined(PERL_CAPI))
+#  define WIN32SCK_IS_STDSCK           /* don't pull in custom wsock layer */
+#endif
+
+#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
+# include <sys/socket.h>
+# if defined(USE_SOCKS) && defined(I_SOCKS)
+#   if !defined(INCLUDE_PROTOTYPES)
+#       define INCLUDE_PROTOTYPES /* for <socks.h> */
+#       define PERL_SOCKS_NEED_PROTOTYPES
+#   endif
+#   ifdef USE_THREADS
+#       define PERL_USE_THREADS /* store our value */
+#       undef USE_THREADS
 #   endif
+#   include <socks.h>
+#   ifdef USE_THREADS
+#       undef USE_THREADS /* socks.h does this on its own */
+#   endif
+#   ifdef PERL_USE_THREADS
+#       define USE_THREADS /* restore our value */
+#       undef PERL_USE_THREADS
+#   endif
+#   ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
+#       undef INCLUDE_PROTOTYPES
+#       undef PERL_SOCKS_NEED_PROTOTYPES
+#   endif
+# endif 
+# ifdef I_NETDB
+#  include <netdb.h>
+# endif
+# ifndef ENOTSOCK
+#  ifdef I_NET_ERRNO
+#   include <net/errno.h>
+#  endif
+# endif
+#endif
+
+#ifdef SETERRNO
+# undef SETERRNO  /* SOCKS might have defined this */
 #endif
 
 #ifdef VMS
@@ -1043,6 +1084,11 @@ typedef UVTYPE UV;
 #define IV_DIG (BIT_DIGITS(IVSIZE * 8))
 #define UV_DIG (BIT_DIGITS(UVSIZE * 8))
 
+/* We like our integers to stay integers. */
+#ifndef NO_PERL_PRESERVE_IVUV
+#define PERL_PRESERVE_IVUV
+#endif
+
 /*   
  *  The macros INT2PTR and NUM2PTR are (despite their names)
  *  bi-directional: they will convert int/float to or from pointers.
@@ -1075,6 +1121,9 @@ typedef UVTYPE UV;
 #endif
   
 #ifdef USE_LONG_DOUBLE
+#  if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE
+#      define LONG_DOUBLE_EQUALS_DOUBLE
+#  endif
 #  if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE))
 #     undef USE_LONG_DOUBLE /* Ouch! */
 #  endif
@@ -1440,6 +1489,7 @@ struct perl_mstats {
     UV *bucket_available_size;
     UV nbuckets;
 };
+struct RExC_state_t;
 
 typedef MEM_SIZE STRLEN;
 
@@ -1626,6 +1676,9 @@ typedef struct ptr_tbl PTR_TBL_t;
 #         else
 #           if defined(MACOS_TRADITIONAL)
 #             include "macos/macish.h"
+#            ifndef NO_ENVIRON_ARRAY
+#               define NO_ENVIRON_ARRAY
+#             endif
 #           else
 #             include "unixish.h"
 #           endif
@@ -2105,6 +2158,7 @@ Gid_t getegid (void);
 #  else
 #    define DEBUG_S(a)
 #  endif
+#define DEBUG_T(a) if (PL_debug & (1<<17))     a
 #else
 #define DEB(a)
 #define DEBUG(a)
@@ -2125,6 +2179,7 @@ Gid_t getegid (void);
 #define DEBUG_X(a)
 #define DEBUG_D(a)
 #define DEBUG_S(a)
+#define DEBUG_T(a)
 #endif
 #define YYMAXDEPTH 300
 
@@ -2195,8 +2250,12 @@ char *crypt (const char*, const char*);
 #    ifndef getenv
 char *getenv (const char*);
 #    endif /* !getenv */
-#    if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO)
+#    if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux)
+#      ifdef _FILE_OFFSET_BITS
+#        if _FILE_OFFSET_BITS == 64
 Off_t lseek (int,Off_t,int);
+#        endif
+#      endif
 #    endif
 #  endif /* !DONT_DECLARE_STD */
 char *getlogin (void);
@@ -2639,6 +2698,7 @@ enum {            /* pass one of these to get_vtbl */
 
 #define HINT_FILETEST_ACCESS   0x00400000
 #define HINT_UTF8              0x00800000
+#define HINT_UTF8_DISTINCT     0x01000000
 
 /* Various states of an input record separator SV (rs, nrs) */
 #define RsSNARF(sv)   (! SvOK(sv))
@@ -2658,10 +2718,6 @@ typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv,
 typedef SV*    (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog);
 typedef void   (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r);
 
-#ifdef USE_PURE_BISON
-int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp);
-#endif
-
 typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*);
 typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*);
 typedef void (*SVFUNC_t) (pTHXo_ SV*);
@@ -3005,46 +3061,53 @@ enum {
   to_sv_amg,   to_av_amg,
   to_hv_amg,   to_gv_amg,
   to_cv_amg,   iter_amg,    
-  max_amg_code
+  DESTROY_amg, max_amg_code
   /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };
 
 #define NofAMmeth max_amg_code
+#define AMG_id2name(id) ((char*)PL_AMG_names[id]+1)
 
 #ifdef DOINIT
 EXTCONST char * PL_AMG_names[NofAMmeth] = {
-  "fallback",  "abs",                  /* "fallback" should be the first. */
-  "bool",      "nomethod",
-  "\"\"",      "0+",
-  "+",         "+=",
-  "-",         "-=",
-  "*",         "*=",
-  "/",         "/=",
-  "%",         "%=",
-  "**",                "**=",
-  "<<",                "<<=",
-  ">>",                ">>=",
-  "&",         "&=",
-  "|",         "|=",
-  "^",         "^=",
-  "<",         "<=",
-  ">",         ">=",
-  "==",                "!=",
-  "<=>",       "cmp",
-  "lt",                "le",
-  "gt",                "ge",
-  "eq",                "ne",
-  "!",         "~",
-  "++",                "--",
-  "atan2",     "cos",
-  "sin",       "exp",
-  "log",       "sqrt",
-  "x",         "x=",
-  ".",         ".=",
-  "=",         "neg",
-  "${}",       "@{}",
-  "%{}",       "*{}",
-  "&{}",       "<>",
+  /* Names kept in the symbol table.  fallback => "()", the rest has
+     "(" prepended.  The only other place in perl which knows about
+     this convention is AMG_id2name (used for debugging output and
+     'nomethod' only), the only other place which has it hardwired is
+     overload.pm.  */
+  "()",                "(abs",                 /* "fallback" should be the first. */
+  "(bool",     "(nomethod",
+  "(\"\"",     "(0+",
+  "(+",                "(+=",
+  "(-",                "(-=",
+  "(*",                "(*=",
+  "(/",                "(/=",
+  "(%",                "(%=",
+  "(**",       "(**=",
+  "(<<",       "(<<=",
+  "(>>",       "(>>=",
+  "(&",                "(&=",
+  "(|",                "(|=",
+  "(^",                "(^=",
+  "(<",                "(<=",
+  "(>",                "(>=",
+  "(==",       "(!=",
+  "(<=>",      "(cmp",
+  "(lt",       "(le",
+  "(gt",       "(ge",
+  "(eq",       "(ne",
+  "(!",                "(~",
+  "(++",       "(--",
+  "(atan2",    "(cos",
+  "(sin",      "(exp",
+  "(log",      "(sqrt",
+  "(x",                "(x=",
+  "(.",                "(.=",
+  "(=",                "(neg",
+  "(${}",      "(@{}",
+  "(%{}",      "(*{}",
+  "(&{}",      "(<>",
+  "DESTROY",
 };
 #else
 EXTCONST char * PL_AMG_names[NofAMmeth];
@@ -3072,10 +3135,15 @@ typedef struct am_table_short AMTS;
 #define AMGfallYES     3
 
 #define AMTf_AMAGIC            1
+#define AMTf_OVERLOADED                2
 #define AMT_AMAGIC(amt)                ((amt)->flags & AMTf_AMAGIC)
 #define AMT_AMAGIC_on(amt)     ((amt)->flags |= AMTf_AMAGIC)
 #define AMT_AMAGIC_off(amt)    ((amt)->flags &= ~AMTf_AMAGIC)
+#define AMT_OVERLOADED(amt)    ((amt)->flags & AMTf_OVERLOADED)
+#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED)
+#define AMT_OVERLOADED_off(amt)        ((amt)->flags &= ~AMTf_OVERLOADED)
 
+#define StashHANDLER(stash,meth)       gv_handler((stash),CAT2(meth,_amg))
 
 /*
  * some compilers like to redefine cos et alia as faster
@@ -3140,16 +3208,10 @@ typedef struct am_table_short AMTS;
 #ifdef USE_LOCALE_NUMERIC
 
 #define SET_NUMERIC_STANDARD() \
-    STMT_START {                               \
-       if (! PL_numeric_standard)              \
-           set_numeric_standard();             \
-    } STMT_END
+       set_numeric_standard();
 
 #define SET_NUMERIC_LOCAL() \
-    STMT_START {                               \
-       if (! PL_numeric_local)                 \
-           set_numeric_local();                \
-    } STMT_END
+       set_numeric_local();
 
 #define IS_NUMERIC_RADIX(c)    \
        ((PL_hints & HINT_LOCALE) && \
@@ -3157,11 +3219,11 @@ typedef struct am_table_short AMTS;
 
 #define STORE_NUMERIC_LOCAL_SET_STANDARD() \
        bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \
-       if (!was_local) SET_NUMERIC_STANDARD();
+       if (was_local) SET_NUMERIC_STANDARD();
 
 #define STORE_NUMERIC_STANDARD_SET_LOCAL() \
-       bool was_standard = !(PL_hints & HINT_LOCALE) || PL_numeric_standard; \
-       if (!was_standard) SET_NUMERIC_LOCAL();
+       bool was_standard = (PL_hints & HINT_LOCALE) && PL_numeric_standard; \
+       if (was_standard) SET_NUMERIC_LOCAL();
 
 #define RESTORE_NUMERIC_LOCAL() \
        if (was_local) SET_NUMERIC_LOCAL();
@@ -3191,6 +3253,9 @@ typedef struct am_table_short AMTS;
 #   if !defined(Strtol) && defined(HAS_STRTOLL)
 #       define Strtol  strtoll
 #   endif
+#    if !defined(Strtol) && defined(HAS_STRTOQ)
+#       define Strtol  strtoq
+#    endif
 /* is there atoq() anywhere? */
 #endif
 #if !defined(Strtol) && defined(HAS_STRTOL)
@@ -3402,6 +3467,10 @@ typedef struct am_table_short AMTS;
 #   include <libutil.h>                /* setproctitle() in some FreeBSDs */
 #endif
 
+#ifndef EXEC_ARGV_CAST
+#define EXEC_ARGV_CAST(x) x
+#endif
+
 /* and finally... */
 #define PERL_PATCHLEVEL_H_IMPLICIT
 #include "patchlevel.h"
index 39a13ba..bb32970 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -85,6 +85,13 @@ Perl_Gv_AMupdate(pTHXo_ HV* stash)
     return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash);
 }
 
+#undef  Perl_gv_handler
+CV*
+Perl_gv_handler(pTHXo_ HV* stash, I32 id)
+{
+    return ((CPerlObj*)pPerl)->Perl_gv_handler(stash, id);
+}
+
 #undef  Perl_apply_attrs_string
 void
 Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len)
@@ -936,7 +943,7 @@ Perl_hv_delayfree_ent(pTHXo_ HV* hv, HE* entry)
 
 #undef  Perl_hv_delete
 SV*
-Perl_hv_delete(pTHXo_ HV* tb, const char* key, U32 klen, I32 flags)
+Perl_hv_delete(pTHXo_ HV* tb, const char* key, I32 klen, I32 flags)
 {
     return ((CPerlObj*)pPerl)->Perl_hv_delete(tb, key, klen, flags);
 }
@@ -950,7 +957,7 @@ Perl_hv_delete_ent(pTHXo_ HV* tb, SV* key, I32 flags, U32 hash)
 
 #undef  Perl_hv_exists
 bool
-Perl_hv_exists(pTHXo_ HV* tb, const char* key, U32 klen)
+Perl_hv_exists(pTHXo_ HV* tb, const char* key, I32 klen)
 {
     return ((CPerlObj*)pPerl)->Perl_hv_exists(tb, key, klen);
 }
@@ -964,7 +971,7 @@ Perl_hv_exists_ent(pTHXo_ HV* tb, SV* key, U32 hash)
 
 #undef  Perl_hv_fetch
 SV**
-Perl_hv_fetch(pTHXo_ HV* tb, const char* key, U32 klen, I32 lval)
+Perl_hv_fetch(pTHXo_ HV* tb, const char* key, I32 klen, I32 lval)
 {
     return ((CPerlObj*)pPerl)->Perl_hv_fetch(tb, key, klen, lval);
 }
@@ -1041,7 +1048,7 @@ Perl_hv_magic(pTHXo_ HV* hv, GV* gv, int how)
 
 #undef  Perl_hv_store
 SV**
-Perl_hv_store(pTHXo_ HV* tb, const char* key, U32 klen, SV* val, U32 hash)
+Perl_hv_store(pTHXo_ HV* tb, const char* key, I32 klen, SV* val, U32 hash)
 {
     return ((CPerlObj*)pPerl)->Perl_hv_store(tb, key, klen, val, hash);
 }
@@ -1327,7 +1334,7 @@ Perl_to_uni_lower_lc(pTHXo_ U32 c)
 }
 
 #undef  Perl_is_utf8_char
-int
+STRLEN
 Perl_is_utf8_char(pTHXo_ U8 *p)
 {
     return ((CPerlObj*)pPerl)->Perl_is_utf8_char(p);
@@ -1743,10 +1750,10 @@ Perl_newCONDOP(pTHXo_ I32 flags, OP* expr, OP* trueop, OP* falseop)
 }
 
 #undef  Perl_newCONSTSUB
-void
+CV*
 Perl_newCONSTSUB(pTHXo_ HV* stash, char* name, SV* sv)
 {
-    ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv);
+    return ((CPerlObj*)pPerl)->Perl_newCONSTSUB(stash, name, sv);
 }
 
 #undef  Perl_newFORM
@@ -2017,7 +2024,7 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len)
 
 #undef  Perl_newSVpvn_share
 SV*
-Perl_newSVpvn_share(pTHXo_ const char* s, STRLEN len, U32 hash)
+Perl_newSVpvn_share(pTHXo_ const char* s, I32 len, U32 hash)
 {
     return ((CPerlObj*)pPerl)->Perl_newSVpvn_share(s, len, hash);
 }
@@ -2237,21 +2244,21 @@ Perl_init_i18nl14n(pTHXo_ int printwarn)
 
 #undef  Perl_new_collate
 void
-Perl_new_collate(pTHXo_ const char* newcoll)
+Perl_new_collate(pTHXo_ char* newcoll)
 {
     ((CPerlObj*)pPerl)->Perl_new_collate(newcoll);
 }
 
 #undef  Perl_new_ctype
 void
-Perl_new_ctype(pTHXo_ const char* newctype)
+Perl_new_ctype(pTHXo_ char* newctype)
 {
     ((CPerlObj*)pPerl)->Perl_new_ctype(newctype);
 }
 
 #undef  Perl_new_numeric
 void
-Perl_new_numeric(pTHXo_ const char* newcoll)
+Perl_new_numeric(pTHXo_ char* newcoll)
 {
     ((CPerlObj*)pPerl)->Perl_new_numeric(newcoll);
 }
@@ -2312,6 +2319,13 @@ Perl_regdump(pTHXo_ regexp* r)
     ((CPerlObj*)pPerl)->Perl_regdump(r);
 }
 
+#undef  Perl_regclass_swash
+SV*
+Perl_regclass_swash(pTHXo_ struct regnode *n, bool doinit, SV **initsvp)
+{
+    return ((CPerlObj*)pPerl)->Perl_regclass_swash(n, doinit, initsvp);
+}
+
 #undef  Perl_pregexec
 I32
 Perl_pregexec(pTHXo_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave)
@@ -2615,6 +2629,13 @@ Perl_save_re_context(pTHXo)
     ((CPerlObj*)pPerl)->Perl_save_re_context();
 }
 
+#undef  Perl_save_padsv
+void
+Perl_save_padsv(pTHXo_ PADOFFSET off)
+{
+    ((CPerlObj*)pPerl)->Perl_save_padsv(off);
+}
+
 #undef  Perl_save_sptr
 void
 Perl_save_sptr(pTHXo_ SV** sptr)
@@ -2638,28 +2659,28 @@ Perl_save_threadsv(pTHXo_ PADOFFSET i)
 
 #undef  Perl_scan_bin
 NV
-Perl_scan_bin(pTHXo_ char* start, I32 len, I32* retlen)
+Perl_scan_bin(pTHXo_ char* start, STRLEN len, STRLEN* retlen)
 {
     return ((CPerlObj*)pPerl)->Perl_scan_bin(start, len, retlen);
 }
 
 #undef  Perl_scan_hex
 NV
-Perl_scan_hex(pTHXo_ char* start, I32 len, I32* retlen)
+Perl_scan_hex(pTHXo_ char* start, STRLEN len, STRLEN* retlen)
 {
     return ((CPerlObj*)pPerl)->Perl_scan_hex(start, len, retlen);
 }
 
 #undef  Perl_scan_num
 char*
-Perl_scan_num(pTHXo_ char* s)
+Perl_scan_num(pTHXo_ char* s, YYSTYPE *lvalp)
 {
-    return ((CPerlObj*)pPerl)->Perl_scan_num(s);
+    return ((CPerlObj*)pPerl)->Perl_scan_num(s, lvalp);
 }
 
 #undef  Perl_scan_oct
 NV
-Perl_scan_oct(pTHXo_ char* start, I32 len, I32* retlen)
+Perl_scan_oct(pTHXo_ char* start, STRLEN len, STRLEN* retlen)
 {
     return ((CPerlObj*)pPerl)->Perl_scan_oct(start, len, retlen);
 }
@@ -3220,6 +3241,13 @@ Perl_sv_unref(pTHXo_ SV* sv)
     ((CPerlObj*)pPerl)->Perl_sv_unref(sv);
 }
 
+#undef  Perl_sv_unref_flags
+void
+Perl_sv_unref_flags(pTHXo_ SV* sv, U32 flags)
+{
+    ((CPerlObj*)pPerl)->Perl_sv_unref_flags(sv, flags);
+}
+
 #undef  Perl_sv_untaint
 void
 Perl_sv_untaint(pTHXo_ SV* sv)
@@ -3350,8 +3378,15 @@ Perl_utf16_to_utf8_reversed(pTHXo_ U8* p, U8 *d, I32 bytelen, I32 *newlen)
     return ((CPerlObj*)pPerl)->Perl_utf16_to_utf8_reversed(p, d, bytelen, newlen);
 }
 
+#undef  Perl_utf8_length
+STRLEN
+Perl_utf8_length(pTHXo_ U8* s, U8 *e)
+{
+    return ((CPerlObj*)pPerl)->Perl_utf8_length(s, e);
+}
+
 #undef  Perl_utf8_distance
-I32
+IV
 Perl_utf8_distance(pTHXo_ U8 *a, U8 *b)
 {
     return ((CPerlObj*)pPerl)->Perl_utf8_distance(a, b);
@@ -3378,18 +3413,18 @@ Perl_bytes_to_utf8(pTHXo_ U8 *s, STRLEN *len)
     return ((CPerlObj*)pPerl)->Perl_bytes_to_utf8(s, len);
 }
 
-#undef  Perl_utf8_to_uv
+#undef  Perl_utf8_to_uv_simple
 UV
-Perl_utf8_to_uv(pTHXo_ U8 *s, I32* retlen)
+Perl_utf8_to_uv_simple(pTHXo_ U8 *s, STRLEN* retlen)
 {
-    return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, retlen);
+    return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_simple(s, retlen);
 }
 
-#undef  Perl_utf8_to_uv_chk
+#undef  Perl_utf8_to_uv
 UV
-Perl_utf8_to_uv_chk(pTHXo_ U8 *s, I32* retlen, bool checking)
+Perl_utf8_to_uv(pTHXo_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
 {
-    return ((CPerlObj*)pPerl)->Perl_utf8_to_uv_chk(s, retlen, checking);
+    return ((CPerlObj*)pPerl)->Perl_utf8_to_uv(s, curlen, retlen, flags);
 }
 
 #undef  Perl_uv_to_utf8
@@ -3439,7 +3474,7 @@ Perl_whichsig(pTHXo_ char* sig)
 {
     return ((CPerlObj*)pPerl)->Perl_whichsig(sig);
 }
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
 #else
 #endif
 #if defined(MYMALLOC)
@@ -3854,6 +3889,13 @@ Perl_sv_force_normal(pTHXo_ SV *sv)
     ((CPerlObj*)pPerl)->Perl_sv_force_normal(sv);
 }
 
+#undef  Perl_sv_force_normal_flags
+void
+Perl_sv_force_normal_flags(pTHXo_ SV *sv, U32 flags)
+{
+    ((CPerlObj*)pPerl)->Perl_sv_force_normal_flags(sv, flags);
+}
+
 #undef  Perl_tmps_grow
 void
 Perl_tmps_grow(pTHXo_ I32 n)
@@ -4068,6 +4110,8 @@ Perl_sys_intern_init(pTHXo)
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #  if defined(DEBUGGING)
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+#  endif
 #endif
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
 #if 0
index 2d210ee..a856dde 100755 (executable)
--- a/perlapi.h
+++ b/perlapi.h
@@ -420,10 +420,8 @@ START_EXTERN_C
 #define PL_origenviron         (*Perl_Iorigenviron_ptr(aTHXo))
 #undef  PL_origfilename
 #define PL_origfilename                (*Perl_Iorigfilename_ptr(aTHXo))
-#undef  PL_ors
-#define PL_ors                 (*Perl_Iors_ptr(aTHXo))
-#undef  PL_orslen
-#define PL_orslen              (*Perl_Iorslen_ptr(aTHXo))
+#undef  PL_ors_sv
+#define PL_ors_sv              (*Perl_Iors_sv_ptr(aTHXo))
 #undef  PL_osname
 #define PL_osname              (*Perl_Iosname_ptr(aTHXo))
 #undef  PL_pad_reset_pending
@@ -712,10 +710,8 @@ START_EXTERN_C
 #define PL_na                  (*Perl_Tna_ptr(aTHXo))
 #undef  PL_nrs
 #define PL_nrs                 (*Perl_Tnrs_ptr(aTHXo))
-#undef  PL_ofs
-#define PL_ofs                 (*Perl_Tofs_ptr(aTHXo))
-#undef  PL_ofslen
-#define PL_ofslen              (*Perl_Tofslen_ptr(aTHXo))
+#undef  PL_ofs_sv
+#define PL_ofs_sv              (*Perl_Tofs_sv_ptr(aTHXo))
 #undef  PL_op
 #define PL_op                  (*Perl_Top_ptr(aTHXo))
 #undef  PL_opsave
index a88daa5..72efa36 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -7,7 +7,6 @@
  *
  */
 
-
 #define VOIDUSED 1
 #ifdef PERL_MICRO
 #   include "uconfig.h"
 #   include "config.h"
 #endif
 
-#define PERLIO_NOT_STDIO 0 
+#define PERLIO_NOT_STDIO 0
 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
-#define PerlIO FILE
+/* #define PerlIO FILE */
 #endif
 /*
- * This file provides those parts of PerlIO abstraction 
- * which are not #defined in iperlsys.h.
- * Which these are depends on various Configure #ifdef's 
+ * This file provides those parts of PerlIO abstraction
+ * which are not #defined in perlio.h.
+ * Which these are depends on various Configure #ifdef's
  */
 
 #include "EXTERN.h"
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
-#if !defined(PERL_IMPLICIT_SYS)
+#undef PerlMemShared_calloc
+#define PerlMemShared_calloc(x,y) calloc(x,y)
+#undef PerlMemShared_free
+#define PerlMemShared_free(x) free(x)
+
+int
+perlsio_binmode(FILE *fp, int iotype, int mode)
+{
+/* This used to be contents of do_binmode in doio.c */
+#ifdef DOSISH
+#  if defined(atarist) || defined(__MINT__)
+    if (!fflush(fp)) {
+       if (mode & O_BINARY)
+           ((FILE*)fp)->_flag |= _IOBIN;
+       else
+           ((FILE*)fp)->_flag &= ~ _IOBIN;
+       return 1;
+    }
+    return 0;
+#  else
+    dTHX;
+    if (PerlLIO_setmode(fileno(fp), mode) != -1) {
+#    if defined(WIN32) && defined(__BORLANDC__)
+       /* The translation mode of the stream is maintained independent
+        * of the translation mode of the fd in the Borland RTL (heavy
+        * digging through their runtime sources reveal).  User has to
+        * set the mode explicitly for the stream (though they don't
+        * document this anywhere). GSAR 97-5-24
+        */
+       fseek(fp,0L,0);
+       if (mode & O_BINARY)
+           fp->flags |= _F_BIN;
+       else
+           fp->flags &= ~ _F_BIN;
+#    endif
+       return 1;
+    }
+    else
+       return 0;
+#  endif
+#else
+#  if defined(USEMYBINMODE)
+    if (my_binmode(fp, iotype, mode) != FALSE)
+       return 1;
+    else
+       return 0;
+#  else
+    return 1;
+#  endif
+#endif
+}
+
+#ifndef PERLIO_LAYERS
+int
+PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
+{
+ if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
+  {
+   return 0;
+  }
+ Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
+ /* NOTREACHED */
+ return -1;
+}
+
+int
+PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
+{
+ return perlsio_binmode(fp,iotype,mode);
+}
+
+#endif
+
 
-#ifdef PERLIO_IS_STDIO 
+#ifdef PERLIO_IS_STDIO
 
 void
 PerlIO_init(void)
 {
- /* Does nothing (yet) except force this file to be included 
+ /* Does nothing (yet) except force this file to be included
     in perl binary. That allows this file to force inclusion
-    of other functions that may be required by loadable 
-    extensions e.g. for FileHandle::tmpfile  
+    of other functions that may be required by loadable
+    extensions e.g. for FileHandle::tmpfile
  */
 }
 
@@ -57,7 +128,7 @@ PerlIO_tmpfile(void)
 #undef HAS_FSETPOS
 #undef HAS_FGETPOS
 
-/* This section is just to make sure these functions 
+/* This section is just to make sure these functions
    get pulled in from libsfio.a
 */
 
@@ -71,364 +142,2992 @@ PerlIO_tmpfile(void)
 void
 PerlIO_init(void)
 {
- /* Force this file to be included  in perl binary. Which allows 
-  *  this file to force inclusion  of other functions that may be 
-  *  required by loadable  extensions e.g. for FileHandle::tmpfile  
+ /* Force this file to be included  in perl binary. Which allows
+  *  this file to force inclusion  of other functions that may be
+  *  required by loadable  extensions e.g. for FileHandle::tmpfile
   */
 
  /* Hack
   * sfio does its own 'autoflush' on stdout in common cases.
-  * Flush results in a lot of lseek()s to regular files and 
+  * Flush results in a lot of lseek()s to regular files and
   * lot of small writes to pipes.
   */
  sfset(sfstdout,SF_SHARE,0);
 }
 
 #else /* USE_SFIO */
+/*======================================================================================*/
+/* Implement all the PerlIO interface ourselves.
+ */
 
-/* Implement all the PerlIO interface using stdio. 
-   - this should be only file to include <stdio.h>
-*/
+#include "perliol.h"
 
-#undef PerlIO_stderr
-PerlIO *
-PerlIO_stderr(void)
+/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_MMAP
+#include <sys/mman.h>
+#endif
+
+#include "XSUB.h"
+
+void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
+
+void
+PerlIO_debug(const char *fmt,...)
 {
- return (PerlIO *) stderr;
+ dTHX;
+ static int dbg = 0;
+ va_list ap;
+ va_start(ap,fmt);
+ if (!dbg)
+  {
+   char *s = PerlEnv_getenv("PERLIO_DEBUG");
+   if (s && *s)
+    dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
+   else
+    dbg = -1;
+  }
+ if (dbg > 0)
+  {
+   dTHX;
+   SV *sv = newSVpvn("",0);
+   char *s;
+   STRLEN len;
+   s = CopFILE(PL_curcop);
+   if (!s)
+    s = "(none)";
+   Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
+   Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
+
+   s = SvPV(sv,len);
+   PerlLIO_write(dbg,s,len);
+   SvREFCNT_dec(sv);
+  }
+ va_end(ap);
 }
 
-#undef PerlIO_stdin
+/*--------------------------------------------------------------------------------------*/
+
+/* Inner level routines */
+
+/* Table of pointers to the PerlIO structs (malloc'ed) */
+PerlIO *_perlio      = NULL;
+#define PERLIO_TABLE_SIZE 64
+
 PerlIO *
-PerlIO_stdin(void)
+PerlIO_allocate(pTHX)
 {
- return (PerlIO *) stdin;
+ /* Find a free slot in the table, allocating new table as necessary */
+ PerlIO **last;
+ PerlIO *f;
+ last = &_perlio;
+ while ((f = *last))
+  {
+   int i;
+   last = (PerlIO **)(f);
+   for (i=1; i < PERLIO_TABLE_SIZE; i++)
+    {
+     if (!*++f)
+      {
+       return f;
+      }
+    }
+  }
+ f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
+ if (!f)
+  {
+   return NULL;
+  }
+ *last = f;
+ return f+1;
 }
 
-#undef PerlIO_stdout
-PerlIO *
-PerlIO_stdout(void)
+void
+PerlIO_cleantable(pTHX_ PerlIO **tablep)
+{
+ PerlIO *table = *tablep;
+ if (table)
+  {
+   int i;
+   PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
+   for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
+    {
+     PerlIO *f = table+i;
+     if (*f)
+      {
+       PerlIO_close(f);
+      }
+    }
+   PerlMemShared_free(table);
+   *tablep = NULL;
+  }
+}
+
+HV *PerlIO_layer_hv;
+AV *PerlIO_layer_av;
+
+void
+PerlIO_cleanup()
 {
- return (PerlIO *) stdout;
+ dTHX;
+ PerlIO_cleantable(aTHX_ &_perlio);
 }
 
-#undef PerlIO_fast_gets
-int 
-PerlIO_fast_gets(PerlIO *f)
+void
+PerlIO_pop(PerlIO *f)
 {
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
- return 1;
-#else
+ dTHX;
+ PerlIOl *l = *f;
+ if (l)
+  {
+   PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
+   (*l->tab->Popped)(f);
+   *f = l->next;
+   PerlMemShared_free(l);
+  }
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* XS Interface for perl code */
+
+XS(XS_perlio_import)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+XS(XS_perlio_unimport)
+{
+ dXSARGS;
+ GV *gv = CvGV(cv);
+ char *s = GvNAME(gv);
+ STRLEN l = GvNAMELEN(gv);
+ PerlIO_debug("%.*s\n",(int) l,s);
+ XSRETURN_EMPTY;
+}
+
+SV *
+PerlIO_find_layer(const char *name, STRLEN len)
+{
+ dTHX;
+ SV **svp;
+ SV *sv;
+ if ((SSize_t) len <= 0)
+  len = strlen(name);
+ svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
+ if (svp && (sv = *svp) && SvROK(sv))
+  return *svp;
+ return NULL;
+}
+
+
+static int
+perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
+{
+ if (SvROK(sv))
+  {
+   IO *io = GvIOn((GV *)SvRV(sv));
+   PerlIO *ifp = IoIFP(io);
+   PerlIO *ofp = IoOFP(io);
+   AV *av = (AV *) mg->mg_obj;
+   Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
+  }
  return 0;
-#endif
 }
 
-#undef PerlIO_has_cntptr
-int 
-PerlIO_has_cntptr(PerlIO *f)
+static int
+perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 {
-#if defined(USE_STDIO_PTR)
- return 1;
-#else
+ if (SvROK(sv))
+  {
+   IO *io = GvIOn((GV *)SvRV(sv));
+   PerlIO *ifp = IoIFP(io);
+   PerlIO *ofp = IoOFP(io);
+   AV *av = (AV *) mg->mg_obj;
+   Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
+  }
  return 0;
-#endif
 }
 
-#undef PerlIO_canset_cnt
-int 
-PerlIO_canset_cnt(PerlIO *f)
+static int
+perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 {
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- return 1;
-#else
+ Perl_warn(aTHX_ "clear %"SVf,sv);
  return 0;
-#endif
 }
 
-#undef PerlIO_set_cnt
+static int
+perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
+{
+ Perl_warn(aTHX_ "free %"SVf,sv);
+ return 0;
+}
+
+MGVTBL perlio_vtab = {
+ perlio_mg_get,
+ perlio_mg_set,
+ NULL, /* len */
+ NULL,
+ perlio_mg_free
+};
+
+XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
+{
+ dXSARGS;
+ SV *sv    = SvRV(ST(1));
+ AV *av    = newAV();
+ MAGIC *mg;
+ int count = 0;
+ int i;
+ sv_magic(sv, (SV *)av, '~', NULL, 0);
+ SvRMAGICAL_off(sv);
+ mg = mg_find(sv,'~');
+ mg->mg_virtual = &perlio_vtab;
+ mg_magical(sv);
+ Perl_warn(aTHX_ "attrib %"SVf,sv);
+ for (i=2; i < items; i++)
+  {
+   STRLEN len;
+   const char *name = SvPV(ST(i),len);
+   SV *layer  = PerlIO_find_layer(name,len);
+   if (layer)
+    {
+     av_push(av,SvREFCNT_inc(layer));
+    }
+   else
+    {
+     ST(count) = ST(i);
+     count++;
+    }
+  }
+ SvREFCNT_dec(av);
+ XSRETURN(count);
+}
+
 void
-PerlIO_set_cnt(PerlIO *f, int cnt)
+PerlIO_define_layer(PerlIO_funcs *tab)
 {
  dTHX;
- if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
-  Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- FILE_cnt(f) = cnt;
-#else
- Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
+ HV *stash = gv_stashpv("perlio::Layer", TRUE);
+ SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
+ hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
+}
+
+PerlIO_funcs *
+PerlIO_default_layer(I32 n)
+{
+ dTHX;
+ SV **svp;
+ SV *layer;
+ PerlIO_funcs *tab = &PerlIO_stdio;
+ int len;
+ if (!PerlIO_layer_hv)
+  {
+   const char *s  = PerlEnv_getenv("PERLIO");
+   newXS("perlio::import",XS_perlio_import,__FILE__);
+   newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
+#if 0
+   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+#endif
+   PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
+   PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
+   PerlIO_define_layer(&PerlIO_unix);
+   PerlIO_define_layer(&PerlIO_perlio);
+   PerlIO_define_layer(&PerlIO_stdio);
+   PerlIO_define_layer(&PerlIO_crlf);
+#ifdef HAS_MMAP
+   PerlIO_define_layer(&PerlIO_mmap);
 #endif
+   av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
+   if (s)
+    {
+     while (*s)
+      {
+       while (*s && isSPACE((unsigned char)*s))
+        s++;
+       if (*s)
+        {
+         const char *e = s;
+         SV *layer;
+         while (*e && !isSPACE((unsigned char)*e))
+          e++;
+         if (*s == ':')
+          s++;
+         layer = PerlIO_find_layer(s,e-s);
+         if (layer)
+          {
+           PerlIO_debug("Pushing %.*s\n",(e-s),s);
+           av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
+          }
+         else
+          Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
+         s = e;
+        }
+      }
+    }
+  }
+ len  = av_len(PerlIO_layer_av);
+ if (len < 1)
+  {
+   if (O_BINARY != O_TEXT)
+    {
+     av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
+    }
+   else
+    {
+     if (PerlIO_stdio.Set_ptrcnt)
+      {
+       av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
+      }
+     else
+      {
+       av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
+      }
+    }
+   len  = av_len(PerlIO_layer_av);
+  }
+ if (n < 0)
+  n += len+1;
+ svp = av_fetch(PerlIO_layer_av,n,0);
+ if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
+  {
+   tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
+  }
+ /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
+ return tab;
+}
+
+#define PerlIO_default_top() PerlIO_default_layer(-1)
+#define PerlIO_default_btm() PerlIO_default_layer(0)
+
+void
+PerlIO_stdstreams()
+{
+ if (!_perlio)
+  {
+   dTHX;
+   PerlIO_allocate(aTHX);
+   PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
+   PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
+   PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
+  }
+}
+
+PerlIO *
+PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
+{
+ dTHX;
+ PerlIOl *l = NULL;
+ l = PerlMemShared_calloc(tab->size,sizeof(char));
+ if (l)
+  {
+   Zero(l,tab->size,char);
+   l->next = *f;
+   l->tab  = tab;
+   *f      = l;
+   PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
+   if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
+    {
+     PerlIO_pop(f);
+     return NULL;
+    }
+  }
+ return f;
+}
+
+int
+PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
+{
+ if (names)
+  {
+   const char *s = names;
+   while (*s)
+    {
+     while (isSPACE(*s))
+      s++;
+     if (*s == ':')
+      s++;
+     if (*s)
+      {
+       const char *e = s;
+       const char *as = Nullch;
+       const char *ae = Nullch;
+       int count = 0;
+       while (*e && *e != ':' && !isSPACE(*e))
+        {
+         if (*e == '(')
+          {
+           if (!as)
+            as = e;
+           count++;
+          }
+         else if (*e == ')')
+          {
+           if (as && --count == 0)
+            ae = e;
+          }
+         e++;
+        }
+       if (e > s)
+        {
+         if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
+          {
+           /* Pop back to bottom layer */
+           if (PerlIONext(f))
+            {
+             PerlIO_flush(f);
+             while (PerlIONext(f))
+              {
+               PerlIO_pop(f);
+              }
+            }
+          }
+         else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
+          {
+           PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+          }
+         else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
+          {
+           PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+          }
+         else
+          {
+           STRLEN len = ((as) ? as : e)-s;
+           SV *layer = PerlIO_find_layer(s,len);
+           if (layer)
+            {
+             PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+             if (tab)
+              {
+               len = (as) ? (ae-(as++)-1) : 0;
+               if (!PerlIO_push(f,tab,mode,as,len))
+                return -1;
+              }
+            }
+           else
+            Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
+          }
+        }
+       s = e;
+      }
+    }
+  }
+ return 0;
+}
+
+
+
+/*--------------------------------------------------------------------------------------*/
+/* Given the abstraction above the public API functions */
+
+int
+PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
+{
+ PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
+              f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
+ if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
+  {
+   PerlIO *top = f;
+   PerlIOl *l;
+   while (l = *top)
+    {
+     if (PerlIOBase(top)->tab == &PerlIO_crlf)
+      {
+       PerlIO_flush(top);
+       PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
+       break;
+      }
+     top = PerlIONext(top);
+    }
+  }
+ return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
+}
+
+#undef PerlIO__close
+int
+PerlIO__close(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Close)(f);
+}
+
+#undef PerlIO_fdupopen
+PerlIO *
+PerlIO_fdupopen(pTHX_ PerlIO *f)
+{
+ char buf[8];
+ int fd = PerlLIO_dup(PerlIO_fileno(f));
+ PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
+ if (new)
+  {
+   Off_t posn = PerlIO_tell(f);
+   PerlIO_seek(new,posn,SEEK_SET);
+  }
+ return new;
+}
+
+#undef PerlIO_close
+int
+PerlIO_close(PerlIO *f)
+{
+ int code = (*PerlIOBase(f)->tab->Close)(f);
+ while (*f)
+  {
+   PerlIO_pop(f);
+  }
+ return code;
+}
+
+#undef PerlIO_fileno
+int
+PerlIO_fileno(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Fileno)(f);
+}
+
+
+
+#undef PerlIO_fdopen
+PerlIO *
+PerlIO_fdopen(int fd, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+  PerlIO_stdstreams();
+ return (*tab->Fdopen)(tab,fd,mode);
+}
+
+#undef PerlIO_open
+PerlIO *
+PerlIO_open(const char *path, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_top();
+ if (!_perlio)
+  PerlIO_stdstreams();
+ return (*tab->Open)(tab,path,mode);
+}
+
+#undef PerlIO_reopen
+PerlIO *
+PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ if (f)
+  {
+   PerlIO_flush(f);
+   if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
+    {
+     if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
+      return f;
+    }
+   return NULL;
+  }
+ else
+  return PerlIO_open(path,mode);
+}
+
+#undef PerlIO_read
+SSize_t
+PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
+}
+
+#undef PerlIO_unread
+SSize_t
+PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
+}
+
+#undef PerlIO_write
+SSize_t
+PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 }
 
-#undef PerlIO_set_ptrcnt
-void
-PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
+#undef PerlIO_seek
+int
+PerlIO_seek(PerlIO *f, Off_t offset, int whence)
+{
+ return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
+}
+
+#undef PerlIO_tell
+Off_t
+PerlIO_tell(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Tell)(f);
+}
+
+#undef PerlIO_flush
+int
+PerlIO_flush(PerlIO *f)
+{
+ if (f)
+  {
+   return (*PerlIOBase(f)->tab->Flush)(f);
+  }
+ else
+  {
+   PerlIO **table = &_perlio;
+   int code = 0;
+   while ((f = *table))
+    {
+     int i;
+     table = (PerlIO **)(f++);
+     for (i=1; i < PERLIO_TABLE_SIZE; i++)
+      {
+       if (*f && PerlIO_flush(f) != 0)
+        code = -1;
+       f++;
+      }
+    }
+   return code;
+  }
+}
+
+#undef PerlIO_fill
+int
+PerlIO_fill(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Fill)(f);
+}
+
+#undef PerlIO_isutf8
+int
+PerlIO_isutf8(PerlIO *f)
+{
+ return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
+}
+
+#undef PerlIO_eof
+int
+PerlIO_eof(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Eof)(f);
+}
+
+#undef PerlIO_error
+int
+PerlIO_error(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Error)(f);
+}
+
+#undef PerlIO_clearerr
+void
+PerlIO_clearerr(PerlIO *f)
+{
+ if (f && *f)
+  (*PerlIOBase(f)->tab->Clearerr)(f);
+}
+
+#undef PerlIO_setlinebuf
+void
+PerlIO_setlinebuf(PerlIO *f)
+{
+ (*PerlIOBase(f)->tab->Setlinebuf)(f);
+}
+
+#undef PerlIO_has_base
+int
+PerlIO_has_base(PerlIO *f)
+{
+ if (f && *f)
+  {
+   return (PerlIOBase(f)->tab->Get_base != NULL);
+  }
+ return 0;
+}
+
+#undef PerlIO_fast_gets
+int
+PerlIO_fast_gets(PerlIO *f)
+{
+ if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
+  {
+   PerlIO_funcs *tab = PerlIOBase(f)->tab;
+   return (tab->Set_ptrcnt != NULL);
+  }
+ return 0;
+}
+
+#undef PerlIO_has_cntptr
+int
+PerlIO_has_cntptr(PerlIO *f)
+{
+ if (f && *f)
+  {
+   PerlIO_funcs *tab = PerlIOBase(f)->tab;
+   return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
+  }
+ return 0;
+}
+
+#undef PerlIO_canset_cnt
+int
+PerlIO_canset_cnt(PerlIO *f)
+{
+ if (f && *f)
+  {
+   PerlIOl *l = PerlIOBase(f);
+   return (l->tab->Set_ptrcnt != NULL);
+  }
+ return 0;
+}
+
+#undef PerlIO_get_base
+STDCHAR *
+PerlIO_get_base(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Get_base)(f);
+}
+
+#undef PerlIO_get_bufsiz
+int
+PerlIO_get_bufsiz(PerlIO *f)
+{
+ return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
+}
+
+#undef PerlIO_get_ptr
+STDCHAR *
+PerlIO_get_ptr(PerlIO *f)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_ptr == NULL)
+  return NULL;
+ return (*tab->Get_ptr)(f);
+}
+
+#undef PerlIO_get_cnt
+int
+PerlIO_get_cnt(PerlIO *f)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_cnt == NULL)
+  return 0;
+ return (*tab->Get_cnt)(f);
+}
+
+#undef PerlIO_set_cnt
+void
+PerlIO_set_cnt(PerlIO *f,int cnt)
+{
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
+}
+
+#undef PerlIO_set_ptrcnt
+void
+PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
+{
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Set_ptrcnt == NULL)
+  {
+   dTHX;
+   Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
+  }
+ (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* "Methods" of the "base class" */
+
+IV
+PerlIOBase_fileno(PerlIO *f)
+{
+ return PerlIO_fileno(PerlIONext(f));
+}
+
+char *
+PerlIO_modestr(PerlIO *f,char *buf)
+{
+ char *s = buf;
+ IV flags = PerlIOBase(f)->flags;
+ if (flags & PERLIO_F_APPEND)
+  {
+   *s++ = 'a';
+   if (flags & PERLIO_F_CANREAD)
+    {
+     *s++ = '+';
+    }
+  }
+ else if (flags & PERLIO_F_CANREAD)
+  {
+   *s++ = 'r';
+   if (flags & PERLIO_F_CANWRITE)
+    *s++ = '+';
+  }
+ else if (flags & PERLIO_F_CANWRITE)
+  {
+   *s++ = 'w';
+   if (flags & PERLIO_F_CANREAD)
+    {
+     *s++ = '+';
+    }
+  }
+#if O_TEXT != O_BINARY
+ if (!(flags & PERLIO_F_CRLF))
+  *s++ = 'b';
+#endif
+ *s = '\0';
+ return buf;
+}
+
+IV
+PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ PerlIOl *l = PerlIOBase(f);
+ const char *omode = mode;
+ char temp[8];
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
+                PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
+ if (tab->Set_ptrcnt != NULL)
+  l->flags |= PERLIO_F_FASTGETS;
+ if (mode)
+  {
+   switch (*mode++)
+    {
+     case 'r':
+      l->flags |= PERLIO_F_CANREAD;
+      break;
+     case 'a':
+      l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
+      break;
+     case 'w':
+      l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
+      break;
+     default:
+      errno = EINVAL;
+      return -1;
+    }
+   while (*mode)
+    {
+     switch (*mode++)
+      {
+       case '+':
+        l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
+        break;
+       case 'b':
+        l->flags &= ~PERLIO_F_CRLF;
+        break;
+       case 't':
+        l->flags |= PERLIO_F_CRLF;
+        break;
+      default:
+       errno = EINVAL;
+       return -1;
+      }
+    }
+  }
+ else
+  {
+   if (l->next)
+    {
+     l->flags |= l->next->flags &
+                 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
+    }
+  }
+#if 0
+ PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
+              f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
+              l->flags,PerlIO_modestr(f,temp));
+#endif
+ return 0;
+}
+
+IV
+PerlIOBase_popped(PerlIO *f)
+{
+ return 0;
+}
+
+SSize_t
+PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ Off_t old = PerlIO_tell(f);
+ SSize_t done;
+ PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
+ done = PerlIOBuf_unread(f,vbuf,count);
+ PerlIOSelf(f,PerlIOBuf)->posn = old - done;
+ return done;
+}
+
+IV
+PerlIOBase_noop_ok(PerlIO *f)
+{
+ return 0;
+}
+
+IV
+PerlIOBase_noop_fail(PerlIO *f)
+{
+ return -1;
+}
+
+IV
+PerlIOBase_close(PerlIO *f)
+{
+ IV code = 0;
+ PerlIO *n = PerlIONext(f);
+ if (PerlIO_flush(f) != 0)
+  code = -1;
+ if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
+  code = -1;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
+ return code;
+}
+
+IV
+PerlIOBase_eof(PerlIO *f)
+{
+ if (f && *f)
+  {
+   return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
+  }
+ return 1;
+}
+
+IV
+PerlIOBase_error(PerlIO *f)
+{
+ if (f && *f)
+  {
+   return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
+  }
+ return 1;
+}
+
+void
+PerlIOBase_clearerr(PerlIO *f)
+{
+ if (f && *f)
+  {
+   PerlIO *n = PerlIONext(f);
+   PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
+   if (n)
+    PerlIO_clearerr(n);
+  }
+}
+
+void
+PerlIOBase_setlinebuf(PerlIO *f)
+{
+
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* Bottom-most level for UNIX-like case */
+
+typedef struct
+{
+ struct _PerlIO base;       /* The generic part */
+ int           fd;         /* UNIX like file descriptor */
+ int           oflags;     /* open/fcntl flags */
+} PerlIOUnix;
+
+int
+PerlIOUnix_oflags(const char *mode)
+{
+ int oflags = -1;
+ switch(*mode)
+  {
+   case 'r':
+    oflags = O_RDONLY;
+    if (*++mode == '+')
+     {
+      oflags = O_RDWR;
+      mode++;
+     }
+    break;
+
+   case 'w':
+    oflags = O_CREAT|O_TRUNC;
+    if (*++mode == '+')
+     {
+      oflags |= O_RDWR;
+      mode++;
+     }
+    else
+     oflags |= O_WRONLY;
+    break;
+
+   case 'a':
+    oflags = O_CREAT|O_APPEND;
+    if (*++mode == '+')
+     {
+      oflags |= O_RDWR;
+      mode++;
+     }
+    else
+     oflags |= O_WRONLY;
+    break;
+  }
+ if (*mode == 'b')
+  {
+   oflags |=  O_BINARY;
+   oflags &= ~O_TEXT;
+   mode++;
+  }
+ else if (*mode == 't')
+  {
+   oflags |=  O_TEXT;
+   oflags &= ~O_BINARY;
+   mode++;
+  }
+ /* Always open in binary mode */
+ oflags |= O_BINARY;
+ if (*mode || oflags == -1)
+  {
+   errno = EINVAL;
+   oflags = -1;
+  }
+ return oflags;
+}
+
+IV
+PerlIOUnix_fileno(PerlIO *f)
+{
+ return PerlIOSelf(f,PerlIOUnix)->fd;
+}
+
+PerlIO *
+PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ if (*mode == 'I')
+  mode++;
+ if (fd >= 0)
+  {
+   int oflags = PerlIOUnix_oflags(mode);
+   if (oflags != -1)
+    {
+     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
+     s->fd     = fd;
+     s->oflags = oflags;
+     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+    }
+  }
+ return f;
+}
+
+PerlIO *
+PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ int oflags = PerlIOUnix_oflags(mode);
+ if (oflags != -1)
+  {
+   int fd = PerlLIO_open3(path,oflags,0666);
+   if (fd >= 0)
+    {
+     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
+     s->fd     = fd;
+     s->oflags = oflags;
+     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+    }
+  }
+ return f;
+}
+
+int
+PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
+ int oflags = PerlIOUnix_oflags(mode);
+ if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+  (*PerlIOBase(f)->tab->Close)(f);
+ if (oflags != -1)
+  {
+   dTHX;
+   int fd = PerlLIO_open3(path,oflags,0666);
+   if (fd >= 0)
+    {
+     s->fd = fd;
+     s->oflags = oflags;
+     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+     return 0;
+    }
+  }
+ return -1;
+}
+
+SSize_t
+PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+  return 0;
+ while (1)
+  {
+   SSize_t len = PerlLIO_read(fd,vbuf,count);
+   if (len >= 0 || errno != EINTR)
+    {
+     if (len < 0)
+      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+     else if (len == 0 && count != 0)
+      PerlIOBase(f)->flags |= PERLIO_F_EOF;
+     return len;
+    }
+  }
+}
+
+SSize_t
+PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ while (1)
+  {
+   SSize_t len = PerlLIO_write(fd,vbuf,count);
+   if (len >= 0 || errno != EINTR)
+    {
+     if (len < 0)
+      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+     return len;
+    }
+  }
+}
+
+IV
+PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
+{
+ dTHX;
+ Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
+ PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+ return (new == (Off_t) -1) ? -1 : 0;
+}
+
+Off_t
+PerlIOUnix_tell(PerlIO *f)
+{
+ dTHX;
+ Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
+ return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
+}
+
+IV
+PerlIOUnix_close(PerlIO *f)
+{
+ dTHX;
+ int fd = PerlIOSelf(f,PerlIOUnix)->fd;
+ int code = 0;
+ while (PerlLIO_close(fd) != 0)
+  {
+   if (errno != EINTR)
+    {
+     code = -1;
+     break;
+    }
+  }
+ if (code == 0)
+  {
+   PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+  }
+ return code;
+}
+
+PerlIO_funcs PerlIO_unix = {
+ "unix",
+ sizeof(PerlIOUnix),
+ PERLIO_K_RAW,
+ PerlIOUnix_fileno,
+ PerlIOUnix_fdopen,
+ PerlIOUnix_open,
+ PerlIOUnix_reopen,
+ PerlIOBase_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOUnix_read,
+ PerlIOBase_unread,
+ PerlIOUnix_write,
+ PerlIOUnix_seek,
+ PerlIOUnix_tell,
+ PerlIOUnix_close,
+ PerlIOBase_noop_ok,   /* flush */
+ PerlIOBase_noop_fail, /* fill */
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBase_setlinebuf,
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* stdio as a layer */
+
+typedef struct
+{
+ struct _PerlIO        base;
+ FILE *                stdio;      /* The stream */
+} PerlIOStdio;
+
+IV
+PerlIOStdio_fileno(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+char *
+PerlIOStdio_mode(const char *mode,char *tmode)
+{
+ char *ret = tmode;
+ while (*mode)
+  {
+   *tmode++ = *mode++;
+  }
+ if (O_BINARY != O_TEXT)
+  {
+   *tmode++ = 'b';
+  }
+ *tmode = '\0';
+ return ret;
+}
+
+PerlIO *
+PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ int init = 0;
+ char tmode[8];
+ if (*mode == 'I')
+  {
+   init = 1;
+   mode++;
+  }
+ if (fd >= 0)
+  {
+   FILE *stdio = NULL;
+   if (init)
+    {
+     switch(fd)
+      {
+       case 0:
+        stdio = PerlSIO_stdin;
+        break;
+       case 1:
+        stdio = PerlSIO_stdout;
+        break;
+       case 2:
+        stdio = PerlSIO_stderr;
+        break;
+      }
+    }
+   else
+    {
+     stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
+    }
+   if (stdio)
+    {
+     PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
+     s->stdio  = stdio;
+    }
+  }
+ return f;
+}
+
+#undef PerlIO_importFILE
+PerlIO *
+PerlIO_importFILE(FILE *stdio, int fl)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ if (stdio)
+  {
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
+   s->stdio  = stdio;
+  }
+ return f;
+}
+
+PerlIO *
+PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
+{
+ dTHX;
+ PerlIO *f = NULL;
+ FILE *stdio = PerlSIO_fopen(path,mode);
+ if (stdio)
+  {
+   char tmode[8];
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
+                               (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
+                               PerlIOStdio);
+   s->stdio  = stdio;
+  }
+ return f;
+}
+
+int
+PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ dTHX;
+ PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
+ char tmode[8];
+ FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
+ if (!s->stdio)
+  return -1;
+ s->stdio = stdio;
+ return 0;
+}
+
+SSize_t
+PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ dTHX;
+ FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
+ SSize_t got = 0;
+ if (count == 1)
+  {
+   STDCHAR *buf = (STDCHAR *) vbuf;
+   /* Perl is expecting PerlIO_getc() to fill the buffer
+    * Linux's stdio does not do that for fread()
+    */
+   int ch = PerlSIO_fgetc(s);
+   if (ch != EOF)
+    {
+     *buf = ch;
+     got = 1;
+    }
+  }
+ else
+  got = PerlSIO_fread(vbuf,1,count,s);
+ return got;
+}
+
+SSize_t
+PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
+ STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
+ SSize_t unread = 0;
+ while (count > 0)
+  {
+   int ch = *buf-- & 0xff;
+   if (PerlSIO_ungetc(ch,s) != ch)
+    break;
+   unread++;
+   count--;
+  }
+ return unread;
+}
+
+SSize_t
+PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+IV
+PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_fseek(stdio,offset,whence);
+}
+
+Off_t
+PerlIOStdio_tell(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_ftell(stdio);
+}
+
+IV
+PerlIOStdio_close(PerlIO *f)
+{
+ dTHX;
+#ifdef HAS_SOCKET
+ int optval, optlen = sizeof(int);
+#endif
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return(
+#ifdef HAS_SOCKET
+   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
+       PerlSIO_fclose(stdio) :
+       close(PerlIO_fileno(f))
+#else
+   PerlSIO_fclose(stdio)
+#endif
+     );
+
+}
+
+IV
+PerlIOStdio_flush(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
+  {
+   return PerlSIO_fflush(stdio);
+  }
+ else
+  {
+#if 0
+   /* FIXME: This discards ungetc() and pre-read stuff which is
+      not right if this is just a "sync" from a layer above
+      Suspect right design is to do _this_ but not have layer above
+      flush this layer read-to-read
+    */
+   /* Not writeable - sync by attempting a seek */
+   int err = errno;
+   if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
+    errno = err;
+#endif
+  }
+ return 0;
+}
+
+IV
+PerlIOStdio_fill(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ int c;
+ /* fflush()ing read-only streams can cause trouble on some stdio-s */
+ if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+  {
+   if (PerlSIO_fflush(stdio) != 0)
+    return EOF;
+  }
+ c = PerlSIO_fgetc(stdio);
+ if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
+  return EOF;
+ return 0;
+}
+
+IV
+PerlIOStdio_eof(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+IV
+PerlIOStdio_error(PerlIO *f)
+{
+ dTHX;
+ return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+void
+PerlIOStdio_clearerr(PerlIO *f)
+{
+ dTHX;
+ PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
+}
+
+void
+PerlIOStdio_setlinebuf(PerlIO *f)
+{
+ dTHX;
+#ifdef HAS_SETLINEBUF
+ PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
+#else
+ PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
+#endif
+}
+
+#ifdef FILE_base
+STDCHAR *
+PerlIOStdio_get_base(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_base(stdio);
+}
+
+Size_t
+PerlIOStdio_get_bufsiz(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_bufsiz(stdio);
+}
+#endif
+
+#ifdef USE_STDIO_PTR
+STDCHAR *
+PerlIOStdio_get_ptr(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_ptr(stdio);
+}
+
+SSize_t
+PerlIOStdio_get_cnt(PerlIO *f)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ return PerlSIO_get_cnt(stdio);
+}
+
+void
+PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
+{
+ dTHX;
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (ptr != NULL)
+  {
+#ifdef STDIO_PTR_LVALUE
+   PerlSIO_set_ptr(stdio,ptr);
+#ifdef STDIO_PTR_LVAL_SETS_CNT
+   if (PerlSIO_get_cnt(stdio) != (cnt))
+    {
+     dTHX;
+     assert(PerlSIO_get_cnt(stdio) == (cnt));
+    }
+#endif
+#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
+   /* Setting ptr _does_ change cnt - we are done */
+   return;
+#endif
+#else  /* STDIO_PTR_LVALUE */
+   PerlProc_abort();
+#endif /* STDIO_PTR_LVALUE */
+  }
+/* Now (or only) set cnt */
+#ifdef STDIO_CNT_LVALUE
+ PerlSIO_set_cnt(stdio,cnt);
+#else  /* STDIO_CNT_LVALUE */
+#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
+ PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
+#else  /* STDIO_PTR_LVAL_SETS_CNT */
+ PerlProc_abort();
+#endif /* STDIO_PTR_LVAL_SETS_CNT */
+#endif /* STDIO_CNT_LVALUE */
+}
+
+#endif
+
+PerlIO_funcs PerlIO_stdio = {
+ "stdio",
+ sizeof(PerlIOStdio),
+ PERLIO_K_BUFFERED,
+ PerlIOStdio_fileno,
+ PerlIOStdio_fdopen,
+ PerlIOStdio_open,
+ PerlIOStdio_reopen,
+ PerlIOBase_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOStdio_read,
+ PerlIOStdio_unread,
+ PerlIOStdio_write,
+ PerlIOStdio_seek,
+ PerlIOStdio_tell,
+ PerlIOStdio_close,
+ PerlIOStdio_flush,
+ PerlIOStdio_fill,
+ PerlIOStdio_eof,
+ PerlIOStdio_error,
+ PerlIOStdio_clearerr,
+ PerlIOStdio_setlinebuf,
+#ifdef FILE_base
+ PerlIOStdio_get_base,
+ PerlIOStdio_get_bufsiz,
+#else
+ NULL,
+ NULL,
+#endif
+#ifdef USE_STDIO_PTR
+ PerlIOStdio_get_ptr,
+ PerlIOStdio_get_cnt,
+#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
+ PerlIOStdio_set_ptrcnt
+#else  /* STDIO_PTR_LVALUE */
+ NULL
+#endif /* STDIO_PTR_LVALUE */
+#else  /* USE_STDIO_PTR */
+ NULL,
+ NULL,
+ NULL
+#endif /* USE_STDIO_PTR */
+};
+
+#undef PerlIO_exportFILE
+FILE *
+PerlIO_exportFILE(PerlIO *f, int fl)
+{
+ FILE *stdio;
+ PerlIO_flush(f);
+ stdio = fdopen(PerlIO_fileno(f),"r+");
+ if (stdio)
+  {
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
+   s->stdio  = stdio;
+  }
+ return stdio;
+}
+
+#undef PerlIO_findFILE
+FILE *
+PerlIO_findFILE(PerlIO *f)
+{
+ PerlIOl *l = *f;
+ while (l)
+  {
+   if (l->tab == &PerlIO_stdio)
+    {
+     PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
+     return s->stdio;
+    }
+   l = *PerlIONext(&l);
+  }
+ return PerlIO_exportFILE(f,0);
+}
+
+#undef PerlIO_releaseFILE
+void
+PerlIO_releaseFILE(PerlIO *p, FILE *f)
+{
+}
+
+/*--------------------------------------------------------------------------------------*/
+/* perlio buffer layer */
+
+IV
+PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ b->posn = PerlIO_tell(PerlIONext(f));
+ return PerlIOBase_pushed(f,mode,arg,len);
+}
+
+PerlIO *
+PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
+{
+ dTHX;
+ PerlIO_funcs *tab = PerlIO_default_btm();
+ int init = 0;
+ PerlIO *f;
+ if (*mode == 'I')
+  {
+   init = 1;
+   mode++;
+  }
+#if O_BINARY != O_TEXT
+ /* do something about failing setmode()? --jhi */
+ PerlLIO_setmode(fd, O_BINARY);
+#endif
+ f = (*tab->Fdopen)(tab,fd,mode);
+ if (f)
+  {
+   PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
+   if (init && fd == 2)
+    {
+     /* Initial stderr is unbuffered */
+     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+    }
+#if 0
+   PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
+                self->name,f,fd,mode,PerlIOBase(f)->flags);
+#endif
+  }
+ return f;
+}
+
+PerlIO *
+PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_btm();
+ PerlIO *f = (*tab->Open)(tab,path,mode);
+ if (f)
+  {
+   PerlIO_push(f,self,mode,Nullch,0);
+  }
+ return f;
+}
+
+int
+PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
+{
+ PerlIO *next = PerlIONext(f);
+ int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
+ if (code = 0)
+  code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
+ return code;
+}
+
+/* This "flush" is akin to sfio's sync in that it handles files in either
+   read or write state
+*/
+IV
+PerlIOBuf_flush(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ int code = 0;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+  {
+   /* write() the buffer */
+   STDCHAR *buf = b->buf;
+   STDCHAR *p = buf;
+   int count;
+   PerlIO *n = PerlIONext(f);
+   while (p < b->ptr)
+    {
+     count = PerlIO_write(n,p,b->ptr - p);
+     if (count > 0)
+      {
+       p += count;
+      }
+     else if (count < 0 || PerlIO_error(n))
+      {
+       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+       code = -1;
+       break;
+      }
+    }
+   b->posn += (p - buf);
+  }
+ else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+  {
+   STDCHAR *buf = PerlIO_get_base(f);
+   /* Note position change */
+   b->posn += (b->ptr - buf);
+   if (b->ptr < b->end)
+    {
+     /* We did not consume all of it */
+     if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
+      {
+       b->posn = PerlIO_tell(PerlIONext(f));
+      }
+    }
+  }
+ b->ptr = b->end = b->buf;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ /* FIXME: Is this right for read case ? */
+ if (PerlIO_flush(PerlIONext(f)) != 0)
+  code = -1;
+ return code;
+}
+
+IV
+PerlIOBuf_fill(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIO *n = PerlIONext(f);
+ SSize_t avail;
+ /* FIXME: doing the down-stream flush is a bad idea if it causes
+    pre-read data in stdio buffer to be discarded
+    but this is too simplistic - as it skips _our_ hosekeeping
+    and breaks tell tests.
+ if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+  {
+  }
+  */
+ if (PerlIO_flush(f) != 0)
+  return -1;
+
+ if (!b->buf)
+  PerlIO_get_base(f); /* allocate via vtable */
+
+ b->ptr = b->end = b->buf;
+ if (PerlIO_fast_gets(n))
+  {
+   /* Layer below is also buffered
+    * We do _NOT_ want to call its ->Read() because that will loop
+    * till it gets what we asked for which may hang on a pipe etc.
+    * Instead take anything it has to hand, or ask it to fill _once_.
+    */
+   avail  = PerlIO_get_cnt(n);
+   if (avail <= 0)
+    {
+     avail = PerlIO_fill(n);
+     if (avail == 0)
+      avail = PerlIO_get_cnt(n);
+     else
+      {
+       if (!PerlIO_error(n) && PerlIO_eof(n))
+        avail = 0;
+      }
+    }
+   if (avail > 0)
+    {
+     STDCHAR *ptr = PerlIO_get_ptr(n);
+     SSize_t cnt  = avail;
+     if (avail > b->bufsiz)
+      avail = b->bufsiz;
+     Copy(ptr,b->buf,avail,STDCHAR);
+     PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
+    }
+  }
+ else
+  {
+   avail = PerlIO_read(n,b->ptr,b->bufsiz);
+  }
+ if (avail <= 0)
+  {
+   if (avail == 0)
+    PerlIOBase(f)->flags |= PERLIO_F_EOF;
+   else
+    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+   return -1;
+  }
+ b->end      = b->buf+avail;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+ return 0;
+}
+
+SSize_t
+PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
+ STDCHAR *buf  = (STDCHAR *) vbuf;
+ if (f)
+  {
+   if (!b->ptr)
+    PerlIO_get_base(f);
+   if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
+    return 0;
+   while (count > 0)
+    {
+     SSize_t avail = PerlIO_get_cnt(f);
+     SSize_t take  = (count < avail) ? count : avail;
+     if (take > 0)
+      {
+       STDCHAR *ptr = PerlIO_get_ptr(f);
+       Copy(ptr,buf,take,STDCHAR);
+       PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
+       count   -= take;
+       buf     += take;
+      }
+     if (count > 0  && avail <= 0)
+      {
+       if (PerlIO_fill(f) != 0)
+        break;
+      }
+    }
+   return (buf - (STDCHAR *) vbuf);
+  }
+ return 0;
+}
+
+SSize_t
+PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ const STDCHAR *buf = (const STDCHAR *) vbuf+count;
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ SSize_t unread = 0;
+ SSize_t avail;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+  PerlIO_flush(f);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ if (b->buf)
+  {
+   if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+    {
+     avail = (b->ptr - b->buf);
+    }
+   else
+    {
+     avail = b->bufsiz;
+     b->end = b->buf + avail;
+     b->ptr = b->end;
+     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+     b->posn -= b->bufsiz;
+    }
+   if (avail > (SSize_t) count)
+    avail = count;
+   if (avail > 0)
+    {
+     b->ptr -= avail;
+     buf    -= avail;
+     if (buf != b->ptr)
+      {
+       Copy(buf,b->ptr,avail,STDCHAR);
+      }
+     count  -= avail;
+     unread += avail;
+     PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
+    }
+  }
+ return unread;
+}
+
+SSize_t
+PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ const STDCHAR *buf = (const STDCHAR *) vbuf;
+ Size_t written = 0;
+ if (!b->buf)
+  PerlIO_get_base(f);
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+  return 0;
+ while (count > 0)
+  {
+   SSize_t avail = b->bufsiz - (b->ptr - b->buf);
+   if ((SSize_t) count < avail)
+    avail = count;
+   PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
+   if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+    {
+     while (avail > 0)
+      {
+       int ch = *buf++;
+       *(b->ptr)++ = ch;
+       count--;
+       avail--;
+       written++;
+       if (ch == '\n')
+        {
+         PerlIO_flush(f);
+         break;
+        }
+      }
+    }
+   else
+    {
+     if (avail)
+      {
+       Copy(buf,b->ptr,avail,STDCHAR);
+       count   -= avail;
+       buf     += avail;
+       written += avail;
+       b->ptr  += avail;
+      }
+    }
+   if (b->ptr >= (b->buf + b->bufsiz))
+    PerlIO_flush(f);
+  }
+ if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
+  PerlIO_flush(f);
+ return written;
+}
+
+IV
+PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
+{
+ IV code;
+ if ((code = PerlIO_flush(f)) == 0)
+  {
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+   PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+   code = PerlIO_seek(PerlIONext(f),offset,whence);
+   if (code == 0)
+    {
+     b->posn = PerlIO_tell(PerlIONext(f));
+    }
+  }
+ return code;
+}
+
+Off_t
+PerlIOBuf_tell(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ Off_t posn = b->posn;
+ if (b->buf)
+  posn += (b->ptr - b->buf);
+ return posn;
+}
+
+IV
+PerlIOBuf_close(PerlIO *f)
+{
+ dTHX;
+ IV code = PerlIOBase_close(f);
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (b->buf && b->buf != (STDCHAR *) &b->oneword)
+  {
+   PerlMemShared_free(b->buf);
+  }
+ b->buf = NULL;
+ b->ptr = b->end = b->buf;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+void
+PerlIOBuf_setlinebuf(PerlIO *f)
+{
+ if (f)
+  {
+   PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
+  }
+}
+
+STDCHAR *
+PerlIOBuf_get_ptr(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ return b->ptr;
+}
+
+SSize_t
+PerlIOBuf_get_cnt(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+  return (b->end - b->ptr);
+ return 0;
+}
+
+STDCHAR *
+PerlIOBuf_get_base(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  {
+   dTHX;
+   if (!b->bufsiz)
+    b->bufsiz = 4096;
+   b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
+   if (!b->buf)
+    {
+     b->buf = (STDCHAR *)&b->oneword;
+     b->bufsiz = sizeof(b->oneword);
+    }
+   b->ptr = b->buf;
+   b->end = b->ptr;
+  }
+ return b->buf;
+}
+
+Size_t
+PerlIOBuf_bufsiz(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ return (b->end - b->buf);
+}
+
+void
+PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ b->ptr = ptr;
+ if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
+  {
+   dTHX;
+   assert(PerlIO_get_cnt(f) == cnt);
+   assert(b->ptr >= b->buf);
+  }
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+}
+
+PerlIO_funcs PerlIO_perlio = {
+ "perlio",
+ sizeof(PerlIOBuf),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOBuf_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOBuf_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOBuf_flush,
+ PerlIOBuf_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* Temp layer to hold unread chars when cannot do it any other way */
+
+IV
+PerlIOPending_fill(PerlIO *f)
+{
+ /* Should never happen */
+ PerlIO_flush(f);
+ return 0;
+}
+
+IV
+PerlIOPending_close(PerlIO *f)
+{
+ /* A tad tricky - flush pops us, then we close new top */
+ PerlIO_flush(f);
+ return PerlIO_close(f);
+}
+
+IV
+PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
+{
+ /* A tad tricky - flush pops us, then we seek new top */
+ PerlIO_flush(f);
+ return PerlIO_seek(f,offset,whence);
+}
+
+
+IV
+PerlIOPending_flush(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (b->buf && b->buf != (STDCHAR *) &b->oneword)
+  {
+   dTHX;
+   PerlMemShared_free(b->buf);
+   b->buf = NULL;
+  }
+ PerlIO_pop(f);
+ return 0;
+}
+
+void
+PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ if (cnt <= 0)
+  {
+   PerlIO_flush(f);
+  }
+ else
+  {
+   PerlIOBuf_set_ptrcnt(f,ptr,cnt);
+  }
+}
+
+IV
+PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
+{
+ IV code    = PerlIOBase_pushed(f,mode,arg,len);
+ PerlIOl *l = PerlIOBase(f);
+ /* Our PerlIO_fast_gets must match what we are pushed on,
+    or sv_gets() etc. get muddled when it changes mid-string
+    when we auto-pop.
+  */
+ l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
+              (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
+ return code;
+}
+
+SSize_t
+PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ SSize_t avail = PerlIO_get_cnt(f);
+ SSize_t got   = 0;
+ if (count < avail)
+  avail = count;
+ if (avail > 0)
+  got = PerlIOBuf_read(f,vbuf,avail);
+ if (got < count)
+  got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
+ return got;
+}
+
+
+PerlIO_funcs PerlIO_pending = {
+ "pending",
+ sizeof(PerlIOBuf),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ NULL,
+ NULL,
+ NULL,
+ PerlIOPending_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOPending_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOPending_seek,
+ PerlIOBuf_tell,
+ PerlIOPending_close,
+ PerlIOPending_flush,
+ PerlIOPending_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOPending_set_ptrcnt,
+};
+
+
+
+/*--------------------------------------------------------------------------------------*/
+/* crlf - translation
+   On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
+   to hand back a line at a time and keeping a record of which nl we "lied" about.
+   On write translate "\n" to CR,LF
+ */
+
+typedef struct
+{
+ PerlIOBuf     base;         /* PerlIOBuf stuff */
+ STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
+} PerlIOCrlf;
+
+IV
+PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
+{
+ IV code;
+ PerlIOBase(f)->flags |= PERLIO_F_CRLF;
+ code = PerlIOBuf_pushed(f,mode,arg,len);
+#if 0
+ PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
+              f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
+              PerlIOBase(f)->flags);
+#endif
+ return code;
+}
+
+
+SSize_t
+PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (c->nl)
+  {
+   *(c->nl) = 0xd;
+   c->nl = NULL;
+  }
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
+  return PerlIOBuf_unread(f,vbuf,count);
+ else
+  {
+   const STDCHAR *buf = (const STDCHAR *) vbuf+count;
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+   SSize_t unread = 0;
+   if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+    PerlIO_flush(f);
+   if (!b->buf)
+    PerlIO_get_base(f);
+   if (b->buf)
+    {
+     if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+      {
+       b->end = b->ptr = b->buf + b->bufsiz;
+       PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+       b->posn -= b->bufsiz;
+      }
+     while (count > 0 && b->ptr > b->buf)
+      {
+       int ch = *--buf;
+       if (ch == '\n')
+        {
+         if (b->ptr - 2 >= b->buf)
+          {
+           *--(b->ptr) = 0xa;
+           *--(b->ptr) = 0xd;
+           unread++;
+           count--;
+          }
+         else
+          {
+           buf++;
+           break;
+          }
+        }
+       else
+        {
+         *--(b->ptr) = ch;
+         unread++;
+         count--;
+        }
+      }
+    }
+   return unread;
+  }
+}
+
+SSize_t
+PerlIOCrlf_get_cnt(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (!b->buf)
+  PerlIO_get_base(f);
+ if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
+  {
+   PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+   if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
+    {
+     STDCHAR *nl   = b->ptr;
+    scan:
+     while (nl < b->end && *nl != 0xd)
+      nl++;
+     if (nl < b->end && *nl == 0xd)
+      {
+     test:
+       if (nl+1 < b->end)
+        {
+         if (nl[1] == 0xa)
+          {
+           *nl   = '\n';
+           c->nl = nl;
+          }
+         else
+          {
+           /* Not CR,LF but just CR */
+           nl++;
+           goto scan;
+          }
+        }
+       else
+        {
+         /* Blast - found CR as last char in buffer */
+         if (b->ptr < nl)
+          {
+           /* They may not care, defer work as long as possible */
+           return (nl - b->ptr);
+          }
+         else
+          {
+           int code;
+           dTHX;
+           b->ptr++;               /* say we have read it as far as flush() is concerned */
+           b->buf++;               /* Leave space an front of buffer */
+           b->bufsiz--;            /* Buffer is thus smaller */
+           code = PerlIO_fill(f);  /* Fetch some more */
+           b->bufsiz++;            /* Restore size for next time */
+           b->buf--;               /* Point at space */
+           b->ptr = nl = b->buf;   /* Which is what we hand off */
+           b->posn--;              /* Buffer starts here */
+           *nl = 0xd;              /* Fill in the CR */
+           if (code == 0)
+            goto test;             /* fill() call worked */
+           /* CR at EOF - just fall through */
+          }
+        }
+      }
+    }
+   return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
+  }
+ return 0;
+}
+
+void
+PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ IV flags = PerlIOBase(f)->flags;
+ if (!b->buf)
+  PerlIO_get_base(f);
+ if (!ptr)
+  {
+   if (c->nl)
+    ptr = c->nl+1;
+   else
+    {
+     ptr = b->end;
+     if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
+      ptr--;
+    }
+   ptr -= cnt;
+  }
+ else
+  {
+   /* Test code - delete when it works ... */
+   STDCHAR *chk;
+   if (c->nl)
+    chk = c->nl+1;
+   else
+    {
+     chk = b->end;
+     if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
+      chk--;
+    }
+   chk -= cnt;
+
+   if (ptr != chk)
+    {
+     dTHX;
+     Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
+                ptr, chk, flags, c->nl, b->end, cnt);
+    }
+  }
+ if (c->nl)
+  {
+   if (ptr > c->nl)
+    {
+     /* They have taken what we lied about */
+     *(c->nl) = 0xd;
+     c->nl = NULL;
+     ptr++;
+    }
+  }
+ b->ptr = ptr;
+ PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+}
+
+SSize_t
+PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
+  return PerlIOBuf_write(f,vbuf,count);
+ else
+  {
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+   const STDCHAR *buf  = (const STDCHAR *) vbuf;
+   const STDCHAR *ebuf = buf+count;
+   if (!b->buf)
+    PerlIO_get_base(f);
+   if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
+    return 0;
+   while (buf < ebuf)
+    {
+     STDCHAR *eptr = b->buf+b->bufsiz;
+     PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
+     while (buf < ebuf && b->ptr < eptr)
+      {
+       if (*buf == '\n')
+        {
+         if ((b->ptr + 2) > eptr)
+          {
+           /* Not room for both */
+           PerlIO_flush(f);
+           break;
+          }
+         else
+          {
+           *(b->ptr)++ = 0xd; /* CR */
+           *(b->ptr)++ = 0xa; /* LF */
+           buf++;
+           if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+            {
+             PerlIO_flush(f);
+             break;
+            }
+          }
+        }
+       else
+        {
+         int ch = *buf++;
+         *(b->ptr)++ = ch;
+        }
+       if (b->ptr >= eptr)
+        {
+         PerlIO_flush(f);
+         break;
+        }
+      }
+    }
+   if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
+    PerlIO_flush(f);
+   return (buf - (STDCHAR *) vbuf);
+  }
+}
+
+IV
+PerlIOCrlf_flush(PerlIO *f)
+{
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
+ if (c->nl)
+  {
+   *(c->nl) = 0xd;
+   c->nl = NULL;
+  }
+ return PerlIOBuf_flush(f);
+}
+
+PerlIO_funcs PerlIO_crlf = {
+ "crlf",
+ sizeof(PerlIOCrlf),
+ PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOCrlf_pushed,
+ PerlIOBase_noop_ok,   /* popped */
+ PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
+ PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
+ PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOCrlf_flush,
+ PerlIOBuf_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOCrlf_get_cnt,
+ PerlIOCrlf_set_ptrcnt,
+};
+
+#ifdef HAS_MMAP
+/*--------------------------------------------------------------------------------------*/
+/* mmap as "buffer" layer */
+
+typedef struct
+{
+ PerlIOBuf     base;         /* PerlIOBuf stuff */
+ Mmap_t                mptr;        /* Mapped address */
+ Size_t                len;          /* mapped length */
+ STDCHAR       *bbuf;        /* malloced buffer if map fails */
+} PerlIOMmap;
+
+static size_t page_size = 0;
+
+IV
+PerlIOMmap_map(PerlIO *f)
 {
  dTHX;
-#ifdef FILE_bufsiz
- STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
- int ec = e - ptr;
- if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
-  Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
- if (cnt != ec && ckWARN_d(WARN_INTERNAL))
-  Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
-#endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
-  FILE_ptr(f) = ptr;
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ IV flags = PerlIOBase(f)->flags;
+ IV code  = 0;
+ if (m->len)
+  abort();
+ if (flags & PERLIO_F_CANREAD)
+  {
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+   int fd   = PerlIO_fileno(f);
+   struct stat st;
+   code = fstat(fd,&st);
+   if (code == 0 && S_ISREG(st.st_mode))
+    {
+     SSize_t len = st.st_size - b->posn;
+     if (len > 0)
+      {
+       Off_t posn;
+       if (!page_size) {
+#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
+          {
+              SETERRNO(0,SS$_NORMAL);
+#   ifdef _SC_PAGESIZE
+              page_size = sysconf(_SC_PAGESIZE);
+#   else
+              page_size = sysconf(_SC_PAGE_SIZE);
+#   endif
+              if ((long)page_size < 0) {
+                  if (errno) {
+                      SV *error = ERRSV;
+                      char *msg;
+                      STRLEN n_a;
+                      (void)SvUPGRADE(error, SVt_PV);
+                      msg = SvPVx(error, n_a);
+                      Perl_croak(aTHX_ "panic: sysconf: %s", msg);
+                  }
+                  else
+                      Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
+              }
+          }
 #else
-  Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
+#   ifdef HAS_GETPAGESIZE
+        page_size = getpagesize();
+#   else
+#       if defined(I_SYS_PARAM) && defined(PAGESIZE)
+        page_size = PAGESIZE; /* compiletime, bad */
+#       endif
+#   endif
 #endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
-  FILE_cnt(f) = cnt;
-#else
-  Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
+       if ((IV)page_size <= 0)
+           Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
+       }
+       if (b->posn < 0)
+        {
+         /* This is a hack - should never happen - open should have set it ! */
+         b->posn = PerlIO_tell(PerlIONext(f));
+        }
+       posn = (b->posn / page_size) * page_size;
+       len  = st.st_size - posn;
+       m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+       if (m->mptr && m->mptr != (Mmap_t) -1)
+        {
+#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
+         madvise(m->mptr, len, MADV_SEQUENTIAL);
+#endif
+#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
+         madvise(m->mptr, len, MADV_WILLNEED);
 #endif
+         PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
+         b->end  = ((STDCHAR *)m->mptr) + len;
+         b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
+         b->ptr  = b->buf;
+         m->len  = len;
+        }
+       else
+        {
+         b->buf = NULL;
+        }
+      }
+     else
+      {
+       PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
+       b->buf = NULL;
+       b->ptr = b->end = b->ptr;
+       code = -1;
+      }
+    }
+  }
+ return code;
 }
 
-#undef PerlIO_get_cnt
-int 
-PerlIO_get_cnt(PerlIO *f)
+IV
+PerlIOMmap_unmap(PerlIO *f)
 {
-#ifdef FILE_cnt
- return FILE_cnt(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
- return -1;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ IV code = 0;
+ if (m->len)
+  {
+   if (b->buf)
+    {
+     code = munmap(m->mptr, m->len);
+     b->buf  = NULL;
+     m->len  = 0;
+     m->mptr = NULL;
+     if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
+      code = -1;
+    }
+   b->ptr = b->end = b->buf;
+   PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+  }
+ return code;
 }
 
-#undef PerlIO_get_bufsiz
-int 
-PerlIO_get_bufsiz(PerlIO *f)
+STDCHAR *
+PerlIOMmap_get_base(PerlIO *f)
 {
-#ifdef FILE_bufsiz
- return FILE_bufsiz(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
- return -1;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+  {
+   /* Already have a readbuffer in progress */
+   return b->buf;
+  }
+ if (b->buf)
+  {
+   /* We have a write buffer or flushed PerlIOBuf read buffer */
+   m->bbuf = b->buf;  /* save it in case we need it again */
+   b->buf  = NULL;    /* Clear to trigger below */
+  }
+ if (!b->buf)
+  {
+   PerlIOMmap_map(f);     /* Try and map it */
+   if (!b->buf)
+    {
+     /* Map did not work - recover PerlIOBuf buffer if we have one */
+     b->buf = m->bbuf;
+    }
+  }
+ b->ptr  = b->end = b->buf;
+ if (b->buf)
+  return b->buf;
+ return PerlIOBuf_get_base(f);
 }
 
-#undef PerlIO_get_ptr
-STDCHAR *
-PerlIO_get_ptr(PerlIO *f)
+SSize_t
+PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
-#ifdef FILE_ptr
- return FILE_ptr(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
- return NULL;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+  PerlIO_flush(f);
+ if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
+  {
+   b->ptr -= count;
+   PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
+   return count;
+  }
+ if (m->len)
+  {
+   /* Loose the unwritable mapped buffer */
+   PerlIO_flush(f);
+   /* If flush took the "buffer" see if we have one from before */
+   if (!b->buf && m->bbuf)
+    b->buf = m->bbuf;
+   if (!b->buf)
+    {
+     PerlIOBuf_get_base(f);
+     m->bbuf = b->buf;
+    }
+  }
+return PerlIOBuf_unread(f,vbuf,count);
 }
 
-#undef PerlIO_get_base
-STDCHAR *
-PerlIO_get_base(PerlIO *f)
+SSize_t
+PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
 {
-#ifdef FILE_base
- return FILE_base(f);
-#else
- dTHX;
- Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
- return NULL;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
+  {
+   /* No, or wrong sort of, buffer */
+   if (m->len)
+    {
+     if (PerlIOMmap_unmap(f) != 0)
+      return 0;
+    }
+   /* If unmap took the "buffer" see if we have one from before */
+   if (!b->buf && m->bbuf)
+    b->buf = m->bbuf;
+   if (!b->buf)
+    {
+     PerlIOBuf_get_base(f);
+     m->bbuf = b->buf;
+    }
+  }
+ return PerlIOBuf_write(f,vbuf,count);
 }
 
-#undef PerlIO_has_base 
-int 
-PerlIO_has_base(PerlIO *f)
+IV
+PerlIOMmap_flush(PerlIO *f)
 {
-#ifdef FILE_base
- return 1;
-#else
- return 0;
-#endif
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ IV code = PerlIOBuf_flush(f);
+ /* Now we are "synced" at PerlIOBuf level */
+ if (b->buf)
+  {
+   if (m->len)
+    {
+     /* Unmap the buffer */
+     if (PerlIOMmap_unmap(f) != 0)
+      code = -1;
+    }
+   else
+    {
+     /* We seem to have a PerlIOBuf buffer which was not mapped
+      * remember it in case we need one later
+      */
+     m->bbuf = b->buf;
+    }
+  }
+ return code;
 }
 
-#undef PerlIO_puts
-int
-PerlIO_puts(PerlIO *f, const char *s)
+IV
+PerlIOMmap_fill(PerlIO *f)
 {
- return fputs(s,f);
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ IV code = PerlIO_flush(f);
+ if (code == 0 && !b->buf)
+  {
+   code = PerlIOMmap_map(f);
+  }
+ if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
+  {
+   code = PerlIOBuf_fill(f);
+  }
+ return code;
 }
 
-#undef PerlIO_open 
-PerlIO * 
-PerlIO_open(const char *path, const char *mode)
+IV
+PerlIOMmap_close(PerlIO *f)
 {
- return fopen(path,mode);
+ PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
+ PerlIOBuf  *b = &m->base;
+ IV code = PerlIO_flush(f);
+ if (m->bbuf)
+  {
+   b->buf  = m->bbuf;
+   m->bbuf = NULL;
+   b->ptr  = b->end = b->buf;
+  }
+ if (PerlIOBuf_close(f) != 0)
+  code = -1;
+ return code;
 }
 
-#undef PerlIO_fdopen
-PerlIO * 
-PerlIO_fdopen(int fd, const char *mode)
+
+PerlIO_funcs PerlIO_mmap = {
+ "mmap",
+ sizeof(PerlIOMmap),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOBuf_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOBuf_read,
+ PerlIOMmap_unread,
+ PerlIOMmap_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOBuf_close,
+ PerlIOMmap_flush,
+ PerlIOMmap_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOMmap_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
+#endif /* HAS_MMAP */
+
+void
+PerlIO_init(void)
 {
- return fdopen(fd,mode);
+ if (!_perlio)
+  {
+#ifndef WIN32
+   atexit(&PerlIO_cleanup);
+#endif
+  }
 }
 
-#undef PerlIO_reopen
-PerlIO * 
-PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
+#undef PerlIO_stdin
+PerlIO *
+PerlIO_stdin(void)
 {
- return freopen(name,mode,f);
+ if (!_perlio)
+  PerlIO_stdstreams();
+ return &_perlio[1];
 }
 
-#undef PerlIO_close
-int      
-PerlIO_close(PerlIO *f)
+#undef PerlIO_stdout
+PerlIO *
+PerlIO_stdout(void)
 {
- return fclose(f);
+ if (!_perlio)
+  PerlIO_stdstreams();
+ return &_perlio[2];
 }
 
-#undef PerlIO_eof
-int      
-PerlIO_eof(PerlIO *f)
+#undef PerlIO_stderr
+PerlIO *
+PerlIO_stderr(void)
 {
- return feof(f);
+ if (!_perlio)
+  PerlIO_stdstreams();
+ return &_perlio[3];
 }
 
+/*--------------------------------------------------------------------------------------*/
+
 #undef PerlIO_getname
 char *
 PerlIO_getname(PerlIO *f, char *buf)
 {
-#ifdef VMS
- return fgetname(f,buf);
-#else
  dTHX;
  Perl_croak(aTHX_ "Don't know how to get file name");
  return NULL;
-#endif
-}
-
-#undef PerlIO_getc
-int      
-PerlIO_getc(PerlIO *f)
-{
- return fgetc(f);
-}
-
-#undef PerlIO_error
-int      
-PerlIO_error(PerlIO *f)
-{
- return ferror(f);
 }
 
-#undef PerlIO_clearerr
-void
-PerlIO_clearerr(PerlIO *f)
-{
- clearerr(f);
-}
 
-#undef PerlIO_flush
-int      
-PerlIO_flush(PerlIO *f)
-{
- return Fflush(f);
-}
+/*--------------------------------------------------------------------------------------*/
+/* Functions which can be called on any kind of PerlIO implemented
+   in terms of above
+*/
 
-#undef PerlIO_fileno
-int      
-PerlIO_fileno(PerlIO *f)
+#undef PerlIO_getc
+int
+PerlIO_getc(PerlIO *f)
 {
- return fileno(f);
+ STDCHAR buf[1];
+ SSize_t count = PerlIO_read(f,buf,1);
+ if (count == 1)
+  {
+   return (unsigned char) buf[0];
+  }
+ return EOF;
 }
 
-#undef PerlIO_setlinebuf
-void
-PerlIO_setlinebuf(PerlIO *f)
+#undef PerlIO_ungetc
+int
+PerlIO_ungetc(PerlIO *f, int ch)
 {
-#ifdef HAS_SETLINEBUF
-    setlinebuf(f);
-#else
-#  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
-    setvbuf(f, Nullch, _IOLBF, BUFSIZ);
-#  else
-    setvbuf(f, Nullch, _IOLBF, 0);
-#  endif
-#endif
+ if (ch != EOF)
+  {
+   STDCHAR buf = ch;
+   if (PerlIO_unread(f,&buf,1) == 1)
+    return ch;
+  }
+ return EOF;
 }
 
 #undef PerlIO_putc
-int      
+int
 PerlIO_putc(PerlIO *f, int ch)
 {
- return putc(ch,f);
-}
-
-#undef PerlIO_ungetc
-int      
-PerlIO_ungetc(PerlIO *f, int ch)
-{
- return ungetc(ch,f);
+ STDCHAR buf = ch;
+ return PerlIO_write(f,&buf,1);
 }
 
-#undef PerlIO_read
-SSize_t
-PerlIO_read(PerlIO *f, void *buf, Size_t count)
+#undef PerlIO_puts
+int
+PerlIO_puts(PerlIO *f, const char *s)
 {
- return fread(buf,1,count,f);
+ STRLEN len = strlen(s);
+ return PerlIO_write(f,s,len);
 }
 
-#undef PerlIO_write
-SSize_t
-PerlIO_write(PerlIO *f, const void *buf, Size_t count)
+#undef PerlIO_rewind
+void
+PerlIO_rewind(PerlIO *f)
 {
- return fwrite1(buf,1,count,f);
+ PerlIO_seek(f,(Off_t)0,SEEK_SET);
+ PerlIO_clearerr(f);
 }
 
 #undef PerlIO_vprintf
-int      
-PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
-{
- return vfprintf(f,fmt,ap);
-}
-
-#undef PerlIO_tell
-Off_t
-PerlIO_tell(PerlIO *f)
-{
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
- return ftello(f);
-#else
- return ftell(f);
-#endif
-}
-
-#undef PerlIO_seek
 int
-PerlIO_seek(PerlIO *f, Off_t offset, int whence)
+PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
 {
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
- return fseeko(f,offset,whence);
+ dTHX;
+ SV *sv = newSVpvn("",0);
+ char *s;
+ STRLEN len;
+#ifdef NEED_VA_COPY
+ va_list apc;
+ Perl_va_copy(ap, apc);
+ sv_vcatpvf(sv, fmt, &apc);
 #else
- return fseek(f,offset,whence);
+ sv_vcatpvf(sv, fmt, &ap);
 #endif
-}
-
-#undef PerlIO_rewind
-void
-PerlIO_rewind(PerlIO *f)
-{
- rewind(f);
+ s = SvPV(sv,len);
+ return PerlIO_write(f,s,len);
 }
 
 #undef PerlIO_printf
-int      
+int
 PerlIO_printf(PerlIO *f,const char *fmt,...)
 {
  va_list ap;
  int result;
  va_start(ap,fmt);
- result = vfprintf(f,fmt,ap);
+ result = PerlIO_vprintf(f,fmt,ap);
  va_end(ap);
  return result;
 }
 
 #undef PerlIO_stdoutf
-int      
+int
 PerlIO_stdoutf(const char *fmt,...)
 {
  va_list ap;
@@ -443,93 +3142,114 @@ PerlIO_stdoutf(const char *fmt,...)
 PerlIO *
 PerlIO_tmpfile(void)
 {
- return tmpfile();
-}
-
-#undef PerlIO_importFILE
-PerlIO *
-PerlIO_importFILE(FILE *f, int fl)
-{
- return f;
-}
-
-#undef PerlIO_exportFILE
-FILE *
-PerlIO_exportFILE(PerlIO *f, int fl)
-{
+ /* I have no idea how portable mkstemp() is ... */
+#if defined(WIN32) || !defined(HAVE_MKSTEMP)
+ dTHX;
+ PerlIO *f = NULL;
+ FILE *stdio = PerlSIO_tmpfile();
+ if (stdio)
+  {
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
+   s->stdio  = stdio;
+  }
  return f;
-}
-
-#undef PerlIO_findFILE
-FILE *
-PerlIO_findFILE(PerlIO *f)
-{
+#else
+ dTHX;
+ SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
+ int fd = mkstemp(SvPVX(sv));
+ PerlIO *f = NULL;
+ if (fd >= 0)
+  {
+   f = PerlIO_fdopen(fd,"w+");
+   if (f)
+    {
+     PerlIOBase(f)->flags |= PERLIO_F_TEMP;
+    }
+   PerlLIO_unlink(SvPVX(sv));
+   SvREFCNT_dec(sv);
+  }
  return f;
+#endif
 }
 
-#undef PerlIO_releaseFILE
-void
-PerlIO_releaseFILE(PerlIO *p, FILE *f)
-{
-}
-
-void
-PerlIO_init(void)
-{
- /* Does nothing (yet) except force this file to be included 
-    in perl binary. That allows this file to force inclusion
-    of other functions that may be required by loadable 
-    extensions e.g. for FileHandle::tmpfile  
- */
-}
+#undef HAS_FSETPOS
+#undef HAS_FGETPOS
 
 #endif /* USE_SFIO */
 #endif /* PERLIO_IS_STDIO */
 
+/*======================================================================================*/
+/* Now some functions in terms of above which may be needed even if
+   we are not in true PerlIO mode
+ */
+
 #ifndef HAS_FSETPOS
 #undef PerlIO_setpos
 int
-PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
+PerlIO_setpos(PerlIO *f, SV *pos)
 {
- return PerlIO_seek(f,*pos,0); 
+ dTHX;
+ if (SvOK(pos))
+  {
+   STRLEN len;
+   Off_t *posn = (Off_t *) SvPV(pos,len);
+   if (f && len == sizeof(Off_t))
+    return PerlIO_seek(f,*posn,SEEK_SET);
+  }
+ errno = EINVAL;
+ return -1;
 }
 #else
-#ifndef PERLIO_IS_STDIO
 #undef PerlIO_setpos
 int
-PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
+PerlIO_setpos(PerlIO *f, SV *pos)
 {
+ dTHX;
+ if (SvOK(pos))
+  {
+   STRLEN len;
+   Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
+   if (f && len == sizeof(Fpos_t))
+    {
 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fsetpos64(f, pos);
+     return fsetpos64(f, fpos);
 #else
- return fsetpos(f, pos);
+     return fsetpos(f, fpos);
 #endif
+    }
+  }
+ errno = EINVAL;
+ return -1;
 }
 #endif
-#endif
 
 #ifndef HAS_FGETPOS
 #undef PerlIO_getpos
 int
-PerlIO_getpos(PerlIO *f, Fpos_t *pos)
+PerlIO_getpos(PerlIO *f, SV *pos)
 {
- *pos = PerlIO_tell(f);
- return 0;
+ dTHX;
+ Off_t posn = PerlIO_tell(f);
+ sv_setpvn(pos,(char *)&posn,sizeof(posn));
+ return (posn == (Off_t)-1) ? -1 : 0;
 }
 #else
-#ifndef PERLIO_IS_STDIO
 #undef PerlIO_getpos
 int
-PerlIO_getpos(PerlIO *f, Fpos_t *pos)
+PerlIO_getpos(PerlIO *f, SV *pos)
 {
+ dTHX;
+ Fpos_t fpos;
+ int code;
 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fgetpos64(f, pos);
+ code = fgetpos64(f, &fpos);
 #else
- return fgetpos(f, pos);
+ code = fgetpos(f, &fpos);
 #endif
+ sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
+ return code;
 }
 #endif
-#endif
 
 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 
@@ -550,7 +3270,7 @@ vfprintf(FILE *fd, char *pat, char *args)
 #endif
 
 #ifndef PerlIO_vsprintf
-int 
+int
 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 {
  int val = vsprintf(s, fmt, ap);
@@ -559,7 +3279,8 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
    if (strlen(s) >= (STRLEN)n)
     {
      dTHX;
-     PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
+     (void)PerlIO_puts(Perl_error_log,
+                      "panic: sprintf overflow - memory corrupted!\n");
      my_exit(1);
     }
   }
@@ -568,7 +3289,7 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 #endif
 
 #ifndef PerlIO_sprintf
-int      
+int
 PerlIO_sprintf(char *s, int n, const char *fmt,...)
 {
  va_list ap;
@@ -580,5 +3301,4 @@ PerlIO_sprintf(char *s, int n, const char *fmt,...)
 }
 #endif
 
-#endif /* !PERL_IMPLICIT_SYS */
 
index e699a3e..b144b24 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -1 +1,337 @@
-#include "iperlsys.h"
+#ifndef _PERLIO_H
+#define _PERLIO_H
+/*
+  Interface for perl to IO functions.
+  There is a hierachy of Configure determined #define controls:
+   USE_STDIO   - forces PerlIO_xxx() to be #define-d onto stdio functions.
+                 This is used for x2p subdirectory and for conservative
+                 builds - "just like perl5.00X used to be".
+                 This dominates over the others.
+
+   USE_PERLIO  - The primary Configure variable that enables PerlIO.
+                 If USE_PERLIO is _NOT_ set
+                   then USE_STDIO above will be set to be conservative.
+                 If USE_PERLIO is set
+                   then there are two modes determined by USE_SFIO:
+
+   USE_SFIO    - If set causes PerlIO_xxx() to be #define-d onto sfio functions.
+                 A backward compatability mode for some specialist applications.
+
+                 If USE_SFIO is not set then PerlIO_xxx() are real functions
+                 defined in perlio.c which implement extra functionality
+                 required for utf8 support.
+
+   One further note - the table-of-functions scheme controlled
+   by PERL_IMPLICIT_SYS turns on USE_PERLIO so that iperlsys.h can
+   #define PerlIO_xxx() to go via the function table, without having
+   to #undef them from (say) stdio forms.
+
+*/
+
+#if defined(PERL_IMPLICIT_SYS)
+#ifndef USE_PERLIO
+# define USE_PERLIO
+#endif
+#endif
+
+#ifndef USE_PERLIO
+# define USE_STDIO
+#endif
+
+#ifdef USE_STDIO
+#  ifndef PERLIO_IS_STDIO
+#      define PERLIO_IS_STDIO
+#  endif
+#endif
+
+/* --------------------  End of Configure controls ---------------------------- */
+
+/*
+ * Although we may not want stdio to be used including <stdio.h> here
+ * avoids issues where stdio.h has strange side effects
+ */
+#include <stdio.h>
+
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
+#define ftell ftello
+#endif
+
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
+#define fseek fseeko
+#endif
+
+#ifdef PERLIO_IS_STDIO
+/* #define PerlIO_xxxx() as equivalent stdio function */
+#include "perlsdio.h"
+#else  /* PERLIO_IS_STDIO */
+#ifdef USE_SFIO
+/* #define PerlIO_xxxx() as equivalent sfio function */
+#include "perlsfio.h"
+#endif /* USE_SFIO */
+#endif /* PERLIO_IS_STDIO */
+
+#ifndef PerlIO
+/* ----------- PerlIO implementation ---------- */
+/* PerlIO not #define-d to something else - define the implementation */
+
+typedef struct _PerlIO PerlIOl;
+typedef struct _PerlIO_funcs PerlIO_funcs;
+typedef PerlIOl *PerlIO;
+#define PerlIO PerlIO
+#define PERLIO_LAYERS 1
+
+extern void    PerlIO_define_layer     (PerlIO_funcs *tab);
+extern SV *    PerlIO_find_layer       (const char *name, STRLEN len);
+extern PerlIO *        PerlIO_push             (PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len);
+extern void    PerlIO_pop              (PerlIO *f);
+
+#endif /* PerlIO */
+
+/* ----------- End of implementation choices  ---------- */
+
+#ifndef PERLIO_IS_STDIO
+/* Not using stdio _directly_ as PerlIO */
+
+/* We now need to determine  what happens if source trys to use stdio.
+ * There are three cases based on PERLIO_NOT_STDIO which XS code
+ * can set how it wants.
+ */
+
+#ifdef PERL_CORE
+/* Make a choice for perl core code
+   - currently this is set to try and catch lingering raw stdio calls.
+     This is a known issue with some non UNIX ports which still use
+     "native" stdio features.
+*/
+#ifndef PERLIO_NOT_STDIO
+#define PERLIO_NOT_STDIO 1
+#endif
+#else
+#ifndef PERLIO_NOT_STDIO
+#define PERLIO_NOT_STDIO 0
+#endif
+#endif
+
+#ifdef PERLIO_NOT_STDIO
+#if PERLIO_NOT_STDIO
+/*
+ * PERLIO_NOT_STDIO #define'd as 1
+ * Case 1: Strong denial of stdio - make all stdio calls (we can think of) errors
+ */
+#include "nostdio.h"
+#else /* if PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO #define'd as 0
+ * Case 2: Declares that both PerlIO and stdio can be used
+ */
+#endif /* if PERLIO_NOT_STDIO */
+#else  /* ifdef PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO not defined
+ * Case 3: Try and fake stdio calls as PerlIO calls
+ */
+#include "fakesdio.h"
+#endif /* ifndef PERLIO_NOT_STDIO */
+#endif /* PERLIO_IS_STDIO */
+
+#define specialCopIO(sv) ((sv) != Nullsv)
+
+/* ----------- fill in things that have not got #define'd  ---------- */
+
+#ifndef Fpos_t
+#define Fpos_t Off_t
+#endif
+
+#ifndef EOF
+#define EOF (-1)
+#endif
+
+/* This is to catch case with no stdio */
+#ifndef BUFSIZ
+#define BUFSIZ 1024
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#endif
+
+#ifndef SEEK_CUR
+#define SEEK_CUR 1
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+/* --------------------- Now prototypes for functions --------------- */
+
+START_EXTERN_C
+
+#ifndef NEXT30_NO_ATTRIBUTE
+#ifndef HASATTRIBUTE       /* disable GNU-cc attribute checking? */
+#ifdef  __attribute__      /* Avoid possible redefinition errors */
+#undef  __attribute__
+#endif
+#define __attribute__(attr)
+#endif
+#endif
+
+#ifndef PerlIO_init
+extern void    PerlIO_init             (void);
+#endif
+#ifndef PerlIO_stdoutf
+extern int     PerlIO_stdoutf          (const char *,...)
+                                       __attribute__((__format__ (__printf__, 1, 2)));
+#endif
+#ifndef PerlIO_puts
+extern int     PerlIO_puts             (PerlIO *,const char *);
+#endif
+#ifndef PerlIO_open
+extern PerlIO *        PerlIO_open             (const char *,const char *);
+#endif
+#ifndef PerlIO_close
+extern int     PerlIO_close            (PerlIO *);
+#endif
+#ifndef PerlIO_eof
+extern int     PerlIO_eof              (PerlIO *);
+#endif
+#ifndef PerlIO_error
+extern int     PerlIO_error            (PerlIO *);
+#endif
+#ifndef PerlIO_clearerr
+extern void    PerlIO_clearerr         (PerlIO *);
+#endif
+#ifndef PerlIO_getc
+extern int     PerlIO_getc             (PerlIO *);
+#endif
+#ifndef PerlIO_putc
+extern int     PerlIO_putc             (PerlIO *,int);
+#endif
+#ifndef PerlIO_flush
+extern int     PerlIO_flush            (PerlIO *);
+#endif
+#ifndef PerlIO_ungetc
+extern int     PerlIO_ungetc           (PerlIO *,int);
+#endif
+#ifndef PerlIO_fileno
+extern int     PerlIO_fileno           (PerlIO *);
+#endif
+#ifndef PerlIO_fdopen
+extern PerlIO *        PerlIO_fdopen           (int, const char *);
+#endif
+#ifndef PerlIO_importFILE
+extern PerlIO *        PerlIO_importFILE       (FILE *,int);
+#endif
+#ifndef PerlIO_exportFILE
+extern FILE *  PerlIO_exportFILE       (PerlIO *,int);
+#endif
+#ifndef PerlIO_findFILE
+extern FILE *  PerlIO_findFILE         (PerlIO *);
+#endif
+#ifndef PerlIO_releaseFILE
+extern void    PerlIO_releaseFILE      (PerlIO *,FILE *);
+#endif
+#ifndef PerlIO_read
+extern SSize_t PerlIO_read             (PerlIO *,void *,Size_t);
+#endif
+#ifndef PerlIO_write
+extern SSize_t PerlIO_write            (PerlIO *,const void *,Size_t);
+#endif
+#ifndef PerlIO_setlinebuf
+extern void    PerlIO_setlinebuf       (PerlIO *);
+#endif
+#ifndef PerlIO_printf
+extern int     PerlIO_printf           (PerlIO *, const char *,...)
+                                       __attribute__((__format__ (__printf__, 2, 3)));
+#endif
+#ifndef PerlIO_sprintf
+extern int     PerlIO_sprintf          (char *, int, const char *,...)
+                                       __attribute__((__format__ (__printf__, 3, 4)));
+#endif
+#ifndef PerlIO_vprintf
+extern int     PerlIO_vprintf          (PerlIO *, const char *, va_list);
+#endif
+#ifndef PerlIO_tell
+extern Off_t   PerlIO_tell             (PerlIO *);
+#endif
+#ifndef PerlIO_seek
+extern int     PerlIO_seek             (PerlIO *, Off_t, int);
+#endif
+#ifndef PerlIO_rewind
+extern void    PerlIO_rewind           (PerlIO *);
+#endif
+#ifndef PerlIO_has_base
+extern int     PerlIO_has_base         (PerlIO *);
+#endif
+#ifndef PerlIO_has_cntptr
+extern int     PerlIO_has_cntptr       (PerlIO *);
+#endif
+#ifndef PerlIO_fast_gets
+extern int     PerlIO_fast_gets        (PerlIO *);
+#endif
+#ifndef PerlIO_canset_cnt
+extern int     PerlIO_canset_cnt       (PerlIO *);
+#endif
+#ifndef PerlIO_get_ptr
+extern STDCHAR * PerlIO_get_ptr                (PerlIO *);
+#endif
+#ifndef PerlIO_get_cnt
+extern int     PerlIO_get_cnt          (PerlIO *);
+#endif
+#ifndef PerlIO_set_cnt
+extern void    PerlIO_set_cnt          (PerlIO *,int);
+#endif
+#ifndef PerlIO_set_ptrcnt
+extern void    PerlIO_set_ptrcnt       (PerlIO *,STDCHAR *,int);
+#endif
+#ifndef PerlIO_get_base
+extern STDCHAR * PerlIO_get_base       (PerlIO *);
+#endif
+#ifndef PerlIO_get_bufsiz
+extern int     PerlIO_get_bufsiz       (PerlIO *);
+#endif
+#ifndef PerlIO_tmpfile
+extern PerlIO *        PerlIO_tmpfile          (void);
+#endif
+#ifndef PerlIO_stdin
+extern PerlIO *        PerlIO_stdin            (void);
+#endif
+#ifndef PerlIO_stdout
+extern PerlIO *        PerlIO_stdout           (void);
+#endif
+#ifndef PerlIO_stderr
+extern PerlIO *        PerlIO_stderr           (void);
+#endif
+#ifndef PerlIO_getpos
+extern int     PerlIO_getpos           (PerlIO *,SV *);
+#endif
+#ifndef PerlIO_setpos
+extern int     PerlIO_setpos           (PerlIO *,SV *);
+#endif
+#ifndef PerlIO_fdupopen
+extern PerlIO *        PerlIO_fdupopen         (pTHX_ PerlIO *);
+#endif
+#if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO)
+extern char *PerlIO_modestr            (PerlIO *,char *buf);
+#endif
+#ifndef PerlIO_isutf8
+extern int     PerlIO_isutf8           (PerlIO *);
+#endif
+#ifndef PerlIO_apply_layers
+extern int     PerlIO_apply_layers     (pTHX_ PerlIO *f, const char *mode, const char *names);
+#endif
+#ifndef PerlIO_binmode
+extern int     PerlIO_binmode          (pTHX_ PerlIO *f, int iotype, int omode, const char *names);
+#endif
+
+#ifndef PERLIO_IS_STDIO
+
+extern void PerlIO_cleanup(void);
+
+extern void PerlIO_debug(const char *fmt,...);
+
+#endif
+
+END_EXTERN_C
+
+#endif /* _PERLIO_H */
diff --git a/perliol.h b/perliol.h
new file mode 100644 (file)
index 0000000..04c7071
--- /dev/null
+++ b/perliol.h
@@ -0,0 +1,150 @@
+#ifndef _PERLIOL_H
+#define _PERLIOL_H
+
+struct _PerlIO_funcs
+{
+ char *                name;
+ Size_t                size;
+ IV            kind;
+ IV            (*Fileno)(PerlIO *f);
+ PerlIO *      (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
+ PerlIO *      (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
+ int           (*Reopen)(const char *path, const char *mode, PerlIO *f);
+ IV            (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
+ IV            (*Popped)(PerlIO *f);
+ /* Unix-like functions - cf sfio line disciplines */
+ SSize_t       (*Read)(PerlIO *f, void *vbuf, Size_t count);
+ SSize_t       (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
+ SSize_t       (*Write)(PerlIO *f, const void *vbuf, Size_t count);
+ IV            (*Seek)(PerlIO *f, Off_t offset, int whence);
+ Off_t         (*Tell)(PerlIO *f);
+ IV            (*Close)(PerlIO *f);
+ /* Stdio-like buffered IO functions */
+ IV            (*Flush)(PerlIO *f);
+ IV            (*Fill)(PerlIO *f);
+ IV            (*Eof)(PerlIO *f);
+ IV            (*Error)(PerlIO *f);
+ void          (*Clearerr)(PerlIO *f);
+ void          (*Setlinebuf)(PerlIO *f);
+ /* Perl's snooping functions */
+ STDCHAR *     (*Get_base)(PerlIO *f);
+ Size_t                (*Get_bufsiz)(PerlIO *f);
+ STDCHAR *     (*Get_ptr)(PerlIO *f);
+ SSize_t       (*Get_cnt)(PerlIO *f);
+ void          (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
+};
+
+/*--------------------------------------------------------------------------------------*/
+/* Kind values */
+#define PERLIO_K_RAW           0x00000001
+#define PERLIO_K_BUFFERED      0x00000002
+#define PERLIO_K_CANCRLF       0x00000004
+#define PERLIO_K_FASTGETS      0x00000008
+
+/*--------------------------------------------------------------------------------------*/
+struct _PerlIO
+{
+ PerlIOl *     next;       /* Lower layer */
+ PerlIO_funcs *        tab;        /* Functions for this layer */
+ IV            flags;      /* Various flags for state */
+};
+
+/*--------------------------------------------------------------------------------------*/
+
+/* Flag values */
+#define PERLIO_F_EOF           0x00000100
+#define PERLIO_F_CANWRITE      0x00000200
+#define PERLIO_F_CANREAD       0x00000400
+#define PERLIO_F_ERROR         0x00000800
+#define PERLIO_F_TRUNCATE      0x00001000
+#define PERLIO_F_APPEND                0x00002000
+#define PERLIO_F_CRLF          0x00004000
+#define PERLIO_F_UTF8          0x00008000
+#define PERLIO_F_UNBUF         0x00010000
+#define PERLIO_F_WRBUF         0x00020000
+#define PERLIO_F_RDBUF         0x00040000
+#define PERLIO_F_LINEBUF       0x00080000
+#define PERLIO_F_TEMP          0x00100000
+#define PERLIO_F_OPEN          0x00200000
+#define PERLIO_F_FASTGETS      0x00400000
+
+#define PerlIOBase(f)      (*(f))
+#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
+#define PerlIONext(f)      (&(PerlIOBase(f)->next))
+
+/*--------------------------------------------------------------------------------------*/
+
+extern PerlIO_funcs PerlIO_unix;
+extern PerlIO_funcs PerlIO_perlio;
+extern PerlIO_funcs PerlIO_stdio;
+extern PerlIO_funcs PerlIO_crlf;
+/* The EXT is need for Cygwin -- but why only for _pending? --jhi */
+EXT PerlIO_funcs PerlIO_pending;
+#ifdef HAS_MMAP
+extern PerlIO_funcs PerlIO_mmap;
+#endif
+
+extern PerlIO *PerlIO_allocate(pTHX);
+
+#if O_BINARY != O_TEXT
+#define PERLIO_STDTEXT "t"
+#else
+#define PERLIO_STDTEXT ""
+#endif
+
+/*--------------------------------------------------------------------------------------*/
+/* Generic, or stub layer functions */
+
+extern IV      PerlIOBase_fileno    (PerlIO *f);
+extern IV      PerlIOBase_pushed    (PerlIO *f, const char *mode,const char *arg,STRLEN len);
+extern IV      PerlIOBase_popped    (PerlIO *f);
+extern SSize_t PerlIOBase_unread    (PerlIO *f, const void *vbuf, Size_t count);
+extern IV      PerlIOBase_eof       (PerlIO *f);
+extern IV      PerlIOBase_error     (PerlIO *f);
+extern void    PerlIOBase_clearerr  (PerlIO *f);
+extern IV      PerlIOBase_flush     (PerlIO *f);
+extern IV      PerlIOBase_fill      (PerlIO *f);
+extern IV      PerlIOBase_close     (PerlIO *f);
+extern void    PerlIOBase_setlinebuf(PerlIO *f);
+
+extern IV      PerlIOBase_noop_ok   (PerlIO *f);
+extern IV      PerlIOBase_noop_fail (PerlIO *f);
+
+/*--------------------------------------------------------------------------------------*/
+/* perlio buffer layer
+   As this is reasonably generic its struct and "methods" are declared here
+   so they can be used to "inherit" from it.
+*/
+
+typedef struct
+{
+ struct _PerlIO base;       /* Base "class" info */
+ STDCHAR *     buf;        /* Start of buffer */
+ STDCHAR *     end;        /* End of valid part of buffer */
+ STDCHAR *     ptr;        /* Current position in buffer */
+ Off_t         posn;       /* Offset of buf into the file */
+ Size_t                bufsiz;     /* Real size of buffer */
+ IV            oneword;    /* Emergency buffer */
+} PerlIOBuf;
+
+extern PerlIO *        PerlIOBuf_fdopen     (PerlIO_funcs *self, int fd, const char *mode);
+extern PerlIO *        PerlIOBuf_open       (PerlIO_funcs *self, const char *path, const char *mode);
+extern int     PerlIOBuf_reopen     (const char *path, const char *mode, PerlIO *f);
+extern SSize_t PerlIOBuf_read       (PerlIO *f, void *vbuf, Size_t count);
+extern SSize_t PerlIOBuf_unread     (PerlIO *f, const void *vbuf, Size_t count);
+extern SSize_t PerlIOBuf_write      (PerlIO *f, const void *vbuf, Size_t count);
+extern IV      PerlIOBuf_seek       (PerlIO *f, Off_t offset, int whence);
+extern Off_t   PerlIOBuf_tell       (PerlIO *f);
+extern IV      PerlIOBuf_close      (PerlIO *f);
+extern IV      PerlIOBuf_flush      (PerlIO *f);
+extern IV      PerlIOBuf_fill       (PerlIO *f);
+extern void    PerlIOBuf_setlinebuf (PerlIO *f);
+extern STDCHAR *PerlIOBuf_get_base   (PerlIO *f);
+extern Size_t  PerlIOBuf_bufsiz     (PerlIO *f);
+extern STDCHAR *PerlIOBuf_get_ptr    (PerlIO *f);
+extern SSize_t PerlIOBuf_get_cnt    (PerlIO *f);
+extern void    PerlIOBuf_set_ptrcnt (PerlIO *f, STDCHAR *ptr, SSize_t cnt);
+
+/*--------------------------------------------------------------------------------------*/
+
+#endif /* _PERLIOL_H */
index c4a1179..fd990c0 100644 (file)
@@ -1,25 +1,23 @@
-/*
- * Although we may not want stdio to be used including <stdio.h> here 
- * avoids issues where stdio.h has strange side effects
- */
-#include <stdio.h>
-
 #ifdef PERLIO_IS_STDIO
 /*
+ * This file #define-s the PerlIO_xxx abstraction onto stdio functions.
  * Make this as close to original stdio as possible.
  */
-#define PerlIO                         FILE 
+#define PerlIO                         FILE
 #define PerlIO_stderr()                        stderr
 #define PerlIO_stdout()                        stdout
 #define PerlIO_stdin()                 stdin
 
+#define PerlIO_fdupopen(f)             (f)
+#define PerlIO_isutf8(f)               0
+
 #define PerlIO_printf                  fprintf
 #define PerlIO_stdoutf                 printf
-#define PerlIO_vprintf(f,fmt,a)                vfprintf(f,fmt,a)          
+#define PerlIO_vprintf(f,fmt,a)                vfprintf(f,fmt,a)
 #define PerlIO_write(f,buf,count)      fwrite1(buf,1,count,f)
 #define PerlIO_open                    fopen
 #define PerlIO_fdopen                  fdopen
-#define PerlIO_reopen          freopen
+#define PerlIO_reopen                  freopen
 #define PerlIO_close(f)                        fclose(f)
 #define PerlIO_puts(f,s)               fputs(s,f)
 #define PerlIO_putc(f,c)               fputc(c,f)
                (feof(f) ? EOF : getc(f))
 #  define PerlIO_read(f,buf,count) \
                (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f))
+#  define PerlIO_tell(f)               ftell(f)
 #else
-#  define PerlIO_ungetc(f,c)           ungetc(c,f)
 #  define PerlIO_getc(f)               getc(f)
+#  define PerlIO_ungetc(f,c)           ungetc(c,f)
 #  define PerlIO_read(f,buf,count)     (SSize_t)fread(buf,1,count,f)
+#  define PerlIO_tell(f)               ftell(f)
 #endif
 #define PerlIO_eof(f)                  feof(f)
 #define PerlIO_getname(f,b)            fgetname(f,b)
 #define PerlIO_fileno(f)               fileno(f)
 #define PerlIO_clearerr(f)             clearerr(f)
 #define PerlIO_flush(f)                        Fflush(f)
-#define PerlIO_tell(f)                 ftell(f)
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
-#define ftell ftello
-#endif
 #if defined(VMS) && !defined(__DECC)
-   /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */
-#  define PerlIO_seek(f,o,w)   (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w))
+/* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */
+#define PerlIO_seek(f,o,w)     (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w))
 #else
 #  define PerlIO_seek(f,o,w)           fseek(f,o,w)
 #endif
-#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
-#define fseek fseeko
-#endif
-#ifdef HAS_FGETPOS
-#define PerlIO_getpos(f,p)             fgetpos(f,p)
-#endif
-#ifdef HAS_FSETPOS
-#define PerlIO_setpos(f,p)             fsetpos(f,p)
-#endif
 
 #define PerlIO_rewind(f)               rewind(f)
 #define PerlIO_tmpfile()               tmpfile()
 
-#define PerlIO_importFILE(f,fl)                (f)            
-#define PerlIO_exportFILE(f,fl)                (f)            
-#define PerlIO_findFILE(f)             (f)            
-#define PerlIO_releaseFILE(p,f)                ((void) 0)            
+#define PerlIO_importFILE(f,fl)                (f)
+#define PerlIO_exportFILE(f,fl)                (f)
+#define PerlIO_findFILE(f)             (f)
+#define PerlIO_releaseFILE(p,f)                ((void) 0)
 
 #ifdef HAS_SETLINEBUF
 #define PerlIO_setlinebuf(f)           setlinebuf(f);
 /* Now our interface to Configure's FILE_xxx macros */
 
 #ifdef USE_STDIO_PTR
-#define PerlIO_has_cntptr(f)           1       
-#define PerlIO_get_ptr(f)              FILE_ptr(f)          
-#define PerlIO_get_cnt(f)              FILE_cnt(f)          
+#define PerlIO_has_cntptr(f)           1
+#define PerlIO_get_ptr(f)              FILE_ptr(f)
+#define PerlIO_get_cnt(f)              FILE_cnt(f)
 
 #ifdef STDIO_CNT_LVALUE
-#define PerlIO_canset_cnt(f)           1      
+#define PerlIO_canset_cnt(f)           1
+#define PerlIO_set_cnt(f,c)            (FILE_cnt(f) = (c))
 #ifdef STDIO_PTR_LVALUE
-#define PerlIO_fast_gets(f)            1        
+#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+#define PerlIO_fast_gets(f)            1
 #endif
-#define PerlIO_set_cnt(f,c)            (FILE_cnt(f) = (c))          
-#else
-#define PerlIO_canset_cnt(f)           0      
+#endif /* STDIO_PTR_LVALUE */
+#else /* STDIO_CNT_LVALUE */
+#define PerlIO_canset_cnt(f)           0
 #define PerlIO_set_cnt(f,c)            abort()
 #endif
 
 #ifdef STDIO_PTR_LVALUE
-#define PerlIO_set_ptrcnt(f,p,c)       (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c))          
+#ifdef STDIO_PTR_LVAL_NOCHANGE_CNT
+#define PerlIO_set_ptrcnt(f,p,c)      STMT_START {FILE_ptr(f) = (p), PerlIO_set_cnt(f,c);} STMT_END
+#else
+#ifdef STDIO_PTR_LVAL_SETS_CNT
+/* assert() may pre-process to ""; potential syntax error (FILE_ptr(), ) */
+#define PerlIO_set_ptrcnt(f,p,c)      STMT_START {FILE_ptr(f) = (p); assert(FILE_cnt(f) == (c));} STMT_END
+#define PerlIO_fast_gets(f)            1
 #else
 #define PerlIO_set_ptrcnt(f,p,c)       abort()
 #endif
+#endif
+#endif
 
 #else  /* USE_STDIO_PTR */
 
 #endif /* USE_STDIO_PTR */
 
 #ifndef PerlIO_fast_gets
-#define PerlIO_fast_gets(f)            0        
+#define PerlIO_fast_gets(f)            0
 #endif
 
 
 #ifdef FILE_base
-#define PerlIO_has_base(f)             1         
-#define PerlIO_get_base(f)             FILE_base(f)         
-#define PerlIO_get_bufsiz(f)           FILE_bufsiz(f)       
+#define PerlIO_has_base(f)             1
+#define PerlIO_get_base(f)             FILE_base(f)
+#define PerlIO_get_bufsiz(f)           FILE_bufsiz(f)
 #else
 #define PerlIO_has_base(f)             0
 #define PerlIO_get_base(f)             (abort(),(void *)0)
 #define PerlIO_get_bufsiz(f)           (abort(),0)
 #endif
-#else /* PERLIO_IS_STDIO */
-#ifdef PERL_CORE
-#ifndef PERLIO_NOT_STDIO
-#define PERLIO_NOT_STDIO 1
-#endif
-#endif
-#ifdef PERLIO_NOT_STDIO
-#if PERLIO_NOT_STDIO
-/*
- * Strong denial of stdio - make all stdio calls (we can think of) errors
- */
-#include "nostdio.h"
-#undef fprintf
-#undef tmpfile
-#undef fclose
-#undef fopen
-#undef vfprintf
-#undef fgetc
-#undef fputc
-#undef fputs
-#undef ungetc
-#undef fread
-#undef fwrite
-#undef fgetpos
-#undef fseek
-#undef fsetpos
-#undef ftell
-#undef rewind
-#undef fdopen
-#undef popen
-#undef pclose
-#undef getw
-#undef putw
-#undef freopen
-#undef setbuf
-#undef setvbuf
-#undef fscanf
-#undef fgets
-#undef getc_unlocked
-#undef putc_unlocked
-#define fprintf    _CANNOT _fprintf_
-#define stdin      _CANNOT _stdin_
-#define stdout     _CANNOT _stdout_
-#define stderr     _CANNOT _stderr_
-#define tmpfile()  _CANNOT _tmpfile_
-#define fclose(f)  _CANNOT _fclose_
-#define fflush(f)  _CANNOT _fflush_
-#define fopen(p,m)  _CANNOT _fopen_
-#define freopen(p,m,f)  _CANNOT _freopen_
-#define setbuf(f,b)  _CANNOT _setbuf_
-#define setvbuf(f,b,x,s)  _CANNOT _setvbuf_
-#define fscanf  _CANNOT _fscanf_
-#define vfprintf(f,fmt,a)  _CANNOT _vfprintf_
-#define fgetc(f)  _CANNOT _fgetc_
-#define fgets(s,n,f)  _CANNOT _fgets_
-#define fputc(c,f)  _CANNOT _fputc_
-#define fputs(s,f)  _CANNOT _fputs_
-#define getc(f)  _CANNOT _getc_
-#define putc(c,f)  _CANNOT _putc_
-#define ungetc(c,f)  _CANNOT _ungetc_
-#define fread(b,s,c,f)  _CANNOT _fread_
-#define fwrite(b,s,c,f)  _CANNOT _fwrite_
-#define fgetpos(f,p)  _CANNOT _fgetpos_
-#define fseek(f,o,w)  _CANNOT _fseek_
-#define fsetpos(f,p)  _CANNOT _fsetpos_
-#define ftell(f)  _CANNOT _ftell_
-#define rewind(f)  _CANNOT _rewind_
-#define clearerr(f)  _CANNOT _clearerr_
-#define feof(f)  _CANNOT _feof_
-#define ferror(f)  _CANNOT _ferror_
-#define __filbuf(f)  _CANNOT __filbuf_
-#define __flsbuf(c,f)  _CANNOT __flsbuf_
-#define _filbuf(f)  _CANNOT _filbuf_
-#define _flsbuf(c,f)  _CANNOT _flsbuf_
-#define fdopen(fd,p)  _CANNOT _fdopen_
-#define fileno(f)  _CANNOT _fileno_
-#if SFIO_VERSION < 20000101L
-#define flockfile(f)  _CANNOT _flockfile_
-#define ftrylockfile(f)  _CANNOT _ftrylockfile_
-#define funlockfile(f)  _CANNOT _funlockfile_
-#endif
-#define getc_unlocked(f)  _CANNOT _getc_unlocked_
-#define putc_unlocked(c,f)  _CANNOT _putc_unlocked_
-#define popen(c,m)  _CANNOT _popen_
-#define getw(f)  _CANNOT _getw_
-#define putw(v,f)  _CANNOT _putw_
-#define pclose(f)  _CANNOT _pclose_
-
-#else /* if PERLIO_NOT_STDIO */
-/*
- * PERLIO_NOT_STDIO defined as 0 
- * Declares that both PerlIO and stdio can be used
- */
-#endif /* if PERLIO_NOT_STDIO */
-#else  /* ifdef PERLIO_NOT_STDIO */
-/*
- * PERLIO_NOT_STDIO not defined 
- * This is "source level" stdio compatibility mode.
- */
-#include "nostdio.h"
-#undef FILE
-#define FILE                   PerlIO 
-#undef fprintf
-#undef tmpfile
-#undef fclose
-#undef fopen
-#undef vfprintf
-#undef fgetc
-#undef getc_unlocked
-#undef fputc
-#undef putc_unlocked
-#undef fputs
-#undef ungetc
-#undef fread
-#undef fwrite
-#undef fgetpos
-#undef fseek
-#undef fsetpos
-#undef ftell
-#undef rewind
-#undef fdopen
-#undef popen
-#undef pclose
-#undef getw
-#undef putw
-#undef freopen
-#undef setbuf
-#undef setvbuf
-#undef fscanf
-#undef fgets
-#define fprintf                        PerlIO_printf
-#define stdin                  PerlIO_stdin()
-#define stdout                 PerlIO_stdout()
-#define stderr                 PerlIO_stderr()
-#define tmpfile()              PerlIO_tmpfile()
-#define fclose(f)              PerlIO_close(f)
-#define fflush(f)              PerlIO_flush(f)
-#define fopen(p,m)             PerlIO_open(p,m)
-#define vfprintf(f,fmt,a)      PerlIO_vprintf(f,fmt,a)
-#define fgetc(f)               PerlIO_getc(f)
-#define fputc(c,f)             PerlIO_putc(f,c)
-#define fputs(s,f)             PerlIO_puts(f,s)
-#define getc(f)                        PerlIO_getc(f)
-#ifdef getc_unlocked
-#undef getc_unlocked
-#endif
-#define getc_unlocked(f)       PerlIO_getc(f)
-#define putc(c,f)              PerlIO_putc(f,c)
-#ifdef putc_unlocked
-#undef putc_unlocked
-#endif
-#define putc_unlocked(c,f)     PerlIO_putc(c,f)
-#define ungetc(c,f)            PerlIO_ungetc(f,c)
-#if 0
-/* return values of read/write need work */
-#define fread(b,s,c,f)         PerlIO_read(f,b,(s*c))
-#define fwrite(b,s,c,f)                PerlIO_write(f,b,(s*c))
-#else
-#define fread(b,s,c,f)         _CANNOT fread
-#define fwrite(b,s,c,f)                _CANNOT fwrite
-#endif
-#define fgetpos(f,p)           PerlIO_getpos(f,p)
-#define fseek(f,o,w)           PerlIO_seek(f,o,w)
-#define fsetpos(f,p)           PerlIO_setpos(f,p)
-#define ftell(f)               PerlIO_tell(f)
-#define rewind(f)              PerlIO_rewind(f)
-#define clearerr(f)            PerlIO_clearerr(f)
-#define feof(f)                        PerlIO_eof(f)
-#define ferror(f)              PerlIO_error(f)
-#define fdopen(fd,p)           PerlIO_fdopen(fd,p)
-#define fileno(f)              PerlIO_fileno(f)
-#define popen(c,m)             my_popen(c,m)
-#define pclose(f)              my_pclose(f)
-
-#define __filbuf(f)            _CANNOT __filbuf_
-#define _filbuf(f)             _CANNOT _filbuf_
-#define __flsbuf(c,f)          _CANNOT __flsbuf_
-#define _flsbuf(c,f)           _CANNOT _flsbuf_
-#define getw(f)                        _CANNOT _getw_
-#define putw(v,f)              _CANNOT _putw_
-#if SFIO_VERSION < 20000101L
-#define flockfile(f)           _CANNOT _flockfile_
-#define ftrylockfile(f)                _CANNOT _ftrylockfile_
-#define funlockfile(f)         _CANNOT _funlockfile_
-#endif
-#define freopen(p,m,f)         _CANNOT _freopen_
-#define setbuf(f,b)            _CANNOT _setbuf_
-#define setvbuf(f,b,x,s)       _CANNOT _setvbuf_
-#define fscanf                 _CANNOT _fscanf_
-#define fgets(s,n,f)           _CANNOT _fgets_
 
-#endif /* ifdef PERLIO_NOT_STDIO */
 #endif /* PERLIO_IS_STDIO */
index d0f6471..de7e9ac 100644 (file)
@@ -5,7 +5,7 @@
 
 /* sfio 2000 changed _stdopen to _stdfdopen */
 #if SFIO_VERSION >= 20000101L
-#define _stdopen _stdfdopen 
+#define _stdopen _stdfdopen
 #endif
 
 extern Sfio_t* _stdopen _ARG_((int, const char*));
@@ -16,9 +16,11 @@ extern int   _stdprintf _ARG_((const char*, ...));
 #define PerlIO_stdout()                        sfstdout
 #define PerlIO_stdin()                 sfstdin
 
+#define PerlIO_isutf8(f)               0
+
 #define PerlIO_printf                  sfprintf
 #define PerlIO_stdoutf                 _stdprintf
-#define PerlIO_vprintf(f,fmt,a)                sfvprintf(f,fmt,a)          
+#define PerlIO_vprintf(f,fmt,a)                sfvprintf(f,fmt,a)
 #define PerlIO_read(f,buf,count)       sfread(f,buf,count)
 #define PerlIO_write(f,buf,count)      sfwrite(f,buf,count)
 #define PerlIO_open(path,mode)         sfopen(NULL,path,mode)
@@ -35,7 +37,12 @@ extern int   _stdprintf _ARG_((const char*, ...));
 #define PerlIO_fileno(f)               sffileno(f)
 #define PerlIO_clearerr(f)             sfclrerr(f)
 #define PerlIO_flush(f)                        sfsync(f)
+#if 0
+/* This breaks tests */
+#define PerlIO_tell(f)                 sfseek(f,0,1|SF_SHARE)
+#else
 #define PerlIO_tell(f)                 sftell(f)
+#endif
 #define PerlIO_seek(f,o,w)             sfseek(f,o,w)
 #define PerlIO_rewind(f)               (void) sfseek((f),0L,0)
 #define PerlIO_tmpfile()               sftmp(0)
@@ -49,15 +56,15 @@ extern int  _stdprintf _ARG_((const char*, ...));
 
 /* Now our interface to equivalent of Configure's FILE_xxx macros */
 
-#define PerlIO_has_cntptr(f)           1       
+#define PerlIO_has_cntptr(f)           1
 #define PerlIO_get_ptr(f)              ((f)->next)
 #define PerlIO_get_cnt(f)              ((f)->endr - (f)->next)
-#define PerlIO_canset_cnt(f)           1      
-#define PerlIO_fast_gets(f)            1        
-#define PerlIO_set_ptrcnt(f,p,c)       ((f)->next = (unsigned char *)(p))          
-#define PerlIO_set_cnt(f,c)            1
+#define PerlIO_canset_cnt(f)           1
+#define PerlIO_fast_gets(f)            1
+#define PerlIO_set_ptrcnt(f,p,c)       STMT_START {(f)->next = (unsigned char *)(p); assert(PerlIO_get_cnt(f) == (c));} STMT_END
+#define PerlIO_set_cnt(f,c)            STMT_START {(f)->next = (f)->endr - (c);} STMT_END
 
-#define PerlIO_has_base(f)             1         
+#define PerlIO_has_base(f)             1
 #define PerlIO_get_base(f)             ((f)->data)
 #define PerlIO_get_bufsiz(f)           ((f)->endr - (f)->data)
 
diff --git a/perly.c b/perly.c
index d03d3de..2b5108f 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -1747,7 +1747,7 @@ case 35:
 break;
 case 37:
 #line 269 "perly.y"
-{ (void)scan_num("1"); yyval.opval = yylval.opval; }
+{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
 break;
 case 39:
 #line 274 "perly.y"
diff --git a/perly.y b/perly.y
index 5170b36..74802f4 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -1,6 +1,6 @@
 /*    perly.y
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -266,7 +266,7 @@ nexpr       :       /* NULL */
        ;
 
 texpr  :       /* NULL means true */
-                       { (void)scan_num("1"); $$ = yylval.opval; }
+                       { (void)scan_num("1", &yylval); $$ = yylval.opval; }
        |       expr
        ;
 
index ae6262c..58ce9be 100644 (file)
@@ -64,6 +64,7 @@ POD2HTML = pod2html \
            --libpods=perlfunc:perlguts:perlvar:perlrun:perlop
 
 PERL = ../miniperl
+PERLILIB = $(PERL) -I../lib
 REALPERL = ../perl
 
 all: $(CONVERTERS) man
@@ -73,7 +74,9 @@ converters: $(CONVERTERS)
 regen_pods: perlmodlib.pod toc
 
 buildtoc:      buildtoc.PL perl.pod ../MANIFEST
-       $(PERL) -I ../lib buildtoc.PL
+       $(PERLILIB) buildtoc.PL
+
+perltoc.pod:   buildtoc
 
 man:   pod2man $(MAN)
 
@@ -82,7 +85,7 @@ html: pod2html $(HTML)
 tex:   pod2latex $(TEX)
 
 toc:   buildtoc
-       $(PERL) -I../lib buildtoc
+       $(PERLILIB) buildtoc
 
 .SUFFIXES: .pm .pod
 
index 3819308..f2dba95 100644 (file)
@@ -154,12 +154,16 @@ if (-d "pod") {
     perlamiga          
     perlcygwin          
     perldos             
+    perlepoc             
     perlhpux            
     perlmachten         
+    perlmpeix         
     perlos2             
     perlos390           
     perlposix-bc
+    perlsolaris
     perlvms             
+    perlvos             
     perlwin32           
          );
 
@@ -168,12 +172,16 @@ if (-d "pod") {
     perlamiga          
     perlcygwin          
     perldos             
+    perlepoc             
     perlhpux            
     perlmachten         
+    perlmpeix
     perlos2             
     perlos390           
     perlposix-bc
+    perlsolaris
     perlvms             
+    perlvos             
     perlwin32           
           );
 for (@ARCHPODS) { s/$/.pod/ }
@@ -328,7 +336,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
        Here should be listed all the extra programs' documentation, but they
        don't all have manual pages yet:
 
-       =over
+       =over 4
 
        =item a2p
 
@@ -381,13 +389,13 @@ sub podset {
        }
        if (s/^=head1 (.*)/=item $1/) {
            unhead2();
-           output "=over\n\n" unless $inhead1;
+           output "=over 4\n\n" unless $inhead1;
            $inhead1 = 1;
            output $_; nl(); next;
        }
        if (s/^=head2 (.*)/=item $1/) {
            unitem();
-           output "=over\n\n" unless $inhead2;
+           output "=over 4\n\n" unless $inhead2;
            $inhead2 = 1;
            output $_; nl(); next;
        }
@@ -399,7 +407,7 @@ sub podset {
            s/\s+$//;
            next if /^[\d.]+$/;
            next if $pod eq 'perlmodlib' && /^ftp:/;
-           ##print "=over\n\n" unless $initem;
+           ##print "=over 4\n\n" unless $initem;
            output ", " if $initem;
            $initem = 1;
            s/\.$//;
index 946d6f2..4e08cc8 100644 (file)
@@ -108,12 +108,16 @@ For ease of access, the Perl manual has been split up into several sections:
     perlamiga          Perl notes for Amiga
     perlcygwin         Perl notes for Cygwin
     perldos            Perl notes for DOS
+    perlepoc           Perl notes for EPOC
     perlhpux           Perl notes for HP-UX
     perlmachten                Perl notes for Power MachTen
+    perlmpeix          Perl notes for MPE/iX
     perlos2            Perl notes for OS/2
     perlos390          Perl notes for OS/390
     perlposix-bc       Perl notes for POSIX-BC
+    perlsolaris        Perl notes for Solaris
     perlvms            Perl notes for VMS
+    perlvos            Perl notes for Stratus VOS
     perlwin32          Perl notes for Windows
 
 (If you're intending to read these straight through for the first time,
@@ -187,58 +191,85 @@ But wait, there's more...
 Begun in 1993 (see L<perlhist>), Perl version 5 is nearly a complete
 rewrite that provides the following additional benefits:
 
-=over
+=over 4
 
-=item * modularity and reusability using innumerable modules 
+=item *
+
+modularity and reusability using innumerable modules 
 
 Described in L<perlmod>, L<perlmodlib>, and L<perlmodinstall>.
 
-=item * embeddable and extensible 
+=item *
+
+embeddable and extensible 
 
 Described in L<perlembed>, L<perlxstut>, L<perlxs>, L<perlcall>,
 L<perlguts>, and L<xsubpp>.
 
-=item * roll-your-own magic variables (including multiple simultaneous DBM implementations)
+=item *
+
+roll-your-own magic variables (including multiple simultaneous DBM implementations)
 
 Described in L<perltie> and L<AnyDBM_File>.
 
-=item * subroutines can now be overridden, autoloaded, and prototyped
+=item *
+
+subroutines can now be overridden, autoloaded, and prototyped
 
 Described in L<perlsub>.
 
-=item * arbitrarily nested data structures and anonymous functions
+=item *
+
+arbitrarily nested data structures and anonymous functions
 
 Described in L<perlreftut>, L<perlref>, L<perldsc>, and L<perllol>.
 
-=item * object-oriented programming
+=item *
+
+object-oriented programming
 
 Described in L<perlobj>, L<perltoot>, and L<perlbot>.
 
-=item * compilability into C code or Perl bytecode
+=item *
+
+compilability into C code or Perl bytecode
 
 Described in L<B> and L<B::Bytecode>.
 
-=item * support for light-weight processes (threads)
+=item *
+
+support for light-weight processes (threads)
 
 Described in L<perlthrtut> and L<Thread>.
 
-=item * support for internationalization, localization, and Unicode 
+=item *
+
+support for internationalization, localization, and Unicode 
 
 Described in L<perllocale> and L<utf8>.
 
-=item * lexical scoping
+=item *
+
+lexical scoping
 
 Described in L<perlsub>.
 
-=item * regular expression enhancements
+=item *
+
+regular expression enhancements
 
 Described in L<perlre>, with additional examples in L<perlop>.
 
-=item * enhanced debugger and interactive Perl environment, with integrated editor support
+=item *
+
+enhanced debugger and interactive Perl environment,
+with integrated editor support
 
 Described in L<perldebug>.
 
-=item * POSIX 1003.1 compliant library
+=item *
+
+POSIX 1003.1 compliant library
 
 Described in L<POSIX>.
 
index 8cec3ab..429cba9 100644 (file)
@@ -24,7 +24,10 @@ problems.  See the F<Changes> file in the distribution for details.
 C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS
 where it generates a fatal error).
 
-=head2 "Can't locate Foo.pm in @INC" error now lists @INC
+=head2 Change to "Can't locate Foo.pm in @INC" error
+
+The error "Can't locate Foo.pm in @INC" now lists the contents of @INC
+for easier debugging.
 
 =head2 Compilation option: Binary compatibility with 5.003
 
@@ -198,7 +201,7 @@ hole was just plugged.
 
 The new restrictions when tainting include:
 
-=over
+=over 4
 
 =item No glob() or <*>
 
@@ -258,7 +261,7 @@ the F<INSTALL> file for how to use it.
 
 =head2 New and changed syntax
 
-=over
+=over 4
 
 =item $coderef->(PARAMS)
 
@@ -276,7 +279,7 @@ S<C<< $table->{FOO}->($bar) >>>.
 
 =head2 New and changed builtin constants
 
-=over
+=over 4
 
 =item __PACKAGE__
 
@@ -289,7 +292,7 @@ into strings.
 
 =head2 New and changed builtin variables
 
-=over
+=over 4
 
 =item $^E
 
@@ -322,7 +325,7 @@ there is no C<use English> long name for this variable.
 
 =head2 New and changed builtin functions
 
-=over
+=over 4
 
 =item delete on slices
 
@@ -544,7 +547,7 @@ subroutine:
 The C<UNIVERSAL> package automatically contains the following methods that
 are inherited by all other classes:
 
-=over
+=over 4
 
 =item isa(CLASS)
 
@@ -593,7 +596,7 @@ have C<isa> available as a plain subroutine in the current package.
 
 See L<perltie> for other kinds of tie()s.
 
-=over
+=over 4
 
 =item TIEHANDLE classname, LIST
 
@@ -687,7 +690,7 @@ install the optional module Devel::Peek.)
 Three new compilation flags are recognized by malloc.c.  (They have no
 effect if perl is compiled with system malloc().)
 
-=over
+=over 4
 
 =item -DPERL_EMERGENCY_SBRK
 
@@ -779,7 +782,7 @@ See F<README.amigaos> in the perl distribution.
 
 Six new pragmatic modules exist:
 
-=over
+=over 4
 
 =item use autouse MODULE => qw(sub1 sub2 sub3)
 
@@ -979,7 +982,7 @@ those who need trigonometric functions only for real numbers.
 There have been quite a few changes made to DB_File. Here are a few of
 the highlights:
 
-=over
+=over 4
 
 =item *
 
@@ -1045,7 +1048,7 @@ For example, you can now say
 
 =head2 pod2html
 
-=over
+=over 4
 
 =item Sends converted HTML to standard output
 
@@ -1058,7 +1061,7 @@ Use the B<--outfile=FILENAME> option to write to a file.
 
 =head2 xsubpp
 
-=over
+=over 4
 
 =item C<void> XSUBs now default to returning nothing
 
@@ -1083,7 +1086,7 @@ XSUB's return type is really C<SV *>.
 
 =head1 C Language API Changes
 
-=over
+=over 4
 
 =item C<gv_fetchmethod> and C<perl_call_sv>
 
@@ -1124,7 +1127,7 @@ which can be more efficient.  See L<perlguts> for details.
 Many of the base and library pods were updated.  These
 new pods are included in section 1:
 
-=over
+=over 4
 
 =item L<perldelta>
 
@@ -1177,7 +1180,7 @@ increasing order of desperation):
    (X) A very fatal error (nontrappable).
    (A) An alien error message (not generated by Perl).
 
-=over
+=over 4
 
 =item "my" variable %s masks earlier declaration in same scope
 
@@ -1429,7 +1432,7 @@ assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves
 like a list when you assign to it, and provides a list context to its
 subscript, which can do weird things if you're expecting only one subscript.
 
-=item Stub found while resolving method `%s' overloading `%s' in package `%s'
+=item Stub found while resolving method `%s' overloading `%s' in %s
 
 (P) Overloading resolution over @ISA tree may be broken by importing stubs.
 Stubs should never be implicitly created, but explicit calls to C<can>
index b133c0d..4b50f40 100644 (file)
@@ -63,11 +63,15 @@ the new features in this release.
 
 =over 4
 
-=item Core sources now require ANSI C compiler
+=item *
+
+Core sources now require ANSI C compiler
 
 An ANSI C compiler is now B<required> to build perl.  See F<INSTALL>.
 
-=item All Perl global variables must now be referenced with an explicit prefix
+=item *
+
+All Perl global variables must now be referenced with an explicit prefix
 
 All Perl global variables that are visible for use by extensions now
 have a C<PL_> prefix.  New extensions should C<not> refer to perl globals
@@ -87,7 +91,9 @@ support may cease in a future release.
 
 See L<perlguts/"API LISTING">.
 
-=item Enabling threads has source compatibility issues
+=item *
+
+Enabling threads has source compatibility issues
 
 Perl built with threading enabled requires extensions to use the new
 C<dTHR> macro to initialize the handle to access per-thread data.
@@ -525,7 +531,7 @@ The hints files for most Unix platforms have seen incremental improvements.
 
 =head2 New Modules
 
-=over
+=over 4
 
 =item B
 
@@ -596,7 +602,7 @@ Various pragmata to control behavior of regular expressions.
 
 =head2 Changes in existing modules
 
-=over
+=over 4
 
 =item Benchmark
 
@@ -702,7 +708,7 @@ L<perlthrtut> gives a tutorial on threads.
 
 =head1 New Diagnostics
 
-=over
+=over 4
 
 =item Ambiguous call resolved as CORE::%s(), qualify as such or use &
 
@@ -859,7 +865,7 @@ are outside the range which can be represented by integers internally.
 One possible workaround is to force Perl to use magical string
 increment by prepending "0" to your numbers.
 
-=item Recursive inheritance detected while looking for method '%s' in package '%s'
+=item Recursive inheritance detected while looking for method '%s' %s
 
 (F) More than 100 levels of inheritance were encountered while invoking a
 method.  Probably indicates an unintended loop in your inheritance hierarchy.
@@ -916,7 +922,7 @@ fix the problem can be found in L<perllocale/"LOCALE PROBLEMS">.
 
 =head1 Obsolete Diagnostics
 
-=over
+=over 4
 
 =item Can't mktemp()
 
index 9f30314..fc0d668 100644 (file)
@@ -786,7 +786,7 @@ regardless of whether or not the array has been used or declared
 already.  The fatal error has been downgraded to an optional warning:
 
         Possible unintended interpolation of @example in string
-        
+
 This warns you that C<"fred@example.com"> is going to turn into
 C<fred.com> if you don't backslash the C<@>.
 See http://www.plover.com/~mjd/perl/at-error.html for more details
@@ -1837,7 +1837,8 @@ run in compile-only mode.  Since this is typically not the expected
 behavior, END blocks are not executed anymore when the C<-c> switch
 is used, or if compilation fails.
 
-See L<CHECK blocks> for how to run things when the compile phase ends.
+See L</"Support for CHECK blocks"> for how to run things when the compile 
+phase ends.
 
 =head2 Potential to leak DATA filehandles
 
@@ -2630,9 +2631,12 @@ but still allowed it.
 
 In Perl 5.6.0 and later, C<"$$1"> always means C<"${$1}">.
 
-=item delete(), values() and C<\(%h)> operate on aliases to values, not copies
+=item delete(), each(), values() and C<\(%h)>
+
+operate on aliases to values, not copies
 
-delete(), each(), values() and hashes in a list context return the actual
+delete(), each(), values() and hashes (e.g. C<\(%h)>)
+in a list context return the actual
 values in the hash, instead of copies (as they used to in earlier
 versions).  Typical idioms for using these constructs copy the
 returned values, but this can make a significant difference when
@@ -2782,7 +2786,7 @@ See L<perlguts/"Memory Allocation"> for further information about that.
 
 =head2 Compatible C Source API Changes
 
-=over
+=over 4
 
 =item C<PATCHLEVEL> is now C<PERL_VERSION>
 
@@ -2912,7 +2916,9 @@ include the following:
 
 =item The DB module
 
-=item The regular expression constructs C<(?{ code })> and C<(??{ code })>
+=item The regular expression code constructs: 
+
+C<(?{ code })> and C<(??{ code })>
 
 =back
 
index 98abdc1..f5596e2 100644 (file)
@@ -287,6 +287,19 @@ Returns the stash of the CV.
 =for hackers
 Found in file cv.h
 
+=item cv_const_sv
+
+If C<cv> is a constant sub eligible for inlining. returns the constant
+value returned by the sub.  Otherwise, returns NULL.
+
+Constant subs can be created with C<newCONSTSUB> or as described in
+L<perlsub/"Constant Functions">.
+
+       SV*     cv_const_sv(CV* cv)
+
+=for hackers
+Found in file op.c
+
 =item dMARK
 
 Declare a stack marker variable, C<mark>, for the XSUB.  See C<MARK> and
@@ -748,7 +761,7 @@ hash and returned to the caller.  The C<klen> is the length of the key.
 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
 will be returned.
 
-       SV*     hv_delete(HV* tb, const char* key, U32 klen, I32 flags)
+       SV*     hv_delete(HV* tb, const char* key, I32 klen, I32 flags)
 
 =for hackers
 Found in file hv.c
@@ -770,7 +783,7 @@ Found in file hv.c
 Returns a boolean indicating whether the specified hash key exists.  The
 C<klen> is the length of the key.
 
-       bool    hv_exists(HV* tb, const char* key, U32 klen)
+       bool    hv_exists(HV* tb, const char* key, I32 klen)
 
 =for hackers
 Found in file hv.c
@@ -796,7 +809,7 @@ dereferencing it to a C<SV*>.
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
 
-       SV**    hv_fetch(HV* tb, const char* key, U32 klen, I32 lval)
+       SV**    hv_fetch(HV* tb, const char* key, I32 klen, I32 lval)
 
 =for hackers
 Found in file hv.c
@@ -907,7 +920,7 @@ the call, and decrementing it if the function returned NULL.
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
 
-       SV**    hv_store(HV* tb, const char* key, U32 klen, SV* val, U32 hash)
+       SV**    hv_store(HV* tb, const char* key, I32 klen, SV* val, U32 hash)
 
 =for hackers
 Found in file hv.c
@@ -1032,7 +1045,8 @@ Found in file scope.h
 =item looks_like_number
 
 Test if an the content of an SV looks like a number (or is a
-number).
+number). C<Inf> and C<Infinity> are treated as numbers (so will not
+issue a non-numeric warning), even if your atof() doesn't grok them.
 
        I32     looks_like_number(SV* sv)
 
@@ -1162,7 +1176,7 @@ Found in file handy.h
 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
 eligible for inlining at compile-time.
 
-       void    newCONSTSUB(HV* stash, char* name, SV* sv)
+       CV*     newCONSTSUB(HV* stash, char* name, SV* sv)
 
 =for hackers
 Found in file op.c
@@ -1270,7 +1284,7 @@ The idea here is that as string table is used for shared hash
 keys these strings will have SvPVX == HeKEY and hash lookup
 will avoid string compare.
 
-       SV*     newSVpvn_share(const char* s, STRLEN len, U32 hash)
+       SV*     newSVpvn_share(const char* s, I32 len, U32 hash)
 
 =for hackers
 Found in file sv.c
@@ -1430,7 +1444,7 @@ Found in file perl.c
 =item PL_DBsingle
 
 When Perl is run in debugging mode, with the B<-d> switch, this SV is a
-boolean which indicates whether subs are being single-stepped. 
+boolean which indicates whether subs are being single-stepped.
 Single-stepping is automatically turned on after every step.  This is the C
 variable which corresponds to Perl's $DB::single variable.  See
 C<PL_DBsub>.
@@ -1474,10 +1488,10 @@ Found in file intrpvar.h
 
 =item PL_modglobal
 
-C<PL_modglobal> is a general purpose, interpreter global HV for use by 
+C<PL_modglobal> is a general purpose, interpreter global HV for use by
 extensions that need to keep information on a per-interpreter basis.
-In a pinch, it can also be used as a symbol table for extensions 
-to share data among each other.  It is a good idea to use keys 
+In a pinch, it can also be used as a symbol table for extensions
+to share data among each other.  It is a good idea to use keys
 prefixed by the package name of the extension that owns the data.
 
        HV*     PL_modglobal
@@ -2421,6 +2435,15 @@ Type flag for blessed scalars.  See C<svtype>.
 =for hackers
 Found in file sv.h
 
+=item SvUOK
+
+Returns a boolean indicating whether the SV contains an unsigned integer.
+
+       void    SvUOK(SV* sv)
+
+=for hackers
+Found in file sv.h
+
 =item SvUPGRADE
 
 Used to upgrade an SV to a more complex form.  Uses C<sv_upgrade> to
@@ -2559,8 +2582,9 @@ Found in file sv.c
 
 =item sv_catsv
 
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
+not 'set' magic.  See C<sv_catsv_mg>.
 
        void    sv_catsv(SV* dsv, SV* ssv)
 
@@ -3050,13 +3074,29 @@ Found in file sv.c
 
 Unsets the RV status of the SV, and decrements the reference count of
 whatever was being referenced by the RV.  This can almost be thought of
-as a reversal of C<newSVrv>.  See C<SvROK_off>.
+as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
+being zero.  See C<SvROK_off>.
 
        void    sv_unref(SV* sv)
 
 =for hackers
 Found in file sv.c
 
+=item sv_unref_flags
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV.  This can almost be thought of
+as a reversal of C<newSVrv>.  The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.
+
+       void    sv_unref_flags(SV* sv, U32 flags)
+
+=for hackers
+Found in file sv.c
+
 =item sv_upgrade
 
 Upgrade an SV to a more complex form.  Use C<SvUPGRADE>.  See
@@ -3190,6 +3230,44 @@ string, false otherwise.
 =for hackers
 Found in file utf8.c
 
+=item utf8_distance
+
+Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+and C<b>.
+
+WARNING: use only if you *know* that the pointers point inside the
+same UTF-8 buffer.
+
+       IV      utf8_distance(U8 *a, U8 *b)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8_hop
+
+Return the UTF-8 pointer C<s> displaced by C<off> characters, either
+forward or backward.
+
+WARNING: do not use the following unless you *know* C<off> is within
+the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
+on the first byte of character or just after the last byte of a character.
+
+       U8*     utf8_hop(U8 *s, I32 off)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8_length
+
+Return the length of the UTF-8 char encoded string C<s> in characters.
+Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
+up past C<e>, croaks.
+
+       STRLEN  utf8_length(U8* s, U8 *e)
+
+=for hackers
+Found in file utf8.c
+
 =item utf8_to_bytes
 
 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
@@ -3205,32 +3283,35 @@ Found in file utf8.c
 =item utf8_to_uv
 
 Returns the character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
-length, in bytes, of that character, and the pointer C<s> will be
-advanced to the end of the character.
+which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+C<retlen> will be set to the length, in bytes, of that character.
 
-If C<s> does not point to a well-formed UTF8 character, an optional UTF8
-warning is produced.
+If C<s> does not point to a well-formed UTF8 character, the behaviour
+is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
+it is assumed that the caller will raise a warning, and this function
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
 
-       U8* s   utf8_to_uv(I32 *retlen)
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
+
+       U8* s   utf8_to_uv(STRLEN curlen, STRLEN *retlen, U32 flags)
 
 =for hackers
 Found in file utf8.c
 
-=item utf8_to_uv_chk
+=item utf8_to_uv_simple
 
 Returns the character value of the first character in the string C<s>
 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
-length, in bytes, of that character, and the pointer C<s> will be
-advanced to the end of the character.
+length, in bytes, of that character.
 
-If C<s> does not point to a well-formed UTF8 character, the behaviour
-is dependent on the value of C<checking>: if this is true, it is
-assumed that the caller will raise a warning, and this function will
-set C<retlen> to C<-1> and return. If C<checking> is not true, an optional UTF8
-warning is produced.
+If C<s> does not point to a well-formed UTF8 character, zero is
+returned and retlen is set, if possible, to -1.
 
-       U8* s   utf8_to_uv_chk(I32 *retlen, I32 checking)
+       U8* s   utf8_to_uv_simple(STRLEN *retlen)
 
 =for hackers
 Found in file utf8.c
index 742423b..20cc546 100644 (file)
@@ -23,7 +23,7 @@ frame was called with are copied to the @DB::args array.  The
 general mechanisms is enabled by calling Perl with the B<-d> switch, the
 following additional features are enabled (cf. L<perlvar/$^P>):
 
-=over
+=over 4
 
 =item *
 
@@ -402,7 +402,7 @@ shorter than 7 chars.
 
 The fields of interest which may appear in the last line are
 
-=over
+=over 4
 
 =item C<anchored> I<STRING> C<at> I<POS>
 
@@ -693,7 +693,7 @@ Devel::Peek module.
 
 Here is some explanation of that format:
 
-=over
+=over 4
 
 =item C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>
 
@@ -840,7 +840,7 @@ per glob - for glob name, and glob stringification magic.
 
 Here are explanations for other I<Id>s above: 
 
-=over
+=over 4
 
 =item C<717> 
 
@@ -894,7 +894,7 @@ these categories.
 
 If warn() string starts with
 
-=over
+=over 4
 
 =item C<!!!> 
 
index 2916897..ece5848 100644 (file)
@@ -495,7 +495,7 @@ And a print to show what values we're currently using:
 
        DB<1> p $deg, $num
        f33.3
-               
+
 We can put another break point on any line beginning with a colon, we'll use
 line 17 as that's just as we come out of the subroutine, and we'd like to
 pause there later on:
@@ -538,7 +538,7 @@ it for inspection.  In this case though, we simply continue down to line 29:
 
        DB<4> c 29  
        main::f2c(temp:29):             return $c;
-   
+
 And have a look at the return value:
 
        DB<5> p $c
@@ -616,7 +616,7 @@ the DEBUGGING flag for this one:
        floating `'$ at 4..2147483647 (checking floating) stclass `EXACTF <pe>'
 anchored(BOL) minlen 4
        Omitting $` $& $' support.
-        
+
        EXECUTING...
 
        Freeing REx: `^pe(a)*rl$'  
@@ -656,7 +656,7 @@ script from the command-line, try something like this:
 
        > perl -d my_cgi.pl -nodebug 
 
-Of course 'L<perldoc CGI>' and L<perlfaq9> will tell you more.
+Of course L<CGI> and L<perlfaq9> will tell you more.
 
 
 =head1 GUIs
index faff39b..01f35e1 100644 (file)
@@ -82,7 +82,7 @@ recursively, unlike the real C<print> function in Perl.
 See L<Dumpvalue> if you'd like to do this yourself.
 
 The output format is governed by multiple options described under
-L<"Options">.
+L<"Configurable Options">.
 
 =item V [pkg [vars]]
 
@@ -308,8 +308,8 @@ For historical reasons, the C<=value> is optional, but defaults to
 1 only where it is safe to do so--that is, mostly for Boolean
 options.  It is always better to assign a specific value using C<=>.
 The C<option> can be abbreviated, but for clarity probably should
-not be.  Several options can be set together.  See L<"Options"> for
-a list of these.
+not be.  Several options can be set together.  See L<"Configurable Options"> 
+for a list of these.
 
 =item < ? 
 
index 480ab84..22a24be 100644 (file)
@@ -402,6 +402,11 @@ L<perlport> for more on portability concerns.
 (W closed) You tried to do a bind on a closed socket.  Did you forget to
 check the return value of your socket() call?  See L<perlfunc/bind>.
 
+=item binmode() on closed filehandle %s
+
+(W unopened) You tried binmode() on a filehandle that was never opened.
+Check you control flow and number of arguments.
+
 =item Bit vector size > 32 non-portable
 
 (W portable) Using bit vector sizes larger than 32 is non-portable.
@@ -651,6 +656,13 @@ If you're getting this error from a here-document, you may have included
 unseen whitespace before or after your closing tag. A good programmer's
 editor will have a way to help you find these characters.
 
+=item Can't find %s property definition %s 
+
+(F) You may have tried to use C<\p> which means a Unicode property for
+example \p{Lu} is all uppercase letters.  Escape the C<\p>, either
+C<\\p> (just the C<\p>) or by C<\Q\p> (the rest of the string, until
+possible C<\E>).
+
 =item Can't fork
 
 (F) A fatal error occurred while trying to fork while opening a
@@ -1086,7 +1098,7 @@ on I<Mastering Regular Expressions>.)
 to check the return value of your socket() call?  See
 L<perlfunc/connect>.
 
-=item constant(%s): %s
+=item Constant(%s)%s: %s
 
 (F) The parser found inconsistencies either while attempting to define
 an overloaded constant, or when trying to find the character name
@@ -1116,8 +1128,8 @@ workarounds.
 
 =item Copy method did not return a reference
 
-(F) The method which overloads "=" is buggy. See L<overload/Copy
-Constructor>.
+(F) The method which overloads "=" is buggy. See 
+L<overload/Copy Constructor>.
 
 =item CORE::%s is not a keyword
 
@@ -1380,7 +1392,7 @@ name.
 =item flock() on closed filehandle %s
 
 (W closed) The filehandle you're attempting to flock() got itself closed
-some time before now.  Check your logic flow.  flock() operates on
+some time before now.  Check your control flow.  flock() operates on
 filehandles.  Are you attempting to call flock() on a dirhandle by the
 same name?
 
@@ -1660,8 +1672,8 @@ shows in the regular expression about where the problem was discovered.
 
 (W syntax) You've run afoul of the rule that says that any list operator
 followed by parentheses turns into a function, with all the list
-operators arguments found inside the parentheses.  See L<perlop/Terms
-and List Operators (Leftward)>.
+operators arguments found inside the parentheses.  See 
+L<perlop/Terms and List Operators (Leftward)>.
 
 =item Invalid %s attribute: %s
 
@@ -1713,6 +1725,11 @@ silently ignored.
 (F) Your machine apparently doesn't implement ioctl(), which is pretty
 strange for a machine that supports C.
 
+=item ioctl() on unopened %s
+
+(W unopened) You tried ioctl() on a filehandle that was never opened.
+Check you control flow and number of arguments.
+
 =item `%s' is not a code reference
 
 (W) The second (fourth, sixth, ...) argument of overload::constant needs
@@ -1768,7 +1785,7 @@ instead on the filehandle.)
 values cannot be returned in subroutines used in lvalue context.  See
 L<perlsub/"Lvalue subroutines">.
 
-=item Lookbehind longer than %d not implemented before << HERE in reges m/%s/
+=item Lookbehind longer than %d not implemented before << HERE %s
 
 (F) There is currently a limit on the length of string which lookbehind can
 handle. This restriction may be eased in a future release. The << HERE shows in
@@ -1789,6 +1806,10 @@ a builtin library search path, prefix2 is substituted.  The error may
 appear if components are not found, or are too long.  See
 "PERLLIB_PREFIX" in L<perlos2>.
 
+=item Malformed UTF-8 character (%s)
+
+Perl detected something that didn't comply with UTF-8 encoding rules.
+
 =item Malformed UTF-16 surrogate
 
 Perl thought it was reading UTF-16 encoded character data but while
@@ -2266,9 +2287,9 @@ the buffer and zero pad the new area.
 =item -%s on unopened filehandle %s
 
 (W unopened) You tried to invoke a file test operator on a filehandle
-that isn't open.  Check your logic.  See also L<perlfunc/-X>.
+that isn't open.  Check your control flow.  See also L<perlfunc/-X>.
 
-=item %s() on unopened %s %s
+=item %s() on unopened %s
 
 (W unopened) An I/O operation was attempted on a filehandle that was
 never initialized.  You need to do an open(), a sysopen(), or a socket()
@@ -2325,7 +2346,8 @@ The request was judged to be small, so the possibility to trap it
 depends on the way perl was compiled.  By default it is not trappable.
 However, if compiled for this, Perl may use the contents of C<$^M> as an
 emergency pool after die()ing with this message.  In this case the error
-is trappable I<once>.
+is trappable I<once>, and the error message will include the line and file
+where the failed request happened.
 
 =item Out of memory during ridiculously large request
 
@@ -2383,23 +2405,19 @@ reference.
 (P) We popped the context stack to an eval context, and then discovered
 it wasn't an eval context.
 
-=item panic: do_match
+=item panic: pp_match
 
 (P) The internal pp_match() routine was called with invalid operational
 data.
 
-=item panic: do_split
-
-(P) Something terrible went wrong in setting up for the split.
-
 =item panic: do_subst
 
 (P) The internal pp_subst() routine was called with invalid operational
 data.
 
-=item panic: do_trans
+=item panic: do_trans_%s
 
-(P) The internal do_trans() routine was called with invalid operational
+(P) The internal do_trans routines were called with invalid operational
 data.
 
 =item panic: frexp
@@ -2491,6 +2509,10 @@ and freeing temporaries and lexicals from.
 
 (P) The foreach iterator got called in a non-loop context frame.
 
+=item panic: pp_split
+
+(P) Something terrible went wrong in setting up for the split.
+
 =item panic: realloc
 
 (P) Something requested a negative number of bytes of realloc.
@@ -2563,13 +2585,23 @@ C<sh>-shell in.  See "PERL_SH_DIR" in L<perlos2>.
 
 Exactly what were the failed locale settings varies.  In the above the
 settings were that the LC_ALL was "En_US" and the LANG had no value.
-This error means that Perl detected that you and/or your system
-administrator have set up the so-called variable system but Perl could
-not use those settings.  This was not dead serious, fortunately: there
-is a "default locale" called "C" that Perl can and will use, the script
-will be run.  Before you really fix the problem, however, you will get
-the same error message each time you run Perl.  How to really fix the
-problem can be found in L<perllocale> section B<LOCALE PROBLEMS>.
+This error means that Perl detected that you and/or your operating
+system supplier and/or system administrator have set up the so-called
+locale system but Perl could not use those settings.  This was not
+dead serious, fortunately: there is a "default locale" called "C" that
+Perl can and will use, the script will be run.  Before you really fix
+the problem, however, you will get the same error message each time
+you run Perl.  How to really fix the problem can be found in
+L<perllocale> section B<LOCALE PROBLEMS>.
+
+=item perlio: unknown layer "%s"
+
+(S) An attempt was made to push an unknown layer onto the Perl I/O
+system.  (Layers take care of transforming data between external and
+internal representations.)  Note that some layers, such as C<mmap>,
+are not supported in all environments.  If your program didn't
+explicitly request the failing operation, it may be the result of the
+value of the environment variable PERLIO.
 
 =item Permission denied
 
@@ -2712,12 +2744,12 @@ See Server error.
 =item printf() on closed filehandle %s
 
 (W closed) The filehandle you're writing to got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item print() on closed filehandle %s
 
 (W closed) The filehandle you're printing on got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item Process terminated by SIG%s
 
@@ -2738,7 +2770,7 @@ declared or defined with a different function prototype.
 {min,max} construct. The << HERE shows in the regular expression about where
 the problem was discovered. See L<perlre>.
 
-=item Quantifier unexpected on zero-length expression before << HERE in regex m/%s/
+=item Quantifier unexpected on zero-length expression before << HERE %s
 
 (W regexp) You applied a regular expression quantifier in a place where
 it makes no sense, such as on a zero-width assertion.  Try putting the
@@ -2756,7 +2788,7 @@ by prepending "0" to your numbers.
 =item readline() on closed filehandle %s
 
 (W closed) The filehandle you're reading from got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item Reallocation too large: %lx
 
@@ -2899,9 +2931,10 @@ filehandle that was either never opened or has since been closed.
 
 (F) This machine doesn't implement the select() system call.
 
-=item Self-ties are not supported
+=item Self-ties of arrays and hashes are not supported
 
-(F) Self-ties are not supported in the current implementation.
+(F) Self-ties are of arrays and hashes are not supported in
+the current implementation.
 
 =item Semicolon seems to be missing
 
@@ -2920,7 +2953,7 @@ scalar that had previously been marked as free.
 =item send() on closed socket %s
 
 (W closed) The socket you're sending to got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item Sequence (? incomplete before << HERE mark in regex m/%s/
 
@@ -2928,18 +2961,18 @@ before now.  Check your logic flow.
 shows in the regular expression about where the problem was discovered. See
 L<perlre>.
 
-=item Sequence (?{...}) not terminated or not {}-balanced in regex m/%s/
+=item Sequence (?{...}) not terminated or not {}-balanced in %s
 
 (F) If the contents of a (?{...}) clause contains braces, they must balance
 for Perl to properly detect the end of the clause. See L<perlre>.
 
-=item Sequence (?%s...) not implemented before << HERE mark in regex m/%s/
+=item Sequence (?%s...) not implemented before << HERE mark in %s
 
 (F) A proposed regular expression extension has the character reserved but
 has not yet been written. The << HERE shows in the regular expression about
 where the problem was discovered. See L<perlre>.
 
-=item Sequence (?%s...) not recognized before << HERE mark in regex m/%s/
+=item Sequence (?%s...) not recognized before << HERE mark in %s
 
 (F) You used a regular expression extension that doesn't make sense.
 The << HERE shows in the regular expression about
@@ -3130,7 +3163,7 @@ assignment or as a subroutine argument for example).
 (F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but
 a version of the setuid emulator somehow got run anyway.
 
-=item Switch (?(condition)... contains too many branches before << HERE in regex m/%s/
+=item Switch (?(condition)... contains too many branches before << HE%s
 
 (F) A (?(condition)if-clause|else-clause) construct can have at most two
 branches (the if-clause and the else-clause). If you want one or both to
@@ -3195,7 +3228,7 @@ unconfigured.  Consult your system support.
 =item syswrite() on closed filehandle %s
 
 (W closed) The filehandle you're writing to got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item Target of goto is too deeply nested
 
@@ -3235,7 +3268,7 @@ will deny it.
 The function indicated isn't implemented on this architecture, according
 to the probings of Configure.
 
-=item The stat preceding C<-l _> wasn't an lstat
+=item The stat preceding %s wasn't an lstat
 
 (F) It makes no sense to test the current stat buffer for symbolic
 linkhood if the last stat that wrote to the stat buffer already went
@@ -3677,6 +3710,15 @@ old way has bad side effects.
 (D deprecated) This was an ill-advised attempt to emulate a poorly
 defined B<awk> feature.  Use an explicit printf() or sprintf() instead.
 
+=item Use of reference "%s" in array index
+
+(W) You tried to use a reference as an array index; this probably
+isn't what you mean, because references tend to be huge numbers which
+take you out of memory, and so usually indicates programmer error.
+
+If you really do mean it, explicitly numify your reference, like so: 
+C<$array[0+$ref]>
+
 =item Use of reserved word "%s" is deprecated
 
 (D deprecated) The indicated bareword is a reserved word.  Future
@@ -3780,7 +3822,7 @@ anonymous, using the C<sub {}> syntax.  When inner anonymous subs that
 reference variables in outer subroutines are called or referenced, they
 are automatically rebound to the current values of such variables.
 
-=item Variable length lookbehind not implemented before << HERE in regex m/%s/
+=item Variable length lookbehind not implemented before << HERE in %s
 
 (F) Lookbehind is allowed only for subexpressions whose length is fixed and
 known at compile time. The << HERE shows in the regular expression about where
@@ -3829,7 +3871,7 @@ So put in parentheses to say what you really mean.
 =item write() on closed filehandle %s
 
 (W closed) The filehandle you're writing to got itself closed sometime
-before now.  Check your logic flow.
+before now.  Check your control flow.
 
 =item X outside of string
 
index 4ef5eca..12ea2f3 100644 (file)
@@ -501,7 +501,8 @@ provide easy to use ASCII to EBCDIC operations that are also easily
 reversed.
 
 For example, to convert ASCII to code page 037 take the output of the second 
-column from the output of recipe 0 and use it in tr/// like so:
+column from the output of recipe 0 (modified to add \\ characters) and use 
+it in tr/// like so:
 
     $cp_037 = 
     '\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017' .
@@ -524,15 +525,19 @@ column from the output of recipe 0 and use it in tr/// like so:
     my $ebcdic_string = $ascii_string;
     eval '$ebcdic_string =~ tr/\000-\377/' . $cp_037 . '/';
 
-To convert from EBCDIC 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;
-    eval '$ascii_string = tr/' . $code_page_chrs . '/\000-\037/';
+    eval '$ascii_string = tr/' . $cp_037 . '/\000-\377/';
+
+Similarly one could take the output of the third column from recipe 0 to
+obtain a C<$cp_1047> table.  The fourth column of the output from recipe
+0 could provide a C<$cp_posix_bc> table suitable for transcoding as well.
 
 =head2 iconv
 
-XPG4 operability often implies the presence of an I<iconv> utility
+XPG operability often implies the presence of an I<iconv> utility
 available from the shell or from the C library.  Consult your system's
 documentation for information on iconv.
 
index 1787e4b..57d1bdb 100644 (file)
@@ -37,25 +37,45 @@ Read on...
 
 =over 5
 
-L<Compiling your C program>
+=item *
 
-L<Adding a Perl interpreter to your C program>
+Compiling your C program
 
-L<Calling a Perl subroutine from your C program>
+=item *
 
-L<Evaluating a Perl statement from your C program>
+Adding a Perl interpreter to your C program
 
-L<Performing Perl pattern matches and substitutions from your C program>
+=item *
 
-L<Fiddling with the Perl stack from your C program>
+Calling a Perl subroutine from your C program
 
-L<Maintaining a persistent interpreter>
+=item *
 
-L<Maintaining multiple interpreter instances>
+Evaluating a Perl statement from your C program
 
-L<Using Perl modules, which themselves use C libraries, from your C program>
+=item *
 
-L<Embedding Perl under Win32>
+Performing Perl pattern matches and substitutions from your C program
+
+=item *
+
+Fiddling with the Perl stack from your C program
+
+=item *
+
+Maintaining a persistent interpreter
+
+=item *
+
+Maintaining multiple interpreter instances
+
+=item *
+
+Using Perl modules, which themselves use C libraries, from your C program
+
+=item *
+
+Embedding Perl under Win32
 
 =back 
 
@@ -258,9 +278,8 @@ and package C<END {}> blocks.
 If you want to pass arguments to the Perl subroutine, you can add
 strings to the C<NULL>-terminated C<args> list passed to
 I<call_argv>.  For other data types, or to examine return values,
-you'll need to manipulate the Perl stack.  That's demonstrated in the
-last section of this document: L<Fiddling with the Perl stack from
-your C program>.
+you'll need to manipulate the Perl stack.  That's demonstrated in
+L<Fiddling with the Perl stack from your C program>.
 
 =head2 Evaluating a Perl statement from your C program
 
@@ -948,7 +967,7 @@ B<ExtUtils::Embed> can also automate writing the I<xs_init> glue code.
 
 Consult L<perlxs>, L<perlguts>, and L<perlapi> for more details.
 
-=head1 Embedding Perl under Windows
+=head1 Embedding Perl under Win32
 
 In general, all of the source code shown here should work unmodified under
 Windows.
index fa6943f..bc29c69 100644 (file)
@@ -4,710 +4,1303 @@ perlfaq - frequently asked questions about Perl ($Date: 1999/05/23 20:38:02 $)
 
 =head1 DESCRIPTION
 
-This document is structured into the following sections:
+The perlfaq is structured into the following documents:
 
-=over
 
-=item perlfaq: Structural overview of the FAQ.
+=head2 perlfaq: Structural overview of the FAQ.
 
 This document.
 
-=item L<perlfaq1>: General Questions About Perl
+=head2 L<perlfaq1>: General Questions About Perl
 
 Very general, high-level information about Perl.
 
 =over 4
 
-=item * What is Perl?
+=item *
 
-=item * Who supports Perl?  Who develops it?  Why is it free?
+What is Perl?
 
-=item * Which version of Perl should I use?
+=item *
 
-=item * What are perl4 and perl5?
+Who supports Perl?  Who develops it?  Why is it free?
 
-=item * What is perl6?
+=item *
 
-=item * How stable is Perl?
+Which version of Perl should I use?
 
-=item * Is Perl difficult to learn?
+=item *
 
-=item * How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl?
+What are perl4 and perl5?
 
-=item * Can I do [task] in Perl?
+=item *
 
-=item * When shouldn't I program in Perl?
+What is perl6?
 
-=item * What's the difference between "perl" and "Perl"?
+=item *
 
-=item * Is it a Perl program or a Perl script?
+How stable is Perl?
 
-=item * What is a JAPH?
+=item *
 
-=item * Where can I get a list of Larry Wall witticisms?
+Is Perl difficult to learn?
 
-=item * How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)?
+=item *
+
+How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl?
+
+=item *
+
+Can I do [task] in Perl?
+
+=item *
+
+When shouldn't I program in Perl?
+
+=item *
+
+What's the difference between "perl" and "Perl"?
+
+=item *
+
+Is it a Perl program or a Perl script?
+
+=item *
+
+What is a JAPH?
+
+=item *
+
+Where can I get a list of Larry Wall witticisms?
+
+=item *
+
+How can I convince my sysadmin/supervisor/employees to use version 5/5.005/Perl instead of some other language?
 
 =back
 
 
-=item L<perlfaq2>: Obtaining and Learning about Perl
+=head2 L<perlfaq2>: Obtaining and Learning about Perl
 
 Where to find source and documentation to Perl, support,
 and related matters.
 
 =over 4
 
-=item * What machines support Perl?  Where do I get it?
+=item *
+
+What machines support Perl?  Where do I get it?
+
+=item *
+
+How can I get a binary version of Perl?
+
+=item *
 
-=item * How can I get a binary version of Perl?
+I don't have a C compiler on my system.  How can I compile perl?
 
-=item * I don't have a C compiler on my system.  How can I compile perl?
+=item *
 
-=item * I copied the Perl binary from one machine to another, but scripts don't work.
+I copied the Perl binary from one machine to another, but scripts don't work.
 
-=item * I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed.  How do I make it work?
+=item *
 
-=item * What modules and extensions are available for Perl?  What is CPAN?  What does CPAN/src/... mean?
+I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed.  How do I make it work?
 
-=item * Is there an ISO or ANSI certified version of Perl?
+=item *
 
-=item * Where can I get information on Perl?
+What modules and extensions are available for Perl?  What is CPAN?  What does CPAN/src/... mean?
 
-=item * What are the Perl newsgroups on USENET?  Where do I post questions?
+=item *
 
-=item * Where should I post source code?
+Is there an ISO or ANSI certified version of Perl?
 
-=item * Perl Books
+=item *
 
-=item * Perl in Magazines
+Where can I get information on Perl?
 
-=item * Perl on the Net: FTP and WWW Access
+=item *
 
-=item * What mailing lists are there for perl?
+What are the Perl newsgroups on Usenet?  Where do I post questions?
 
-=item * Archives of comp.lang.perl.misc
+=item *
 
-=item * Where can I buy a commercial version of Perl?
+Where should I post source code?
 
-=item * Where do I send bug reports?
+=item *
 
-=item * What is perl.com?  
+Perl Books
+
+=item *
+
+Perl in Magazines
+
+=item *
+
+Perl on the Net: FTP and WWW Access
+
+=item *
+
+What mailing lists are there for Perl?
+
+=item *
+
+Archives of comp.lang.perl.misc
+
+=item *
+
+Where can I buy a commercial version of Perl?
+
+=item *
+
+Where do I send bug reports?
+
+=item *
+
+What is perl.com? Perl Mongers? pm.org? perl.org?
 
 =back
 
 
-=item L<perlfaq3>: Programming Tools
+=head2 L<perlfaq3>: Programming Tools
 
 Programmer tools and programming support.
 
 =over 4
 
-=item * How do I do (anything)?
+=item *
+
+How do I do (anything)?
+
+=item *
+
+How can I use Perl interactively?
+
+=item *
+
+Is there a Perl shell?
 
-=item * How can I use Perl interactively?
+=item *
 
-=item * Is there a Perl shell?
+How do I debug my Perl programs?
 
-=item * How do I debug my Perl programs?
+=item *
 
-=item * How do I profile my Perl programs?
+How do I profile my Perl programs?
 
-=item * How do I cross-reference my Perl programs?
+=item *
 
-=item * Is there a pretty-printer (formatter) for Perl?
+How do I cross-reference my Perl programs?
 
-=item * Is there a ctags for Perl?
+=item *
 
-=item * Is there an IDE or Windows Perl Editor?
+Is there a pretty-printer (formatter) for Perl?
 
-=item * Where can I get Perl macros for vi?
+=item *
 
-=item * Where can I get perl-mode for emacs?
+Is there a ctags for Perl?
 
-=item * How can I use curses with Perl?
+=item *
 
-=item * How can I use X or Tk with Perl?
+Is there an IDE or Windows Perl Editor?
 
-=item * How can I generate simple menus without using CGI or Tk?
+=item *
 
-=item * What is undump?
+Where can I get Perl macros for vi?
 
-=item * How can I make my Perl program run faster?
+=item *
 
-=item * How can I make my Perl program take less memory?
+Where can I get perl-mode for emacs?
 
-=item * Is it unsafe to return a pointer to local data?
+=item *
 
-=item * How can I free an array or hash so my program shrinks?
+How can I use curses with Perl?
 
-=item * How can I make my CGI script more efficient?
+=item *
 
-=item * How can I hide the source for my Perl program?
+How can I use X or Tk with Perl?
 
-=item * How can I compile my Perl program into byte code or C?
+=item *
 
-=item * How can I compile Perl into Java?
+How can I generate simple menus without using CGI or Tk?
 
-=item * How can I get C<#!perl> to work on [MS-DOS,NT,...]?
+=item *
 
-=item * Can I write useful perl programs on the command line?
+What is undump?
 
-=item * Why don't perl one-liners work on my DOS/Mac/VMS system?
+=item *
 
-=item * Where can I learn about CGI or Web programming in Perl?
+How can I make my Perl program run faster?
 
-=item * Where can I learn about object-oriented Perl programming?
+=item *
 
-=item * Where can I learn about linking C with Perl? [h2xs, xsubpp]
+How can I make my Perl program take less memory?
 
-=item * I've read perlembed, perlguts, etc., but I can't embed perl in
-my C program, what am I doing wrong?
+=item *
 
-=item * When I tried to run my script, I got this message. What does it
+Is it unsafe to return a pointer to local data?
+
+=item *
+
+How can I free an array or hash so my program shrinks?
+
+=item *
+
+How can I make my CGI script more efficient?
+
+=item *
+
+How can I hide the source for my Perl program?
+
+=item *
+
+How can I compile my Perl program into byte code or C?
+
+=item *
+
+How can I compile Perl into Java?
+
+=item *
+
+How can I get C<#!perl> to work on [MS-DOS,NT,...]?
+
+=item *
+
+Can I write useful Perl programs on the command line?
+
+=item *
+
+Why don't Perl one-liners work on my DOS/Mac/VMS system?
+
+=item *
+
+Where can I learn about CGI or Web programming in Perl?
+
+=item *
+
+Where can I learn about object-oriented Perl programming?
+
+=item *
+
+Where can I learn about linking C with Perl? [h2xs, xsubpp]
+
+=item *
+
+I've read perlembed, perlguts, etc., but I can't embed perl in
+my C program; what am I doing wrong?
+
+=item *
+
+When I tried to run my script, I got this message. What does it
 mean?
 
-=item * What's MakeMaker?
+=item *
+
+What's MakeMaker?
 
 =back
 
 
-=item L<perlfaq4>: Data Manipulation
+=head2 L<perlfaq4>: Data Manipulation
 
 Manipulating numbers, dates, strings, arrays, hashes, and
 miscellaneous data issues.
 
 =over 4
 
-=item * Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?
+=item *
+
+Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?
+
+=item *
+
+Why isn't my octal data interpreted correctly?
+
+=item *
+
+Does Perl have a round() function?  What about ceil() and floor()?  Trig functions?
+
+=item *
+
+How do I convert bits into ints?
+
+=item *
+
+Why doesn't & work the way I want it to?
+
+=item *
 
-=item * Why isn't my octal data interpreted correctly?
+How do I multiply matrices?
 
-=item * Does Perl have a round() function?  What about ceil() and floor()?  Trig functions?
+=item *
 
-=item * How do I convert bits into ints?
+How do I perform an operation on a series of integers?
 
-=item * Why doesn't & work the way I want it to?
+=item *
 
-=item * How do I multiply matrices?
+How can I output Roman numerals?
 
-=item * How do I perform an operation on a series of integers?
+=item *
 
-=item * How can I output Roman numerals?
+Why aren't my random numbers random?
 
-=item * Why aren't my random numbers random?
+=item *
 
-=item * How do I find the week-of-the-year/day-of-the-year?
+How do I find the week-of-the-year/day-of-the-year?
 
-=item * How do I find the current century or millennium?
+=item *
 
-=item * How can I compare two dates and find the difference?
+How do I find the current century or millennium?
 
-=item * How can I take a string and turn it into epoch seconds?
+=item *
 
-=item * How can I find the Julian Day?
+How can I compare two dates and find the difference?
 
-=item * How do I find yesterday's date?
+=item *
 
-=item * Does Perl have a year 2000 problem?  Is Perl Y2K compliant?
+How can I take a string and turn it into epoch seconds?
 
-=item * How do I validate input?
+=item *
 
-=item * How do I unescape a string?
+How can I find the Julian Day?
 
-=item * How do I remove consecutive pairs of characters?
+=item *
 
-=item * How do I expand function calls in a string?
+How do I find yesterday's date?
 
-=item * How do I find matching/nesting anything?
+=item *
 
-=item * How do I reverse a string?
+Does Perl have a Year 2000 problem?  Is Perl Y2K compliant?
 
-=item * How do I expand tabs in a string?
+=item *
 
-=item * How do I reformat a paragraph?
+How do I validate input?
 
-=item * How can I access/change the first N letters of a string?
+=item *
 
-=item * How do I change the Nth occurrence of something?
+How do I unescape a string?
 
-=item * How can I count the number of occurrences of a substring within a string?
+=item *
 
-=item * How do I capitalize all the words on one line?
+How do I remove consecutive pairs of characters?
 
-=item * How can I split a [character] delimited string except when inside
+=item *
+
+How do I expand function calls in a string?
+
+=item *
+
+How do I find matching/nesting anything?
+
+=item *
+
+How do I reverse a string?
+
+=item *
+
+How do I expand tabs in a string?
+
+=item *
+
+How do I reformat a paragraph?
+
+=item *
+
+How can I access/change the first N letters of a string?
+
+=item *
+
+How do I change the Nth occurrence of something?
+
+=item *
+
+How can I count the number of occurrences of a substring within a string?
+
+=item *
+
+How do I capitalize all the words on one line?
+
+=item *
+
+How can I split a [character] delimited string except when inside
 [character]? (Comma-separated files)
 
-=item * How do I strip blank space from the beginning/end of a string?
+=item *
+
+How do I strip blank space from the beginning/end of a string?
+
+=item *
+
+How do I pad a string with blanks or pad a number with zeroes?
+
+=item *
+
+How do I extract selected columns from a string?
+
+=item *
+
+How do I find the soundex value of a string?
+
+=item *
+
+How can I expand variables in text strings?
+
+=item *
+
+What's wrong with always quoting "$vars"?
+
+=item *
+
+Why don't my <<HERE documents work?
+
+=item *
+
+What is the difference between a list and an array?
+
+=item *
+
+What is the difference between $array[1] and @array[1]?
+
+=item *
+
+How can I remove duplicate elements from a list or array?
 
-=item * How do I pad a string with blanks or pad a number with zeroes?
+=item *
 
-=item * How do I extract selected columns from a string?
+How can I tell whether a list or array contains a certain element?
 
-=item * How do I find the soundex value of a string?
+=item *
 
-=item * How can I expand variables in text strings?
+How do I compute the difference of two arrays?  How do I compute the intersection of two arrays?
 
-=item * What's wrong with always quoting "$vars"?
+=item *
 
-=item * Why don't my <<HERE documents work?
+How do I test whether two arrays or hashes are equal?
 
-=item * What is the difference between a list and an array?
+=item *
 
-=item * What is the difference between $array[1] and @array[1]?
+How do I find the first array element for which a condition is true?
 
-=item * How can I remove duplicate elements from a list or array?
+=item *
 
-=item * How can I tell whether a list or array contains a certain element?
+How do I handle linked lists?
 
-=item * How do I compute the difference of two arrays?  How do I compute the intersection of two arrays?
+=item *
 
-=item * How do I test whether two arrays or hashes are equal?
+How do I handle circular lists?
 
-=item * How do I find the first array element for which a condition is true?
+=item *
 
-=item * How do I handle linked lists?
+How do I shuffle an array randomly?
 
-=item * How do I handle circular lists?
+=item *
 
-=item * How do I shuffle an array randomly?
+How do I process/modify each element of an array?
 
-=item * How do I process/modify each element of an array?
+=item *
 
-=item * How do I select a random element from an array?
+How do I select a random element from an array?
 
-=item * How do I permute N elements of a list?
+=item *
 
-=item * How do I sort an array by (anything)?
+How do I permute N elements of a list?
 
-=item * How do I manipulate arrays of bits?
+=item *
 
-=item * Why does defined() return true on empty arrays and hashes?
+How do I sort an array by (anything)?
 
-=item * How do I process an entire hash?
+=item *
 
-=item * What happens if I add or remove keys from a hash while iterating over it?
+How do I manipulate arrays of bits?
 
-=item * How do I look up a hash element by value?
+=item *
 
-=item * How can I know how many entries are in a hash?
+Why does defined() return true on empty arrays and hashes?
 
-=item * How do I sort a hash (optionally by value instead of key)?
+=item *
 
-=item * How can I always keep my hash sorted?
+How do I process an entire hash?
 
-=item * What's the difference between "delete" and "undef" with hashes?
+=item *
 
-=item * Why don't my tied hashes make the defined/exists distinction?
+What happens if I add or remove keys from a hash while iterating over it?
 
-=item * How do I reset an each() operation part-way through?
+=item *
 
-=item * How can I get the unique keys from two hashes?
+How do I look up a hash element by value?
 
-=item * How can I store a multidimensional array in a DBM file?
+=item *
 
-=item * How can I make my hash remember the order I put elements into it?
+How can I know how many entries are in a hash?
 
-=item * Why does passing a subroutine an undefined element in a hash create it?
+=item *
 
-=item * How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays?
+How do I sort a hash (optionally by value instead of key)?
 
-=item * How can I use a reference as a hash key?
+=item *
 
-=item * How do I handle binary data correctly?
+How can I always keep my hash sorted?
 
-=item * How do I determine whether a scalar is a number/whole/integer/float?
+=item *
 
-=item * How do I keep persistent data across program calls?
+What's the difference between "delete" and "undef" with hashes?
 
-=item * How do I print out or copy a recursive data structure?
+=item *
 
-=item * How do I define methods for every class/object?
+Why don't my tied hashes make the defined/exists distinction?
 
-=item * How do I verify a credit card checksum?
+=item *
 
-=item * How do I pack arrays of doubles or floats for XS code?
+How do I reset an each() operation part-way through?
+
+=item *
+
+How can I get the unique keys from two hashes?
+
+=item *
+
+How can I store a multidimensional array in a DBM file?
+
+=item *
+
+How can I make my hash remember the order I put elements into it?
+
+=item *
+
+Why does passing a subroutine an undefined element in a hash create it?
+
+=item *
+
+How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays?
+
+=item *
+
+How can I use a reference as a hash key?
+
+=item *
+
+How do I handle binary data correctly?
+
+=item *
+
+How do I determine whether a scalar is a number/whole/integer/float?
+
+=item *
+
+How do I keep persistent data across program calls?
+
+=item *
+
+How do I print out or copy a recursive data structure?
+
+=item *
+
+How do I define methods for every class/object?
+
+=item *
+
+How do I verify a credit card checksum?
+
+=item *
+
+How do I pack arrays of doubles or floats for XS code?
 
 =back
 
 
-=item L<perlfaq5>: Files and Formats
+=head2 L<perlfaq5>: Files and Formats
 
 I/O and the "f" issues: filehandles, flushing, formats and footers.
 
 =over 4
 
-=item * How do I flush/unbuffer an output filehandle?  Why must I do this?
+=item *
+
+How do I flush/unbuffer an output filehandle?  Why must I do this?
+
+=item *
+
+How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file?
+
+=item *
+
+How do I count the number of lines in a file?
+
+=item *
+
+How do I make a temporary file name?
+
+=item *
+
+How can I manipulate fixed-record-length files?
+
+=item *
+
+How can I make a filehandle local to a subroutine?  How do I pass filehandles between subroutines?  How do I make an array of filehandles?
 
-=item * How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file?
+=item *
 
-=item * How do I count the number of lines in a file?
+How can I use a filehandle indirectly?
 
-=item * How do I make a temporary file name?
+=item *
 
-=item * How can I manipulate fixed-record-length files?
+How can I set up a footer format to be used with write()?
 
-=item * How can I make a filehandle local to a subroutine?  How do I pass filehandles between subroutines?  How do I make an array of filehandles?
+=item *
 
-=item * How can I use a filehandle indirectly?
+How can I write() into a string?
 
-=item * How can I set up a footer format to be used with write()?
+=item *
 
-=item * How can I write() into a string?
+How can I output my numbers with commas added?
 
-=item * How can I output my numbers with commas added?
+=item *
 
-=item * How can I translate tildes (~) in a filename?
+How can I translate tildes (~) in a filename?
 
-=item * How come when I open a file read-write it wipes it out?
+=item *
 
-=item * Why do I sometimes get an "Argument list too long" when I use <*>?
+How come when I open a file read-write it wipes it out?
 
-=item * Is there a leak/bug in glob()?
+=item *
 
-=item * How can I open a file with a leading ">" or trailing blanks?
+Why do I sometimes get an "Argument list too long" when I use <*>?
 
-=item * How can I reliably rename a file?
+=item *
 
-=item * How can I lock a file?
+Is there a leak/bug in glob()?
 
-=item * Why can't I just open(FH, ">file.lock")?
+=item *
 
-=item * I still don't get locking.  I just want to increment the number in the file.  How can I do this?
+How can I open a file with a leading ">" or trailing blanks?
 
-=item * How do I randomly update a binary file?
+=item *
 
-=item * How do I get a file's timestamp in perl?
+How can I reliably rename a file?
 
-=item * How do I set a file's timestamp in perl?
+=item *
 
-=item * How do I print to more than one file at once?
+How can I lock a file?
 
-=item * How can I read in an entire file all at once?
+=item *
 
-=item * How can I read in a file by paragraphs?
+Why can't I just open(FH, ">file.lock")?
 
-=item * How can I read a single character from a file?  From the keyboard?
+=item *
 
-=item * How can I tell whether there's a character waiting on a filehandle?
+I still don't get locking.  I just want to increment the number in the file.  How can I do this?
 
-=item * How do I do a C<tail -f> in perl?
+=item *
 
-=item * How do I dup() a filehandle in Perl?
+How do I randomly update a binary file?
 
-=item * How do I close a file descriptor by number?
+=item *
 
-=item * Why can't I use "C:\temp\foo" in DOS paths?  What doesn't `C:\temp\foo.exe` work?
+How do I get a file's timestamp in perl?
 
-=item * Why doesn't glob("*.*") get all the files?
+=item *
 
-=item * Why does Perl let me delete read-only files?  Why does C<-i> clobber protected files?  Isn't this a bug in Perl?
+How do I set a file's timestamp in perl?
 
-=item * How do I select a random line from a file?
+=item *
 
-=item * Why do I get weird spaces when I print an array of lines?
+How do I print to more than one file at once?
+
+=item *
+
+How can I read in an entire file all at once?
+
+=item *
+
+How can I read in a file by paragraphs?
+
+=item *
+
+How can I read a single character from a file?  From the keyboard?
+
+=item *
+
+How can I tell whether there's a character waiting on a filehandle?
+
+=item *
+
+How do I do a C<tail -f> in perl?
+
+=item *
+
+How do I dup() a filehandle in Perl?
+
+=item *
+
+How do I close a file descriptor by number?
+
+=item *
+
+Why can't I use "C:\temp\foo" in DOS paths?  What doesn't `C:\temp\foo.exe` work?
+
+=item *
+
+Why doesn't glob("*.*") get all the files?
+
+=item *
+
+Why does Perl let me delete read-only files?  Why does C<-i> clobber protected files?  Isn't this a bug in Perl?
+
+=item *
+
+How do I select a random line from a file?
+
+=item *
+
+Why do I get weird spaces when I print an array of lines?
 
 =back
 
 
-=item L<perlfaq6>: Regexps
+=head2 L<perlfaq6>: Regexps
 
 Pattern matching and regular expressions.
 
 =over 4
 
-=item * How can I hope to use regular expressions without creating illegible and unmaintainable code?
+=item *
+
+How can I hope to use regular expressions without creating illegible and unmaintainable code?
+
+=item *
+
+I'm having trouble matching over more than one line.  What's wrong?
+
+=item *
+
+How can I pull out lines between two patterns that are themselves on different lines?
+
+=item *
+
+I put a regular expression into $/ but it didn't work. What's wrong?
+
+=item *
+
+How do I substitute case insensitively on the LHS while preserving case on the RHS?
+
+=item *
+
+How can I make C<\w> match national character sets?
+
+=item *
+
+How can I match a locale-smart version of C</[a-zA-Z]/>?
+
+=item *
 
-=item * I'm having trouble matching over more than one line.  What's wrong?
+How can I quote a variable to use in a regex?
 
-=item * How can I pull out lines between two patterns that are themselves on different lines?
+=item *
 
-=item * I put a regular expression into $/ but it didn't work. What's wrong?
+What is C</o> really for?
 
-=item * How do I substitute case insensitively on the LHS, but preserving case on the RHS?
+=item *
 
-=item * How can I make C<\w> match national character sets?
+How do I use a regular expression to strip C style comments from a file?
 
-=item * How can I match a locale-smart version of C</[a-zA-Z]/>?
+=item *
 
-=item * How can I quote a variable to use in a regex?
+Can I use Perl regular expressions to match balanced text?
 
-=item * What is C</o> really for?
+=item *
 
-=item * How do I use a regular expression to strip C style comments from a file?
+What does it mean that regexes are greedy?  How can I get around it?
 
-=item * Can I use Perl regular expressions to match balanced text?
+=item *
 
-=item * What does it mean that regexes are greedy?  How can I get around it?
+How do I process each word on each line?
 
-=item * How do I process each word on each line?
+=item *
 
-=item * How can I print out a word-frequency or line-frequency summary?
+How can I print out a word-frequency or line-frequency summary?
 
-=item * How can I do approximate matching?
+=item *
 
-=item * How do I efficiently match many regular expressions at once?
+How can I do approximate matching?
 
-=item * Why don't word-boundary searches with C<\b> work for me?
+=item *
 
-=item * Why does using $&, $`, or $' slow my program down?
+How do I efficiently match many regular expressions at once?
 
-=item * What good is C<\G> in a regular expression?
+=item *
 
-=item * Are Perl regexes DFAs or NFAs?  Are they POSIX compliant?
+Why don't word-boundary searches with C<\b> work for me?
 
-=item * What's wrong with using grep or map in a void context?
+=item *
 
-=item * How can I match strings with multibyte characters?
+Why does using $&, $`, or $' slow my program down?
 
-=item * How do I match a pattern that is supplied by the user?
+=item *
+
+What good is C<\G> in a regular expression?
+
+=item *
+
+Are Perl regexes DFAs or NFAs?  Are they POSIX compliant?
+
+=item *
+
+What's wrong with using grep or map in a void context?
+
+=item *
+
+How can I match strings with multibyte characters?
+
+=item *
+
+How do I match a pattern that is supplied by the user?
 
 =back
 
 
-=item L<perlfaq7>: General Perl Language Issues
+=head2 L<perlfaq7>: General Perl Language Issues
 
 General Perl language issues that don't clearly fit into any of the
 other sections.
 
 =over 4
 
-=item * Can I get a BNF/yacc/RE for the Perl language?
+=item *
+
+Can I get a BNF/yacc/RE for the Perl language?
+
+=item *
+
+What are all these $@%&* punctuation signs, and how do I know when to use them?
+
+=item *
+
+Do I always/never have to quote my strings or use semicolons and commas?
+
+=item *
+
+How do I skip some return values?
+
+=item *
+
+How do I temporarily block warnings?
+
+=item *
+
+What's an extension?
+
+=item *
+
+Why do Perl operators have different precedence than C operators?
+
+=item *
+
+How do I declare/create a structure?
+
+=item *
+
+How do I create a module?
+
+=item *
+
+How do I create a class?
+
+=item *
+
+How can I tell if a variable is tainted?
+
+=item *
+
+What's a closure?
+
+=item *
+
+What is variable suicide and how can I prevent it?
+
+=item *
+
+How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regex}?
+
+=item *
 
-=item * What are all these $@%&* punctuation signs, and how do I know when to use them?
+How do I create a static variable?
 
-=item * Do I always/never have to quote my strings or use semicolons and commas?
+=item *
 
-=item * How do I skip some return values?
+What's the difference between dynamic and lexical (static) scoping?  Between local() and my()?
 
-=item * How do I temporarily block warnings?
+=item *
 
-=item * What's an extension?
+How can I access a dynamic variable while a similarly named lexical is in scope?
 
-=item * Why do Perl operators have different precedence than C operators?
+=item *
 
-=item * How do I declare/create a structure?
+What's the difference between deep and shallow binding?
 
-=item * How do I create a module?
+=item *
 
-=item * How do I create a class?
+Why doesn't "my($foo) = <FILE>;" work right?
 
-=item * How can I tell if a variable is tainted?
+=item *
 
-=item * What's a closure?
+How do I redefine a builtin function, operator, or method?
 
-=item * What is variable suicide and how can I prevent it?
+=item *
 
-=item * How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regex}?
+What's the difference between calling a function as &foo and foo()?
 
-=item * How do I create a static variable?
+=item *
 
-=item * What's the difference between dynamic and lexical (static) scoping?  Between local() and my()?
+How do I create a switch or case statement?
 
-=item * How can I access a dynamic variable while a similarly named lexical is in scope?
+=item *
 
-=item * What's the difference between deep and shallow binding?
+How can I catch accesses to undefined variables/functions/methods?
 
-=item * Why doesn't "my($foo) = <FILE>;" work right?
+=item *
 
-=item * How do I redefine a builtin function, operator, or method?
+Why can't a method included in this same file be found?
 
-=item * What's the difference between calling a function as &foo and foo()?
+=item *
 
-=item * How do I create a switch or case statement?
+How can I find out my current package?
 
-=item * How can I catch accesses to undefined variables/functions/methods?
+=item *
 
-=item * Why can't a method included in this same file be found?
+How can I comment out a large block of perl code?
 
-=item * How can I find out my current package?
+=item *
 
-=item * How can I comment out a large block of perl code?
+How do I clear a package?
 
-=item * How do I clear a package?
+=item *
 
-=item * How can I use a variable as a variable name?
+How can I use a variable as a variable name?
 
 =back
 
 
-=item L<perlfaq8>: System Interaction
+=head2 L<perlfaq8>: System Interaction
 
 Interprocess communication (IPC), control over the user-interface
 (keyboard, screen and pointing devices).
 
 =over 4
 
-=item * How do I find out which operating system I'm running under?
+=item *
 
-=item * How come exec() doesn't return?
+How do I find out which operating system I'm running under?
 
-=item * How do I do fancy stuff with the keyboard/screen/mouse?
+=item *
 
-=item * How do I print something out in color?
+How come exec() doesn't return?
 
-=item * How do I read just one key without waiting for a return key?
+=item *
 
-=item * How do I check whether input is ready on the keyboard?
+How do I do fancy stuff with the keyboard/screen/mouse?
 
-=item * How do I clear the screen?
+=item *
 
-=item * How do I get the screen size?
+How do I print something out in color?
 
-=item * How do I ask the user for a password?
+=item *
 
-=item * How do I read and write the serial port?
+How do I read just one key without waiting for a return key?
 
-=item * How do I decode encrypted password files?
+=item *
 
-=item * How do I start a process in the background?
+How do I check whether input is ready on the keyboard?
 
-=item * How do I trap control characters/signals?
+=item *
 
-=item * How do I modify the shadow password file on a Unix system?
+How do I clear the screen?
 
-=item * How do I set the time and date?
+=item *
 
-=item * How can I sleep() or alarm() for under a second?
+How do I get the screen size?
 
-=item * How can I measure time under a second?
+=item *
 
-=item * How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
+How do I ask the user for a password?
 
-=item * Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean?
+=item *
 
-=item * How can I call my system's unique C functions from Perl?
+How do I read and write the serial port?
 
-=item * Where do I get the include files to do ioctl() or syscall()?
+=item *
 
-=item * Why do setuid perl scripts complain about kernel problems?
+How do I decode encrypted password files?
 
-=item * How can I open a pipe both to and from a command?
+=item *
 
-=item * Why can't I get the output of a command with system()?
+How do I start a process in the background?
 
-=item * How can I capture STDERR from an external command?
+=item *
 
-=item * Why doesn't open() return an error when a pipe open fails?
+How do I trap control characters/signals?
 
-=item * What's wrong with using backticks in a void context?
+=item *
 
-=item * How can I call backticks without shell processing?
+How do I modify the shadow password file on a Unix system?
 
-=item * Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)?
+=item *
 
-=item * How can I convert my shell script to perl?
+How do I set the time and date?
 
-=item * Can I use perl to run a telnet or ftp session?
+=item *
 
-=item * How can I write expect in Perl?
+How can I sleep() or alarm() for under a second?
 
-=item * Is there a way to hide perl's command line from programs such as "ps"?
+=item *
 
-=item * I {changed directory, modified my environment} in a perl script.  How come the change disappeared when I exited the script?  How do I get my changes to be visible?
+How can I measure time under a second?
 
-=item * How do I close a process's filehandle without waiting for it to complete?
+=item *
 
-=item * How do I fork a daemon process?
+How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
 
-=item * How do I make my program run with sh and csh?
+=item *
 
-=item * How do I find out if I'm running interactively or not?
+Why doesn't my sockets program work under System V (Solaris)?  What does the error message "Protocol not supported" mean?
 
-=item * How do I timeout a slow event?
+=item *
 
-=item * How do I set CPU limits?
+How can I call my system's unique C functions from Perl?
 
-=item * How do I avoid zombies on a Unix system?
+=item *
 
-=item * How do I use an SQL database?
+Where do I get the include files to do ioctl() or syscall()?
 
-=item * How do I make a system() exit on control-C?
+=item *
 
-=item * How do I open a file without blocking?
+Why do setuid perl scripts complain about kernel problems?
 
-=item * How do I install a module from CPAN?
+=item *
 
-=item * What's the difference between require and use?
+How can I open a pipe both to and from a command?
 
-=item * How do I keep my own module/library directory?
+=item *
 
-=item * How do I add the directory my program lives in to the module/library search path?
+Why can't I get the output of a command with system()?
 
-=item * How do I add a directory to my include path at runtime?
+=item *
 
-=item * What is socket.ph and where do I get it?
+How can I capture STDERR from an external command?
+
+=item *
+
+Why doesn't open() return an error when a pipe open fails?
+
+=item *
+
+What's wrong with using backticks in a void context?
+
+=item *
+
+How can I call backticks without shell processing?
+
+=item *
+
+Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)?
+
+=item *
+
+How can I convert my shell script to perl?
+
+=item *
+
+Can I use perl to run a telnet or ftp session?
+
+=item *
+
+How can I write expect in Perl?
+
+=item *
+
+Is there a way to hide perl's command line from programs such as "ps"?
+
+=item *
+
+I {changed directory, modified my environment} in a perl script.  How come the change disappeared when I exited the script?  How do I get my changes to be visible?
+
+=item *
+
+How do I close a process's filehandle without waiting for it to complete?
+
+=item *
+
+How do I fork a daemon process?
+
+=item *
+
+How do I find out if I'm running interactively or not?
+
+=item *
+
+How do I timeout a slow event?
+
+=item *
+
+How do I set CPU limits?
+
+=item *
+
+How do I avoid zombies on a Unix system?
+
+=item *
+
+How do I use an SQL database?
+
+=item *
+
+How do I make a system() exit on control-C?
+
+=item *
+
+How do I open a file without blocking?
+
+=item *
+
+How do I install a module from CPAN?
+
+=item *
+
+What's the difference between require and use?
+
+=item *
+
+How do I keep my own module/library directory?
+
+=item *
+
+How do I add the directory my program lives in to the module/library search path?
+
+=item *
+
+How do I add a directory to my include path at runtime?
+
+=item *
+
+What is socket.ph and where do I get it?
 
 =back
 
 
-=item L<perlfaq9>: Networking
+=head2 L<perlfaq9>: Networking
 
 Networking, the Internet, and a few on the web.
 
 =over 4
 
-=item * My CGI script runs from the command line but not the browser.   (500 Server Error)
+=item *
 
-=item * How can I get better error messages from a CGI program?
+My CGI script runs from the command line but not the browser.  (500 Server Error)
 
-=item * How do I remove HTML from a string?
+=item *
 
-=item * How do I extract URLs?
+How can I get better error messages from a CGI program?
 
-=item * How do I download a file from the user's machine?  How do I open a file on another machine?
+=item *
 
-=item * How do I make a pop-up menu in HTML?
+How do I remove HTML from a string?
 
-=item * How do I fetch an HTML file?
+=item *
 
-=item * How do I automate an HTML form submission?
+How do I extract URLs?
 
-=item * How do I decode or create those %-encodings on the web?
+=item *
 
-=item * How do I redirect to another page?
+How do I download a file from the user's machine?  How do I open a file on another machine?
 
-=item * How do I put a password on my web pages?
+=item *
 
-=item * How do I edit my .htpasswd and .htgroup files with Perl?
+How do I make a pop-up menu in HTML?
 
-=item * How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
+=item *
 
-=item * How do I parse a mail header?
+How do I fetch an HTML file?
 
-=item * How do I decode a CGI form?
+=item *
 
-=item * How do I check a valid mail address?
+How do I automate an HTML form submission?
 
-=item * How do I decode a MIME/BASE64 string?
+=item *
 
-=item * How do I return the user's mail address?
+How do I decode or create those %-encodings on the web?
 
-=item * How do I send mail?
+=item *
 
-=item * How do I read mail?
+How do I redirect to another page?
 
-=item * How do I find out my hostname/domainname/IP address?
+=item *
 
-=item * How do I fetch a news article or the active newsgroups?
+How do I put a password on my web pages?
 
-=item * How do I fetch/put an FTP file?
+=item *
 
-=item * How can I do RPC in Perl?
+How do I edit my .htpasswd and .htgroup files with Perl?
 
-=back
+=item *
+
+How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
+
+=item *
+
+How do I parse a mail header?
+
+=item *
+
+How do I decode a CGI form?
+
+=item *
+
+How do I check a valid mail address?
+
+=item *
 
+How do I decode a MIME/BASE64 string?
+
+=item *
+
+How do I return the user's mail address?
+
+=item *
+
+How do I send mail?
+
+=item *
+
+How do I read mail?
+
+=item *
+
+How do I find out my hostname/domainname/IP address?
+
+=item *
+
+How do I fetch a news article or the active newsgroups?
+
+=item *
+
+How do I fetch/put an FTP file?
+
+=item *
+
+How can I do RPC in Perl?
 
 =back
 
-=head2 Where to get this document
+
+=head1 About the perlfaq documents
+
+=head2 Where to get the perlfaq
 
 This document is posted regularly to comp.lang.perl.announce and
 several other related newsgroups.  It is available in a variety of
-formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory, or on the web
+formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory or on the web
 at http://www.perl.com/perl/faq/ .
 
-=head2 How to contribute to this document
+=head2 How to contribute to the perlfaq
 
 You may mail corrections, additions, and suggestions to
 perlfaq-suggestions@perl.com .  This alias should not be 
@@ -740,11 +1333,11 @@ All rights reserved.
 
 =head2 Bundled Distributions
 
-When included as part of the Standard Version of Perl, or as part of
+When included as part of the Standard Version of Perl or as part of
 its complete documentation whether printed or otherwise, this work
 may be distributed only under the terms of Perl's Artistic License.
 Any distribution of this file or derivatives thereof I<outside>
-of that package require that special arrangements be made with
+of that package requires that special arrangements be made with
 copyright holder.
 
 Irrespective of its distribution, all code examples in these files
@@ -764,6 +1357,10 @@ in respect of this information or its use.
 
 =over 4
 
+=item 1/November/2000
+
+A few grammatical fixes and updates implemented by John Borwick.
+
 =item 23/May/99
 
 Extensive updates from the net in preparation for 5.6 release.
index ec61e8b..1f9cb4c 100644 (file)
@@ -56,8 +56,8 @@ You should definitely use version 5.  Version 4 is old, limited, and
 no longer maintained; its last patch (4.036) was in 1992, long ago and
 far away.  Sure, it's stable, but so is anything that's dead; in fact,
 perl4 had been called a dead, flea-bitten camel carcass.  The most recent
-production release is 5.005_03 (although 5.004_05 is still supported).
-The most cutting-edge development release is 5.005_57.  Further references
+production release is 5.6 (although 5.005_03 is still supported).
+The most cutting-edge development release is 5.7.  Further references
 to the Perl language in this document refer to the production release
 unless otherwise specified.  There may be one or more official bug fixes
 by the time you read this, and also perhaps some experimental versions
@@ -78,8 +78,8 @@ The 5.0 release is, essentially, a ground-up rewrite of the original
 perl source code from releases 1 through 4.  It has been modularized,
 object-oriented, tweaked, trimmed, and optimized until it almost doesn't
 look like the old code.  However, the interface is mostly the same, and
-compatibility with previous releases is very high. See L<perltrap/"Perl4
-to Perl5 Traps">.
+compatibility with previous releases is very high. 
+See L<perltrap/"Perl4 to Perl5 Traps">.
 
 To avoid the "what language is perl5?" confusion, some people prefer to
 simply use "perl" to refer to the latest version of perl and avoid using
@@ -120,10 +120,10 @@ and the rare new keyword).
 
 =head2 Is Perl difficult to learn?
 
-No, Perl is easy to start learning -- and easy to keep learning.  It looks
+No, Perl is easy to start learning--and easy to keep learning.  It looks
 like most programming languages you're likely to have experience
 with, so if you've ever written a C program, an awk script, a shell
-script, or even a BASIC program, you're already part way there.
+script, or even a BASIC program, you're already partway there.
 
 Most tasks only require a small subset of the Perl language.  One of
 the guiding mottos for Perl development is "there's more than one way
@@ -183,7 +183,7 @@ languages that come to mind include prolog and matlab.
 
 =head2 When shouldn't I program in Perl?
 
-When your manager forbids it -- but do consider replacing them :-).
+When your manager forbids it--but do consider replacing them :-).
 
 Actually, one good reason is when you already have an existing
 application written in another language that's all done (and done
@@ -201,7 +201,7 @@ limitations given in the previous statement to some degree, but understand
 that Perl remains fundamentally a dynamically typed language, not
 a statically typed one.  You certainly won't be chastised if you don't
 trust nuclear-plant or brain-surgery monitoring code to it.  And Larry
-will sleep easier, too -- Wall Street programs not withstanding. :-)
+will sleep easier, too--Wall Street programs not withstanding. :-)
 
 =head2 What's the difference between "perl" and "Perl"?
 
@@ -220,17 +220,17 @@ Larry doesn't really care.  He says (half in jest) that "a script is
 what you give the actors.  A program is what you give the audience."
 
 Originally, a script was a canned sequence of normally interactive
-commands, that is, a chat script.  Something like a UUCP or PPP chat
+commands--that is, a chat script.  Something like a UUCP or PPP chat
 script or an expect script fits the bill nicely, as do configuration
 scripts run by a program at its start up, such F<.cshrc> or F<.ircrc>,
 for example.  Chat scripts were just drivers for existing programs,
 not stand-alone programs in their own right.
 
 A computer scientist will correctly explain that all programs are
-interpreted, and that the only question is at what level.  But if you
+interpreted and that the only question is at what level.  But if you
 ask this question of someone who isn't a computer scientist, they might
 tell you that a I<program> has been compiled to physical machine code
-once, and can then be run multiple times, whereas a I<script> must be
+once and can then be run multiple times, whereas a I<script> must be
 translated by a program each time it's used.
 
 Perl programs are (usually) neither strictly compiled nor strictly
@@ -263,7 +263,7 @@ Newer examples can be found by perusing Larry's postings:
 
     http://x1.dejanews.com/dnquery.xp?QRY=*&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=100&subjects=&groups=&authors=larry@*wall.org&fromdate=&todate=
 
-=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)?
+=head2 How can I convince my sysadmin/supervisor/employees to use version 5/5.005/Perl instead of some other language?
 
 If your manager or employees are wary of unsupported software, or
 software which doesn't officially ship with your operating system, you
@@ -272,15 +272,15 @@ more productive using and utilizing Perl constructs, functionality,
 simplicity, and power, then the typical manager/supervisor/employee
 may be persuaded.  Regarding using Perl in general, it's also
 sometimes helpful to point out that delivery times may be reduced
-using Perl, as compared to other languages.
+using Perl compared to other languages.
 
 If you have a project which has a bottleneck, especially in terms of
 translation or testing, Perl almost certainly will provide a viable,
-and quick solution.  In conjunction with any persuasion effort, you
+quick solution.  In conjunction with any persuasion effort, you
 should not fail to point out that Perl is used, quite extensively, and
 with extremely reliable and valuable results, at many large computer
-software and/or hardware companies throughout the world.  In fact,
-many Unix vendors now ship Perl by default, and support is usually
+software and hardware companies throughout the world.  In fact,
+many Unix vendors now ship Perl by default.  Support is usually
 just a news-posting away, if you can't find the answer in the
 I<comprehensive> documentation, including this FAQ.
 
@@ -292,7 +292,7 @@ by the Perl Development Team.  Another big sell for Perl5 is the large
 number of modules and extensions which greatly reduce development time
 for any given task.  Also mention that the difference between version
 4 and version 5 of Perl is like the difference between awk and C++.
-(Well, OK, maybe not quite that distinct, but you get the idea.)  If you
+(Well, OK, maybe it's not quite that distinct, but you get the idea.)  If you
 want support and a reasonable guarantee that what you're developing
 will continue to work in the future, then you have to run the supported
 version.  That probably means running the 5.005 release, although 5.004
index df05091..f438baa 100644 (file)
@@ -69,19 +69,19 @@ eventually live on, and then type C<make install>.  Most other
 approaches are doomed to failure.
 
 One simple way to check that things are in the right place is to print out
-the hard-coded @INC which perl is looking for.
+the hard-coded @INC that perl looks through for libraries:
 
     % perl -e 'print join("\n",@INC)'
 
-If this command lists any paths which don't exist on your system, then you
+If this command lists any paths that don't exist on your system, then you
 may need to move the appropriate libraries to these locations, or create
 symbolic links, aliases, or shortcuts appropriately.  @INC is also printed as
 part of the output of
 
     % perl -V
 
-You might also want to check out L<perlfaq8/"How do I keep my own
-module/library directory?">.
+You might also want to check out 
+L<perlfaq8/"How do I keep my own module/library directory?">.
 
 =head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed.  How do I make it work?
 
@@ -133,7 +133,7 @@ If you have Perl installed locally, you probably have the documentation
 installed as well: type C<man perl> if you're on a system resembling Unix.
 This will lead you to other important man pages, including how to set your
 $MANPATH.  If you're not on a Unix system, access to the documentation
-will be different; for example, it might be only in HTML format.  But all
+will be different; for example, documentation might only be in HTML format.  All
 proper Perl installations have fully-accessible documentation.
 
 You might also try C<perldoc perl> in case your system doesn't
@@ -145,14 +145,16 @@ complete documentation in various formats, including native pod,
 troff, html, and plain text.  There's also a web page at
 http://www.perl.com/perl/info/documentation.html that might help.
 
-Many good books have been written about Perl -- see the section below
+Many good books have been written about Perl--see the section below
 for more details.
 
 Tutorial documents are included in current or upcoming Perl releases
-include L<perltoot> for objects, L<perlopentut> for file opening
-semantics, L<perlreftut> for managing references, and L<perlxstut>
-for linking C and Perl together.  There may be more by the 
-time you read this.  The following URLs might also be of 
+include L<perltoot> for objects or L<perlboot> for a beginner's
+approach to objects, L<perlopentut> for file opening semantics,
+L<perlreftut> for managing references, L<perlretut> for regular
+expressions, L<perlthrtut> for threads, L<perldebtut> for debugging,
+and L<perlxstut> for linking C and Perl together.  There may be more
+by the time you read this.  The following URLs might also be of
 assistance:
 
     http://language.perl.com/info/documentation.html
@@ -193,7 +195,7 @@ a request.
 A number of books on Perl and/or CGI programming are available.  A few of
 these are good, some are OK, but many aren't worth your money.  Tom
 Christiansen maintains a list of these books, some with extensive
-reviews, at http://www.perl.com/perl/critiques/index.html.
+reviews, at http://www.perl.com/perl/critiques/index.html .
 
 The incontestably definitive reference book on Perl, written by
 the creator of Perl, is now (July 2000) in its third edition:
@@ -206,7 +208,7 @@ the creator of Perl, is now (July 2000) in its third edition:
 
 The companion volume to the Camel containing thousands
 of real-world examples, mini-tutorials, and complete programs
-(first premiering at the 1998 Perl Conference), is:
+(first premiered at the 1998 Perl Conference), is:
 
     The Perl Cookbook (the "Ram Book"):
        by Tom Christiansen and Nathan Torkington, 
@@ -215,8 +217,8 @@ of real-world examples, mini-tutorials, and complete programs
        http://perl.oreilly.com/cookbook/
 
 If you're already a hard-core systems programmer, then the Camel Book
-might suffice for you to learn Perl from.  But if you're not, check
-out:
+might suffice for you to learn Perl from.  If you're not, check
+out
 
     Learning Perl (the "Llama Book"):
        by Randal Schwartz and Tom Christiansen 
@@ -225,9 +227,9 @@ out:
        http://www.oreilly.com/catalog/lperl2/
 
 Despite the picture at the URL above, the second edition of "Llama
-Book" really has a blue cover, and is updated for the 5.004 release
+Book" really has a blue cover and was updated for the 5.004 release
 of Perl.  Various foreign language editions are available, including
-I<Learning Perl on Win32 Systems> (the Gecko Book).
+I<Learning Perl on Win32 Systems> (the "Gecko Book").
 
 If you're not an accidental programmer, but a more serious and possibly
 even degreed computer scientist who doesn't need as much hand-holding as
@@ -245,7 +247,7 @@ useful.  Your mileage may (but, we hope, probably won't) vary.
 
 Recommended books on (or mostly on) Perl follow.
 
-=over
+=over 4
 
 =item References
 
@@ -350,7 +352,7 @@ Recommended books on (or mostly on) Perl follow.
 
 The first and only periodical devoted to All Things Perl, I<The
 Perl Journal> contains tutorials, demonstrations, case studies,
-announcements, contests, and much more.  TPJ has columns on web
+announcements, contests, and much more.  I<TPJ> has columns on web
 development, databases, Win32 Perl, graphical programming, regular
 expressions, and networking, and sponsors the Obfuscated Perl
 Contest.  It is published quarterly under the gentle hand of its
@@ -362,11 +364,11 @@ on Perl are I<Web Techniques> (see http://www.webtechniques.com/),
 I<Performance Computing> (http://www.performance-computing.com/), and Usenix's
 newsletter/magazine to its members, I<login:>, at http://www.usenix.org/.
 Randal's Web Technique's columns are available on the web at
-http://www.stonehenge.com/merlyn/WebTechniques/.
+http://www.stonehenge.com/merlyn/WebTechniques/ .
 
 =head2 Perl on the Net: FTP and WWW Access
 
-To get the best (and possibly cheapest) performance, pick a site from
+To get the best performance, pick a site from
 the list below and use it to grab the complete list of mirror sites.
 From there you can find the quickest site for you.  Remember, the
 following list is I<not> the complete list of CPAN mirrors
@@ -399,7 +401,7 @@ best archives.  Just look up "*perl*" as a newsgroup.
 
     http://www.deja.com/dnquery.xp?QRY=&DBS=2&ST=PS&defaultOp=AND&LNG=ALL&format=terse&showsort=date&maxhits=25&subjects=&groups=*perl*&authors=&fromdate=&todate=
 
-You'll probably want to trim that down a bit, though.
+You might want to trim that down a bit, though.
 
 You'll probably want more a sophisticated query and retrieval mechanism
 than a file listing, preferably one that allows you to retrieve
@@ -413,7 +415,7 @@ let perlfaq-suggestions@perl.com know.
 
 =head2 Where can I buy a commercial version of Perl?
 
-In a real sense, Perl already I<is> commercial software: It has a license
+In a real sense, Perl already I<is> commercial software: it has a license
 that you can grab and carefully read to your manager. It is distributed
 in releases and comes in well-defined packages. There is a very large
 user community and an extensive literature.  The comp.lang.perl.*
@@ -427,13 +429,13 @@ However, these answers may not suffice for managers who require a
 purchase order from a company whom they can sue should anything go awry.
 Or maybe they need very serious hand-holding and contractual obligations.
 Shrink-wrapped CDs with Perl on them are available from several sources if
-that will help.  For example, many Perl books carry a Perl distribution
-on them, as do the O'Reilly Perl Resource Kits (in both the Unix flavor
+that will help.  For example, many Perl books include a distribution of Perl,
+as do the O'Reilly Perl Resource Kits (in both the Unix flavor
 and in the proprietary Microsoft flavor); the free Unix distributions
 also all come with Perl.
 
-Or you can purchase commercial incidence based support through the Perl
-Clinic.  The following is a commercial from them:
+Alternatively, you can purchase commercial incidence based support
+through the Perl Clinic.  The following is a commercial from them:
 
 "The Perl Clinic is a commercial Perl support service operated by
 ActiveState Tool Corp. and The Ingram Group.  The operators have many
@@ -444,7 +446,7 @@ on a wide range of platforms.
 we will put our best effort into understanding your problem, providing an
 explanation of the situation, and a recommendation on how to proceed."
 
-Contact The Perl Clinic at:
+Contact The Perl Clinic at
 
     www.PerlClinic.com
 
index b05b736..5bf2f5c 100644 (file)
@@ -49,22 +49,22 @@ uninteresting, but may still be what you want.
 =head2 How do I debug my Perl programs?
 
 Have you tried C<use warnings> or used C<-w>?  They enable warnings 
-for dubious practices.
+to detect dubious practices.
 
 Have you tried C<use strict>?  It prevents you from using symbolic
 references, makes you predeclare any subroutines that you call as bare
 words, and (probably most importantly) forces you to predeclare your
-variables with C<my> or C<our> or C<use vars>.
+variables with C<my>, C<our>, or C<use vars>.
 
-Did you check the returns of each and every system call?  The operating
-system (and thus Perl) tells you whether they worked or not, and if not
+Did you check the return values of each and every system call?  The operating
+system (and thus Perl) tells you whether they worked, and if not
 why.
 
   open(FH, "> /etc/cantwrite")
     or die "Couldn't write to /etc/cantwrite: $!\n";
 
 Did you read L<perltrap>?  It's full of gotchas for old and new Perl
-programmers, and even has sections for those of you who are upgrading
+programmers and even has sections for those of you who are upgrading
 from languages like I<awk> and I<C>.
 
 Have you tried the Perl debugger, described in L<perldebug>?  You can
@@ -73,10 +73,11 @@ why what it's doing isn't what it should be doing.
 
 =head2 How do I profile my Perl programs?
 
-You should get the Devel::DProf module from CPAN, and also use
-Benchmark.pm from the standard distribution.  Benchmark lets you time
-specific portions of your code, while Devel::DProf gives detailed
-breakdowns of where your code spends its time.
+You should get the Devel::DProf module from the standard distribution
+(or separately on CPAN) and also use Benchmark.pm from the standard 
+distribution.  The Benchmark module lets you time specific portions of 
+your code, while Devel::DProf gives detailed breakdowns of where your 
+code spends its time.
 
 Here's a sample use of Benchmark:
 
@@ -104,7 +105,7 @@ on your hardware, operating system, and the load on your machine):
          map:  6 secs ( 4.97 usr  0.00 sys =  4.97 cpu)
 
 Be aware that a good benchmark is very hard to write.  It only tests the
-data you give it, and really proves little about differing complexities
+data you give it and proves little about the differing complexities
 of contrasting algorithms.
 
 =head2 How do I cross-reference my Perl programs?
@@ -125,17 +126,17 @@ challenging at best to write a stand-alone Perl parser.
 Of course, if you simply follow the guidelines in L<perlstyle>, you
 shouldn't need to reformat.  The habit of formatting your code as you
 write it will help prevent bugs.  Your editor can and should help you
-with this.  The perl-mode for emacs can provide a remarkable amount of
-help with most (but not all) code, and even less programmable editors
-can provide significant assistance.  Tom swears by the following
-settings in vi and its clones:
+with this.  The perl-mode or newer cperl-mode for emacs can provide
+remarkable amounts of help with most (but not all) code, and even less
+programmable editors can provide significant assistance.  Tom swears
+by the following settings in vi and its clones:
 
     set ai sw=4
     map! ^O {^M}^[O^T
 
 Now put that in your F<.exrc> file (replacing the caret characters
 with control characters) and away you go.  In insert mode, ^T is
-for indenting, ^D is for undenting, and ^O is for blockdenting --
+for indenting, ^D is for undenting, and ^O is for blockdenting--
 as it were.  If you haven't used the last one, you're missing
 a lot.  A more complete example, with comments, can be found at
 http://www.perl.com/CPAN-local/authors/id/TOMC/scripts/toms.exrc.gz
@@ -156,7 +157,7 @@ the trick.  And if not, it's easy to hack into what you want.
 
 =head2 Is there an IDE or Windows Perl Editor?
 
-If you're on Unix, you already have an IDE -- Unix itself.  This powerful
+If you're on Unix, you already have an IDE--Unix itself.  This powerful
 IDE derives from its interoperability, flexibility, and configurability.
 If you really want to get a feel for Unix-qua-IDE, the best thing to do
 is to find some high-powered programmer whose native language is Unix.
@@ -168,7 +169,7 @@ development *is* integrated, like a top-of-the-line German sports car:
 functional, powerful, and elegant.  You will be absolutely astonished
 at the speed and ease exhibited by the native speaker of Unix in his
 home territory.  The art and skill of a virtuoso can only be seen to be
-believed.  That is the path to mastery -- all these cobbled little IDEs
+believed.  That is the path to mastery--all these cobbled little IDEs
 are expensive toys designed to sell a flashy demo using cheap tricks,
 and being optimized for immediate but shallow understanding rather than
 enduring use, are but a dim palimpsest of real tools.
@@ -176,22 +177,76 @@ enduring use, are but a dim palimpsest of real tools.
 In short, you just have to learn the toolbox.  However, if you're not
 on Unix, then your vendor probably didn't bother to provide you with
 a proper toolbox on the so-called complete system that you forked out
-your hard-earned cash on.
-
-PerlBuilder (XXX URL to follow) is an integrated development environment
-for Windows that supports Perl development.  Perl programs are just plain
-text, though, so you could download emacs for Windows (???) or a vi clone
-(vim) which runs on for win32 (http://www.cs.vu.nl/%7Etmgil/vi.html).
-If you're transferring Windows files to Unix, be sure to transfer in
-ASCII mode so the ends of lines are appropriately mangled.
+your hard-earned cash for.
+
+If you're transferring Windows text files to Unix using FTP be sure to
+transfer them in ASCII mode so the ends of lines are appropriately mangled.
+
+PerlBuilder (http://www.solutionsoft.com/perl.htm) is an integrated
+development environment for Windows that supports Perl development.
+Komodo, ActiveState's cross-platform, multi-language IDE has Perl
+support, including a regular expression debugger and remote debugging
+(http://www.ActiveState.com/Products/Komodo/index.html).  (Visual Perl,
+a Visual Studio.NET plug-in is currently in beta (late 2000)
+(http://www.ActiveState.com/Products/VisualPerl/index.html)).
+The visiPerl+ IDE is available from Help Consulting
+(http://helpconsulting.net/visiperl/).  Perl code magic is
+another IDE (http://www.petes-place.com/codemagic.html).  CodeMagicCD
+(http://www.codemagiccd.com/) is another IDE.  The Object System
+(http://www.castlelink.co.uk/object_system/) is a Perl web
+applications development IDE.
+
+Perl programs are just plain text, though, so you could download GNU
+Emacs (http://www.gnu.org/software/emacs/windows/ntemacs.html) or
+XEmacs (http://www.xemacs.org/Download/index.html), or a vi clone such
+as Elvis (ftp://ftp.cs.pdx.edu/pub/elvis/, see also
+http://www.fh-wedel.de/elvis/), nvi (http://www.bostic.com/vi/, or
+available from CPAN in src/misc/), or Vile
+(http://www.clark.net/pub/dickey/vile/vile.html), or vim
+(http://www.vim.org/) (win32: http://www.cs.vu.nl/%7Etmgil/vi.html).
+(For vi lovers in general: http://www.thomer.com/thomer/vi/vi.html)
+
+The following are Win32 multilanguage editor/IDESs that support Perl: 
+Codewright (http://www.starbase.com/), MultiEdit (http://www.MultiEdit.com/),
+SlickEdit (http://www.slickedit.com/).
+
+There is also a toyedit Text widget based editor written in Perl that
+is distributed with the Tk module on CPAN.  The ptkdb
+(http://world.std.com/~aep/ptkdb/) is a Perl/tk based debugger that
+acts as a development environment of sorts.  Perl Composer
+(http://perlcomposer.sourceforge.net/vperl.html) 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 the Bash
+from the Cygwin package (http://sources.redhat.com/cygwin/), or the
+Ksh from the MKS Toolkit (http://www.mks.com/), or the Bourne shell of
+the U/WIN environment (http://www.research.att.com/sw/tools/uwin/), or
+the Tcsh (ftp://ftp.astron.com/pub/tcsh/, see also
+http://www.primate.wisc.edu/software/csh-tcsh-book/), or the Zsh
+(ftp://ftp.blarg.net/users/amol/zsh/, see also http://www.zsh.org/).
+MKS and U/WIN are commercial (U/WIN is free for educational and
+research purposes), Cygwin is covered by the GNU 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.
+
+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).  BBEdit and BBEdit Lite are text editors for Mac OS 
+that have a Perl sensitivity mode (http://web.barebones.com/).
+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://alpha.olm.net/).
 
 =head2 Where can I get Perl macros for vi?
 
 For a complete version of Tom Christiansen's vi configuration file,
-see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc.gz,
-the standard benchmark file for vi emulators.  This runs best with nvi,
+see http://www.perl.com/CPAN/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.perl.com/CPAN/src/misc.
+with an embedded Perl interpreter--see http://www.perl.com/CPAN/src/misc.
 
 =head2 Where can I get perl-mode for emacs?
 
@@ -223,7 +278,7 @@ that doesn't force you to use Tcl just to get at Tk.  Sx is an interface
 to the Athena Widget set.  Both are available from CPAN.  See the
 directory http://www.perl.com/CPAN/modules/by-category/08_User_Interfaces/
 
-Invaluable for Perl/Tk programming are: the Perl/Tk FAQ at
+Invaluable for Perl/Tk programming are the Perl/Tk FAQ at
 http://w4.lns.cornell.edu/%7Epvhp/ptk/ptkTOC.html , the Perl/Tk Reference
 Guide available at
 http://www.perl.com/CPAN-local/authors/Stephen_O_Lidie/ , and the
@@ -237,13 +292,12 @@ module, which is curses-based, can help with this.
 
 =head2 What is undump?
 
-See the next questions.
+See the next question on ``How can I make my Perl program run faster?''
 
 =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.  Chapter 8 in the Camel has some
-efficiency tips in it you might want to look at.  Jon Bentley's book
+can often make a dramatic difference.  Jon Bentley's book
 ``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
@@ -254,8 +308,8 @@ 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 is the use of
-modules that have critical sections written in C (for instance, the
+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).
 
 In some cases, it may be worth it to use the backend compiler to
@@ -294,7 +348,7 @@ 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 for a considerable memory savings.  The standard
+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
@@ -339,7 +393,7 @@ $scalar> will return memory to the system, while on Solaris 2.6 it
 won't.  In general, try it yourself and see.
 
 However, judicious use of my() on your variables will help make sure
-that they go out of scope so that Perl can free up their storage for
+that they go out of scope so that Perl can free up that space for
 use in other parts of your program.  A global variable, of course, never
 goes out of scope, so you can't get its space automatically reclaimed,
 although undef()ing and/or delete()ing it will achieve the same effect.
@@ -380,12 +434,13 @@ care.
 See http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/ .
 
 A non-free, commercial product, ``The Velocity Engine for Perl'',
-(http://www.binevolve.com/ or http://www.binevolve.com/velocigen/) might
-also be worth looking at.  It will allow you to increase the performance
-of your Perl programs, up to 25 times faster than normal CGI Perl by
-running in persistent Perl mode, or 4 to 5 times faster without any
-modification to your existing CGI programs. Fully functional evaluation
-copies are available from the web site.
+(http://www.binevolve.com/ or http://www.binevolve.com/velocigen/ )
+might also be worth looking at.  It will allow you to increase the
+performance of your Perl programs, running programs up to 25 times
+faster than normal CGI Perl when running in persistent Perl mode or 4
+to 5 times faster without any modification to your existing CGI
+programs. Fully functional evaluation copies are available from the
+web site.
 
 =head2 How can I hide the source for my Perl program?
 
@@ -395,12 +450,12 @@ 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
+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
+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
@@ -412,7 +467,7 @@ the byte code compiler and interpreter described below, but the curious
 might still be able to de-compile it.  You can try using the native-code
 compiler described below, 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 (this is true of every
+your code, but none can definitively conceal it (true of every
 language, not just Perl).
 
 If you're concerned about people profiting from your code, then the
@@ -434,10 +489,10 @@ really for people looking for turn-key solutions.
 Merely compiling into C does not in and of itself guarantee that your
 code will run very much faster.  That's because except for lucky cases
 where a lot of native type inferencing is possible, the normal Perl
-run time system is still present and so your program will take just as
+run-time system is still present and so your program will take just as
 long to run and be just as big.  Most programs save little more than
 compilation time, leaving execution no more than 10-30% faster.  A few
-rare programs actually benefit significantly (like several times
+rare programs actually benefit significantly (even running several times
 faster), but this takes some tweaking of your code.
 
 You'll probably be astonished to learn that the current version of the
@@ -452,8 +507,8 @@ For example, on one author's system, F</usr/bin/perl> is only 11k in
 size!
 
 In general, the compiler will do nothing to make a Perl program smaller,
-faster, more portable, or more secure.  In fact, it will usually hurt
-all of those.  The executable will be bigger, your VM system may take
+faster, more portable, or more secure.  In fact, it can make your
+situation worse.  The executable will be bigger, your VM system may take
 longer to load the whole thing, the binary is fragile and hard to fix,
 and compilation never stopped software piracy in the form of crackers,
 viruses, or bootleggers.  The real advantage of the compiler is merely
@@ -463,11 +518,13 @@ Perl install anyway.
 
 =head2 How can I compile Perl into Java?
 
-You can't.  Not yet, anyway.  You can integrate Java and Perl with the
+You can also integrate Java and Perl with the
 Perl Resource Kit from O'Reilly and Associates.  See
-http://www.oreilly.com/catalog/prkunix/ for more information.
-The Java interface will be supported in the core 5.6 release
-of Perl.
+http://www.oreilly.com/catalog/prkunix/ .
+
+Perl 5.6 comes with Java Perl Lingo, or JPL.  JPL, still in
+development, allows Perl code to be called from Java.  See jpl/README
+in the Perl source tree.
 
 =head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]?
 
@@ -477,7 +534,7 @@ For OS/2 just use
 
 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<ALTERNATIVE_SHEBANG> (see the
+batch file and codify it in C<ALTERNATIVE_SHEBANG> (see the
 F<INSTALL> file in the source distribution for more information).
 
 The Win95/NT installation, when using the ActiveState port of Perl,
@@ -546,9 +603,9 @@ For example:
     # VMS
     perl -e "print ""Hello world\n"""
 
-The problem is that none of this is reliable: it depends on the
+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 neither works.  If 4DOS was the command shell,
+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>""
@@ -596,13 +653,12 @@ when it runs fine on the command line'', see these sources:
     CGI Security FAQ
         http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt
 
-
 =head2 Where can I learn about object-oriented Perl programming?
 
-A good place to start is L<perltoot>, and you can use L<perlobj> and
-L<perlbot> for reference.  Perltoot didn't come out until the 5.004
-release, but you can get a copy (in pod, html, or postscript) from
-http://www.perl.com/CPAN/doc/FMTEYEWTK/ .
+A good place to start is L<perltoot>, and you can use L<perlobj>,
+L<perlboot>, and L<perlbot> for reference.  Perltoot didn't come out
+until the 5.004 release; you can get a copy (in pod, html, or
+postscript) from http://www.perl.com/CPAN/doc/FMTEYEWTK/ .
 
 =head2 Where can I learn about linking C with Perl? [h2xs, xsubpp]
 
@@ -614,7 +670,7 @@ how the authors of existing extension modules wrote their code and
 solved their problems.
 
 =head2 I've read perlembed, perlguts, etc., but I can't embed perl in
-my C program, what am I doing wrong?
+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
index 79905f8..1198f18 100644 (file)
@@ -4,7 +4,7 @@ perlfaq4 - Data Manipulation ($Revision: 1.49 $, $Date: 1999/05/23 20:37:49 $)
 
 =head1 DESCRIPTION
 
-The section of the FAQ answers question related to the manipulation
+The section of the FAQ answers questions related to the manipulation
 of data as numbers, dates, strings, arrays, hashes, and miscellaneous
 data issues.
 
@@ -13,13 +13,13 @@ data issues.
 =head2 Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?
 
 The infinite set that a mathematician thinks of as the real numbers can
-only be approximate on a computer, since the computer only has a finite
+only be approximated on a computer, since the computer only has a finite
 number of bits to store an infinite number of, um, numbers.
 
 Internally, your computer represents floating-point numbers in binary.
 Floating-point numbers read in from a file or appearing as literals
 in your program are converted from their decimal floating-point
-representation (eg, 19.95) to the internal binary representation.
+representation (eg, 19.95) to an internal binary representation.
 
 However, 19.95 can't be precisely represented as a binary
 floating-point number, just like 1/3 can't be exactly represented as a
@@ -29,7 +29,7 @@ of 19.95, therefore, isn't exactly 19.95.
 When a floating-point number gets printed, the binary floating-point
 representation is converted back to decimal.  These decimal numbers
 are displayed in either the format you specify with printf(), or the
-current output format for numbers (see L<perlvar/"$#"> if you use
+current output format for numbers.  (See L<perlvar/"$#"> if you use
 print.  C<$#> has a different default value in Perl5 than it did in
 Perl4.  Changing C<$#> yourself is deprecated.)
 
@@ -75,7 +75,7 @@ functions.
     $ceil   = ceil(3.5);                       # 4
     $floor  = floor(3.5);                      # 3
 
-In 5.000 to 5.003 Perls, trigonometry was done in the Math::Complex
+In 5.000 to 5.003 perls, trigonometry was done in the Math::Complex
 module.  With 5.004, the Math::Trig module (part of the standard Perl
 distribution) implements the trigonometric functions. Internally it
 uses the Math::Complex module and some functions can break out from
@@ -206,8 +206,8 @@ than more.
 
 Computers are good at being predictable and bad at being random
 (despite appearances caused by bugs in your programs :-).
-http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom
-Phoenix, talks more about this..  John von Neumann said, ``Anyone who
+http://www.perl.com/CPAN/doc/FMTEYEWTK/random , courtesy of Tom
+Phoenix, talks more about this.  John von Neumann said, ``Anyone who
 attempts to generate random numbers by deterministic means is, of
 course, living in a state of sin.''
 
@@ -286,7 +286,7 @@ Use the Time::JulianDay module (part of the Time-modules bundle
 available from CPAN.)
 
 Before you immerse yourself too deeply in this, be sure to verify that it
-is the I<Julian> Day you really want.  Are they really just interested in
+is the I<Julian> Day you really want.  Are you really just interested in
 a way of getting serial days so that they can do date arithmetic?  If you
 are interested in performing date arithmetic, this can be done using
 either Date::Manip or Date::Calc, without converting to Julian Day first.
@@ -398,7 +398,7 @@ addresses, etc.) for details.
 
 It depends just what you mean by ``escape''.  URL escapes are dealt
 with in L<perlfaq9>.  Shell escapes with the backslash (C<\>)
-character are removed with:
+character are removed with
 
     s/\\(.)/$1/g;
 
@@ -512,7 +512,7 @@ use substr() as an lvalue:
     substr($a, 0, 3) = "Tom";
 
 Although those with a pattern matching kind of thought process will
-likely prefer:
+likely prefer
 
     $a =~ s/^.../Tom/;
 
@@ -549,7 +549,7 @@ repetition count and repeated pattern like this:
 
 =head2 How can I count the number of occurrences of a substring within a string?
 
-There are a number of ways, with varying efficiency: If you want a
+There are a number of ways, with varying efficiency.  If you want a
 count of a certain single character (X) within a string, you can use the
 C<tr///> function like so:
 
@@ -574,8 +574,8 @@ To make the first letter of each word upper case:
         $line =~ s/\b(\w)/\U$1/g;
 
 This has the strange effect of turning "C<don't do it>" into "C<Don'T
-Do It>".  Sometimes you might want this, instead (Suggested by brian d. 
-foy):
+Do It>".  Sometimes you might want this.  Other times you might need a
+more thorough solution (Suggested by brian d.  foy):
 
     $string =~ s/ (
                  (^\w)    #at the beginning of the line
@@ -637,15 +637,15 @@ distribution) lets you say:
     use Text::ParseWords;
     @new = quotewords(",", 0, $text);
 
-There's also a Text::CSV module on CPAN.
+There's also a Text::CSV (Comma-Separated Values) module on CPAN.
 
 =head2 How do I strip blank space from the beginning/end of a string?
 
-Although the simplest approach would seem to be:
+Although the simplest approach would seem to be
 
     $string =~ s/^\s*(.*?)\s*$/$1/;
 
-Not only is this unnecessarily slow and destructive, it also fails with
+not only is this unnecessarily slow and destructive, it also fails with
 embedded newlines.  It is much faster to do this operation in two steps:
 
     $string =~ s/^\s+//;
@@ -740,7 +740,7 @@ you can use this kind of thing:
 =head2 How do I find the soundex value of a string?
 
 Use the standard Text::Soundex module distributed with Perl.
-But before you do so, you may want to determine whether `soundex' is in
+Before you do so, you may want to determine whether `soundex' is in
 fact what you think it is.  Knuth's soundex algorithm compresses words
 into a small space, and so it does not necessarily distinguish between
 two words which you might want to appear separately.  For example, the
@@ -779,9 +779,9 @@ of the FAQ.
 
 =head2 What's wrong with always quoting "$vars"?
 
-The problem is that those double-quotes force stringification,
-coercing numbers and references into strings, even when you
-don't want them to be.  Think of it this way: double-quote
+The problem is that those double-quotes force stringification--
+coercing numbers and references into strings--even when you
+don't want them to be strings.  Think of it this way: double-quote
 expansion is used to produce new strings.  If you already 
 have a string, why do you need more?
 
@@ -857,13 +857,13 @@ in the indentation.
 A nice general-purpose fixer-upper function for indented here documents
 follows.  It expects to be called with a here document as its argument.
 It looks to see whether each line begins with a common substring, and
-if so, strips that off.  Otherwise, it takes the amount of leading
-white space found on the first line and removes that much off each
+if so, strips that substring off.  Otherwise, it takes the amount of leading
+whitespace found on the first line and removes that much off each
 subsequent line.
 
     sub fix {
         local $_ = shift;
-        my ($white, $leader);  # common white space and common leading string
+        my ($white, $leader);  # common whitespace and common leading string
         if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
             ($white, $leader) = ($2, quotemeta($1));
         } else {
@@ -886,7 +886,7 @@ This works with leading special strings, dynamically determined:
        @@@ }
     MAIN_INTERPRETER_LOOP
 
-Or with a fixed amount of leading white space, with remaining
+Or with a fixed amount of leading whitespace, with remaining
 indentation correctly preserved:
 
     $poem = fix<<EVER_ON_AND_ON;
@@ -910,7 +910,7 @@ Subroutines are passed and return lists, you put things into list
 context, you initialize arrays with lists, and you foreach() across
 a list.  C<@> variables are arrays, anonymous arrays are arrays, arrays
 in scalar context behave like the number of elements in them, subroutines
-access their arguments through the array C<@_>, push/pop/shift only work
+access their arguments through the array C<@_>, and push/pop/shift only work
 on arrays.
 
 As a side note, there's no such thing as a list in scalar context.
@@ -924,7 +924,7 @@ last value to be returned: 9.
 
 =head2 What is the difference between $array[1] and @array[1]?
 
-The former is a scalar value, the latter an array slice, which makes
+The former is a scalar value; the latter an array slice, making
 it a list with one (scalar) value.  You should use $ when you want a
 scalar value (most of the time) and @ when you want a list with one
 scalar value in it (very, very rarely; nearly never, in fact).
@@ -948,33 +948,43 @@ ordered and whether you wish to preserve the ordering.
 
 =over 4
 
-=item a) If @in is sorted, and you want @out to be sorted:
+=item a)
+
+If @in is sorted, and you want @out to be sorted:
 (this assumes all true values in the array)
 
     $prev = 'nonesuch';
-    @out = grep($_ ne $prev && ($prev = $_), @in);
+    @out = grep($_ ne $prev && ($prev = $_, 1), @in);
 
 This is nice in that it doesn't use much extra memory, simulating
-uniq(1)'s behavior of removing only adjacent duplicates.  It's less
-nice in that it won't work with false values like undef, 0, or "";
-"0 but true" is OK, though.
+uniq(1)'s behavior of removing only adjacent duplicates.  The ", 1"
+guarantees that the expression is true (so that grep picks it up)
+even if the $_ is 0, "", or undef.
+
+=item b)
 
-=item b) If you don't know whether @in is sorted:
+If you don't know whether @in is sorted:
 
     undef %saw;
     @out = grep(!$saw{$_}++, @in);
 
-=item c) Like (b), but @in contains only small integers:
+=item c)
+
+Like (b), but @in contains only small integers:
 
     @out = grep(!$saw[$_]++, @in);
 
-=item d) A way to do (b) without any loops or greps:
+=item d)
+
+A way to do (b) without any loops or greps:
 
     undef %saw;
     @saw{@in} = ();
     @out = sort keys %saw;  # remove sort if undesired
 
-=item e) Like (d), but @in contains only small positive integers:
+=item e)
+
+Like (d), but @in contains only small positive integers:
 
     undef @ary;
     @ary[@in] = @in;
@@ -1023,11 +1033,11 @@ Now check whether C<vec($read,$n,1)> is true for some C<$n>.
 
 Please do not use
 
-    $is_there = grep $_ eq $whatever, @array;
+    ($is_there) = grep $_ eq $whatever, @array;
 
 or worse yet
 
-    $is_there = grep /$whatever/, @array;
+    ($is_there) = grep /$whatever/, @array;
 
 These are slow (checks every element even if the first matches),
 inefficient (same reason), and potentially buggy (what if there are
@@ -1057,7 +1067,7 @@ each element is unique in a given array:
     }
 
 Note that this is the I<symmetric difference>, that is, all elements in
-either A or in B, but not in both.  Think of it as an xor operation.
+either A or in B but not in both.  Think of it as an xor operation.
 
 =head2 How do I test whether two arrays or hashes are equal?
 
@@ -1148,7 +1158,7 @@ You could walk the list this way:
     }
     print "\n";
 
-You could grow the list this way:
+You could add to the list this way:
 
     my ($head, $tail);
     $tail = append($head, 1);       # grow a new head
@@ -1196,7 +1206,7 @@ Use this:
     fisher_yates_shuffle( \@array );    # permutes @array in place
 
 You've probably seen shuffling algorithms that work using splice,
-randomly picking another element to swap the current element with:
+randomly picking another element to swap the current element with
 
     srand;
     @new = ();
@@ -1297,7 +1307,7 @@ case-insensitively.
     }
     @sorted = @data[ sort { $idx[$a] cmp $idx[$b] } 0 .. $#idx ];
 
-Which could also be written this way, using a trick
+which could also be written this way, using a trick
 that's come to be known as the Schwartzian Transform:
 
     @sorted = map  { $_->[0] }
@@ -1438,7 +1448,7 @@ table, at which point you've totally bamboozled the iterator code.
 Even if the table doesn't double, there's no telling whether your new
 entry will be inserted before or after the current iterator position.
 
-Either treasure up your changes and make them after the iterator finishes,
+Either treasure up your changes and make them after the iterator finishes
 or use keys to fetch all the old keys at once, and iterate over the list
 of keys.
 
@@ -1471,7 +1481,7 @@ take the scalar sense of the keys() function:
 
     $num_keys = scalar keys %hash;
 
-In void context, the keys() function just resets the iterator, which is
+The keys() function also resets the iterator, which in void context is
 faster for tied hashes than would be iterating through the whole 
 hash, one key-value pair at a time.
 
@@ -1487,8 +1497,8 @@ keys or values:
            } keys %hash;       # and by value
 
 Here we'll do a reverse numeric sort by value, and if two keys are
-identical, sort by length of key, and if that fails, by straight ASCII
-comparison of the keys (well, possibly modified by your locale -- see
+identical, sort by length of key, or if that fails, by straight ASCII
+comparison of the keys (well, possibly modified by your locale--see
 L<perllocale>).
 
     @keys = sort {
index feb66a4..e4ad3fa 100644 (file)
@@ -10,7 +10,7 @@ formats, and footers.
 =head2 How do I flush/unbuffer an output filehandle?  Why must I do this?
 
 The C standard I/O library (stdio) normally buffers characters sent to
-devices.  This is done for efficiency reasons, so that there isn't a
+devices.  This is done for efficiency reasons so that there isn't a
 system call for each byte.  Any time you use print() or write() in
 Perl, you go though this buffering.  syswrite() circumvents stdio and
 buffering.
@@ -83,16 +83,17 @@ Perl is a programming language.  You have to decompose the problem into
 low-level calls to read, write, open, close, and seek.
 
 Although humans have an easy time thinking of a text file as being a
-sequence of lines that operates much like a stack of playing cards -- or
-punch cards -- computers usually see the text file as a sequence of bytes.
+sequence of lines that operates much like a stack of playing cards--or
+punch cards--computers usually see the text file as a sequence of bytes.
 In general, there's no direct way for Perl to seek to a particular line
 of a file, insert text into a file, or remove text from a file.
 
-(There are exceptions in special circumstances.  You can add or remove at
-the very end of the file.  Another is replacing a sequence of bytes with
-another sequence of the same length.  Another is using the C<$DB_RECNO>
-array bindings as documented in L<DB_File>.  Yet another is manipulating
-files with all lines the same length.)
+(There are exceptions in special circumstances.  You can add or remove
+data at the very end of the file.  A sequence of bytes can be replaced
+with another sequence of the same length.  The C<$DB_RECNO> array
+bindings as documented in L<DB_File> also provide a direct way of
+modifying a file.  Files where all lines are the same length are also
+easy to alter.)
 
 The general solution is to create a temporary copy of the text file with
 the changes you want, then copy that over the original.  This assumes
@@ -174,16 +175,17 @@ This assumes no funny games with newline translations.
 =head2 How do I make a temporary file name?
 
 Use the C<new_tmpfile> class method from the IO::File module to get a
-filehandle opened for reading and writing.  Use this if you don't
-need to know the file's name.
+filehandle opened for reading and writing.  Use it if you don't
+need to know the file's name:
 
     use IO::File;
     $fh = IO::File->new_tmpfile()
        or die "Unable to make new temporary file: $!";
 
-Or you can use the C<tmpnam> function from the POSIX module to get a
-filename that you then open yourself.  Use this if you do need to know
-the file's name.
+If you do need to know the file's name, you can use the C<tmpnam>
+function from the POSIX module to get a filename that you then open
+yourself:
+
 
     use Fcntl;
     use POSIX qw(tmpnam);
@@ -199,9 +201,9 @@ the file's name.
 
     # now go on to use the file ...
 
-If you're committed to doing this by hand, use the process ID and/or
-the current time-value.  If you need to have many temporary files in
-one process, use a counter:
+If you're committed to creating a temporary file by hand, use the
+process ID and/or the current time-value.  If you need to have many
+temporary files in one process, use a counter:
 
     BEGIN {
        use Fcntl;
@@ -272,7 +274,7 @@ had, for example, a function named TmpHandle(), or a variable named
        # *HostFile automatically closes/disappears here
     }
 
-Here's how to use this in a loop to open and store a bunch of
+Here's how to use typeglobs in a loop to open and store a bunch of
 filehandles.  We'll use as values of the hash an ordered
 pair to make it easy to sort the hash in insertion order.
 
@@ -292,8 +294,8 @@ pair to make it easy to sort the hash in insertion order.
     }
 
 For passing filehandles to functions, the easiest way is to 
-preface them with a star, as in func(*STDIN).  See L<perlfaq7/"Passing
-Filehandles"> for details.
+preface them with a star, as in func(*STDIN).  
+See L<perlfaq7/"Passing Filehandles"> for details.
 
 If you want to create many anonymous handles, you should check out the
 Symbol, FileHandle, or IO::Handle (etc.) modules.  Here's the equivalent
@@ -306,7 +308,7 @@ code with Symbol::gensym, which is reasonably light-weight:
         $file{$filename} = [ $i++, $fh ];
     }
 
-Or here using the semi-object-oriented FileHandle module, which certainly
+Here's using the semi-object-oriented FileHandle module, which certainly
 isn't light-weight:
 
     use FileHandle;
@@ -317,7 +319,7 @@ isn't light-weight:
     }
 
 Please understand that whether the filehandle happens to be a (probably
-localized) typeglob or an anonymous handle from one of the modules,
+localized) typeglob or an anonymous handle from one of the modules
 in no way affects the bizarre rules for managing indirect handles.
 See the next question.
 
@@ -325,7 +327,7 @@ See the next question.
 
 An indirect filehandle is using something other than a symbol
 in a place that a filehandle is expected.  Here are ways
-to get those:
+to get indirect filehandles:
 
     $fh =   SOME_FH;       # bareword is strict-subs hostile
     $fh =  "SOME_FH";      # strict-refs hostile; same package only
@@ -333,7 +335,7 @@ to get those:
     $fh = \*SOME_FH;       # ref to typeglob (bless-able)
     $fh =  *SOME_FH{IO};   # blessed IO::Handle from *SOME_FH typeglob
 
-Or to use the C<new> method from the FileHandle or IO modules to
+Or, you can use the C<new> method from the FileHandle or IO modules to
 create an anonymous filehandle, store that in a scalar variable,
 and use it as though it were a normal filehandle.
 
@@ -378,9 +380,10 @@ is risky.)
     accept_fh($handle);
 
 In the examples above, we assigned the filehandle to a scalar variable
-before using it.  That is because only simple scalar variables,
-not expressions or subscripts into hashes or arrays, can be used with
-built-ins like C<print>, C<printf>, or the diamond operator.  These are
+before using it.  That is because only simple scalar variables, not
+expressions or subscripts of hashes or arrays, can be used with
+built-ins like C<print>, C<printf>, or the diamond operator.  Using
+something other than a simple scalar varaible as a filehandle is
 illegal and won't even compile:
 
     @fd = (*STDIN, *STDOUT, *STDERR);
@@ -449,7 +452,7 @@ You can't just:
 because you have to put the comma in and then recalculate your
 position.
 
-Alternatively, this commifies all numbers in a line regardless of
+Alternatively, this code commifies all numbers in a line regardless of
 whether they have decimal portions, are preceded by + or -, or
 whatever:
 
@@ -465,7 +468,7 @@ whatever:
 
 Use the <> (glob()) operator, documented in L<perlfunc>.  This
 requires that you have a shell installed that groks tildes, meaning
-csh or tcsh or (some versions of) ksh, and thus may have portability
+csh or tcsh or (some versions of) ksh, and thus your code may have portability
 problems.  The Glob::KGlob module (available from CPAN) gives more
 portable glob functionality.
 
@@ -551,8 +554,8 @@ To open a file without blocking, creating if necessary:
 
 Be warned that neither creation nor deletion of files is guaranteed to
 be an atomic operation over NFS.  That is, two processes might both
-successful create or unlink the same file!  Therefore O_EXCL
-isn't so exclusive as you might wish.
+successfully create or unlink the same file!  Therefore O_EXCL
+isn't as exclusive as you might wish.
 
 See also the new L<perlopentut> if you have it (new for 5.6).
 
@@ -573,15 +576,15 @@ one that doesn't use the shell to do globbing.
 
 Due to the current implementation on some operating systems, when you
 use the glob() function or its angle-bracket alias in a scalar
-context, you may cause a leak and/or unpredictable behavior.  It's
+context, you may cause a memory leak and/or unpredictable behavior.  It's
 best therefore to use glob() only in list context.
 
 =head2 How can I open a file with a leading ">" or trailing blanks?
 
 Normally perl ignores trailing blanks in filenames, and interprets
 certain leading characters (or a trailing "|") to mean something
-special.  To avoid this, you might want to use a routine like this.
-It makes incomplete pathnames into explicit relative ones, and tacks a
+special.  To avoid this, you might want to use a routine like the one below.
+It turns incomplete pathnames into explicit relative ones, and tacks a
 trailing null byte on the name to make perl leave it alone:
 
     sub safe_filename {
@@ -603,7 +606,7 @@ It would be a lot clearer to use sysopen(), though:
 
     use Fcntl;
     $badpath = "<<<something really wicked   ";
-    open (FH, $badpath, O_WRONLY | O_CREAT | O_TRUNC)
+    sysopen (FH, $badpath, O_WRONLY | O_CREAT | O_TRUNC)
        or die "can't open $badpath: $!";
 
 For more information, see also the new L<perlopentut> if you have it
@@ -611,10 +614,10 @@ For more information, see also the new L<perlopentut> if you have it
 
 =head2 How can I reliably rename a file?
 
-Well, usually you just use Perl's rename() function.  But that may not
-work everywhere, in particular, renaming files across file systems.
+Well, usually you just use Perl's rename() function.  That may not
+work everywhere, though, particularly when renaming files across file systems.
 Some sub-Unix systems have broken ports that corrupt the semantics of
-rename() -- for example, WinNT does this right, but Win95 and Win98
+rename()--for example, WinNT does this right, but Win95 and Win98
 are broken.  (The last two parts are not surprising, but the first is. :-)
 
 If your operating system supports a proper mv(1) program or its moral
@@ -624,11 +627,11 @@ equivalent, this works:
 
 It may be more compelling to use the File::Copy module instead.  You
 just copy to the new file to the new name (checking return values),
-then delete the old one.  This isn't really the same semantics as a
+then delete the old one.  This isn't really the same semantically as a
 real rename(), though, which preserves metainformation like
 permissions, timestamps, inode info, etc.
 
-The newer version of File::Copy exports a move() function.
+Newer versions of File::Copy exports a move() function.
 
 =head2 How can I lock a file?
 
@@ -654,12 +657,12 @@ filehandle be open for writing (or appending, or read/writing).
 
 Some versions of flock() can't lock files over a network (e.g. on NFS file
 systems), so you'd need to force the use of fcntl(2) when you build Perl.
-But even this is dubious at best.  See the flock entry of L<perlfunc>,
+But even this is dubious at best.  See the flock entry of L<perlfunc>
 and the F<INSTALL> file in the source distribution for information on
 building Perl to do this.
 
 Two potentially non-obvious but traditional flock semantics are that
-it waits indefinitely until the lock is granted, and that its locks
+it waits indefinitely until the lock is granted, and that its locks are
 I<merely advisory>.  Such discretionary locks are more flexible, but
 offer fewer guarantees.  This means that files locked with flock() may
 be modified by programs that do not also use flock().  Cars that stop
@@ -667,13 +670,13 @@ for red lights get on well with each other, but not with cars that don't
 stop for red lights.  See the perlport manpage, your port's specific
 documentation, or your system-specific local manpages for details.  It's
 best to assume traditional behavior if you're writing portable programs.
-(But if you're not, you should as always feel perfectly free to write
+(If you're not, you should as always feel perfectly free to write
 for your own system's idiosyncrasies (sometimes called "features").
 Slavish adherence to portability concerns shouldn't get in the way of
 your getting your job done.)
 
-For more information on file locking, see also L<perlopentut/"File
-Locking"> if you have it (new for 5.6).
+For more information on file locking, see also 
+L<perlopentut/"File Locking"> if you have it (new for 5.6).
 
 =back
 
@@ -700,20 +703,18 @@ these tend to involve busy-wait, which is also subdesirable.
 
 Didn't anyone ever tell you web-page hit counters were useless?
 They don't count number of hits, they're a waste of time, and they serve
-only to stroke the writer's vanity.  Better to pick a random number.
-It's more realistic.
+only to stroke the writer's vanity.  It's better to pick a random number;
+they're more realistic.
 
 Anyway, this is what you can do if you can't help yourself.
 
-    use Fcntl ':flock';
+    use Fcntl qw(:DEFAULT :flock);
     sysopen(FH, "numfile", O_RDWR|O_CREAT)      or die "can't open numfile: $!";
     flock(FH, LOCK_EX)                                  or die "can't flock numfile: $!";
     $num = <FH> || 0;
     seek(FH, 0, 0)                              or die "can't rewind numfile: $!";
     truncate(FH, 0)                             or die "can't truncate numfile: $!";
     (print FH $num+1, "\n")                     or die "can't write numfile: $!";
-    # Perl as of 5.004 automatically flushes before unlocking
-    flock(FH, LOCK_UN)                                  or die "can't flock numfile: $!";
     close FH                                    or die "can't close numfile: $!";
 
 Here's a much better web-page hit counter:
@@ -743,7 +744,7 @@ like this:
     close FH;
 
 Locking and error checking are left as an exercise for the reader.
-Don't forget them, or you'll be quite sorry.
+Don't forget them or you'll be quite sorry.
 
 =head2 How do I get a file's timestamp in perl?
 
@@ -793,7 +794,7 @@ Error checking is, as usual, left as an exercise for the reader.
 
 Note that utime() currently doesn't work correctly with Win95/NT
 ports.  A bug has been reported.  Check it carefully before using
-it on those platforms.
+utime() on those platforms.
 
 =head2 How do I print to more than one file at once?
 
@@ -815,8 +816,8 @@ Or even:
     close(STDOUT)                            or die "Closing: $!\n";
 
 Otherwise you'll have to write your own multiplexing print
-function -- or your own tee program -- or use Tom Christiansen's,
-at http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz, which is
+function--or your own tee program--or use Tom Christiansen's,
+at http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz , which is
 written in Perl and offers much greater functionality
 than the stock version.
 
@@ -834,12 +835,12 @@ do so one line at a time:
 
 This is tremendously more efficient than reading the entire file into
 memory as an array of lines and then processing it one element at a time,
-which is often -- if not almost always -- the wrong approach.  Whenever
+which is often--if not almost always--the wrong approach.  Whenever
 you see someone do this:
 
     @lines = <INPUT>;
 
-You should think long and hard about why you need everything loaded
+you should think long and hard about why you need everything loaded
 at once.  It's just not a scalable solution.  You might also find it
 more fun to use the standard DB_File module's $DB_RECNO bindings,
 which allow you to tie an array to a file so that accessing an element
@@ -847,7 +848,7 @@ the array actually accesses the corresponding line in the file.
 
 On very rare occasion, you may have an algorithm that demands that
 the entire file be in memory at once as one scalar.  The simplest solution
-to that is:
+to that is
 
     $var = `cat $file`;
 
@@ -886,7 +887,7 @@ Note that a blank line must have no blanks in it.  Thus C<"fred\n
 
 You can use the builtin C<getc()> function for most filehandles, but
 it won't (easily) work on a terminal device.  For STDIN, either use
-the Term::ReadKey module from CPAN, or use the sample code in
+the Term::ReadKey module from CPAN or use the sample code in
 L<perlfunc/getc>.
 
 If your system supports the portable operating system programming
@@ -942,7 +943,7 @@ turns off echo processing as well.
 
     END { cooked() }
 
-The Term::ReadKey module from CPAN may be easier to use.  Recent version
+The Term::ReadKey module from CPAN may be easier to use.  Recent versions
 include also support for non-portable systems as well.
 
     use Term::ReadKey;
@@ -997,8 +998,8 @@ table:
     # 78-83   ALT 1234567890-=
     # 84      CTR PgUp
 
-This is all trial and error I did a long time ago, I hope I'm reading the
-file that worked.
+This is all trial and error I did a long time ago; I hope I'm reading the
+file that worked...
 
 =head2 How can I tell whether there's a character waiting on a filehandle?
 
@@ -1056,7 +1057,7 @@ And then hard-code it, leaving porting as an exercise to your successor.
     ioctl(FH, $FIONREAD, $size)     or die "Couldn't call ioctl: $!\n";
     $size = unpack("L", $size);
 
-FIONREAD requires a filehandle connected to a stream, meaning sockets,
+FIONREAD requires a filehandle connected to a stream, meaning that sockets,
 pipes, and tty devices work, but I<not> files.
 
 =head2 How do I do a C<tail -f> in perl?
@@ -1111,14 +1112,14 @@ Error checking, as always, has been left as an exercise for the reader.
 
 This should rarely be necessary, as the Perl close() function is to be
 used for things that Perl opened itself, even if it was a dup of a
-numeric descriptor, as with MHCONTEXT above.  But if you really have
+numeric descriptor as with MHCONTEXT above.  But if you really have
 to, you may be able to do this:
 
     require 'sys/syscall.ph';
     $rc = syscall(&SYS_close, $fd + 0);  # must force numeric
     die "can't sysclose $fd: $!" unless $rc == -1;
 
-Or just use the fdopen(3S) feature of open():
+Or, just use the fdopen(3S) feature of open():
 
     { 
        local *F; 
@@ -1138,7 +1139,7 @@ have a file called "c:(tab)emp(formfeed)oo" or
 Either single-quote your strings, or (preferably) use forward slashes.
 Since all DOS and Windows versions since something like MS-DOS 2.0 or so
 have treated C</> and C<\> the same in a path, you might as well use the
-one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++,
+one that doesn't clash with Perl--or the POSIX shell, ANSI C and C++,
 awk, Tcl, Java, or Python, just to mention a few.  POSIX paths
 are more portable, too.
 
@@ -1173,7 +1174,7 @@ Here's an algorithm from the Camel Book:
 
 This has a significant advantage in space over reading the whole
 file in.  A simple proof by induction is available upon 
-request if you doubt its correctness.
+request if you doubt the algorithm's correctness.
 
 =head2 Why do I get weird spaces when I print an array of lines?
 
@@ -1183,7 +1184,7 @@ Saying
 
 joins together the elements of C<@lines> with a space between them.
 If C<@lines> were C<("little", "fluffy", "clouds")> then the above
-statement would print:
+statement would print
 
     little fluffy clouds
 
index 4ab4d4c..5100c35 100644 (file)
@@ -8,8 +8,9 @@ This section is surprisingly small because the rest of the FAQ is
 littered with answers involving regular expressions.  For example,
 decoding a URL and checking whether something is a number are handled
 with regular expressions, but those answers are found elsewhere in
-this document (in the section on Data and the Networking one on
-networking, to be precise).
+this document (in L<perlfaq9>: ``How do I decode or create those %-encodings 
+on the web'' and L<perfaq4>: ``How do I determine whether a scalar is
+a number/whole/integer/float'', to be precise).
 
 =head2 How can I hope to use regular expressions without creating illegible and unmaintainable code?
 
@@ -175,7 +176,7 @@ appear within a certain time.
     $file->waitfor('/second line\n/');
     print $file->getline;
 
-=head2 How do I substitute case insensitively on the LHS, but preserving case on the RHS?
+=head2 How do I substitute case insensitively on the LHS while preserving case on the RHS?
 
 Here's a lovely Perlish solution by Larry Rosler.  It exploits
 properties of bitwise xor on ASCII strings.
@@ -280,10 +281,11 @@ Without the \Q, the regex would also spuriously match "di".
 =head2 What is C</o> really for?
 
 Using a variable in a regular expression match forces a re-evaluation
-(and perhaps recompilation) each time through.  The C</o> modifier
-locks in the regex the first time it's used.  This always happens in a
-constant regular expression, and in fact, the pattern was compiled
-into the internal format at the same time your entire program was.
+(and perhaps recompilation) each time the regular expression is
+encountered.  The C</o> modifier locks in the regex the first time
+it's used.  This always happens in a constant regular expression, and
+in fact, the pattern was compiled into the internal format at the same
+time your entire program was.
 
 Use of C</o> is irrelevant unless variable interpolation is used in
 the pattern, and if so, the regex engine will neither know nor care
@@ -367,8 +369,8 @@ A slight modification also removes C++ comments:
 =head2 Can I use Perl regular expressions to match balanced text?
 
 Although Perl regular expressions are more powerful than "mathematical"
-regular expressions, because they feature conveniences like backreferences
-(C<\1> and its ilk), they still aren't powerful enough -- with
+regular expressions because they feature conveniences like backreferences
+(C<\1> and its ilk), they still aren't powerful enough--with
 the possible exception of bizarre and experimental features in the
 development-track releases of Perl.  You still need to use non-regex
 techniques to parse balanced text, such as the text enclosed between
@@ -379,7 +381,7 @@ and possibly nested single chars, like C<`> and C<'>, C<{> and C<}>,
 or C<(> and C<)> can be found in
 http://www.perl.com/CPAN/authors/id/TOMC/scripts/pull_quotes.gz .
 
-The C::Scan module from CPAN contains such subs for internal usage,
+The C::Scan module from CPAN contains such subs for internal use,
 but they are undocumented.
 
 =head2 What does it mean that regexes are greedy?  How can I get around it?
@@ -402,7 +404,7 @@ expression engine to find a match as quickly as possible and pass
 control on to whatever is next in line, like you would if you were
 playing hot potato.
 
-=head2  How do I process each word on each line?
+=head2 How do I process each word on each line?
 
 Use the split function:
 
@@ -450,7 +452,8 @@ regular expression:
        print "$count $line";
     }
 
-If you want these output in a sorted order, see the section on Hashes.
+If you want these output in a sorted order, see L<perlfaq4>: ``How do I
+sort a hash (optionally by value instead of key)?''.
 
 =head2 How can I do approximate matching?
 
@@ -487,7 +490,7 @@ approach, one which makes use of the new C<qr//> operator:
 
 =head2 Why don't word-boundary searches with C<\b> work for me?
 
-Two common misconceptions are that C<\b> is a synonym for C<\s+>, and
+Two common misconceptions are that C<\b> is a synonym for C<\s+> and
 that it's the edge between whitespace characters and non-whitespace
 characters.  Neither is correct.  C<\b> is the place between a C<\w>
 character and a C<\W> character (that is, C<\b> is the edge of a
@@ -514,11 +517,11 @@ not "this" or "island".
 
 =head2 Why does using $&, $`, or $' slow my program down?
 
-Because once Perl sees that you need one of these variables anywhere in
-the program, it has to provide them on each and every pattern match.
+Once Perl sees that you need one of these variables anywhere in
+the program, it provides them on each and every pattern match.
 The same mechanism that handles these provides for the use of $1, $2,
 etc., so you pay the same price for each regex that contains capturing
-parentheses. But if you never use $&, etc., in your script, then regexes
+parentheses.  If you never use $&, etc., in your script, then regexes
 I<without> capturing parentheses won't be penalized. So avoid $&, $',
 and $` if you can, but if you can't, once you've used them at all, use
 them at will because you've already paid the price.  Remember that some
@@ -589,7 +592,7 @@ Of course, that could have been written as
       }
     }
 
-But then you lose the vertical alignment of the regular expressions.
+but then you lose the vertical alignment of the regular expressions.
 
 =head2 Are Perl regexes DFAs or NFAs?  Are they POSIX compliant?
 
@@ -670,12 +673,12 @@ Well, if it's really a pattern, then just use
     chomp($pattern = <STDIN>);
     if ($line =~ /$pattern/) { }
 
-Or, since you have no guarantee that your user entered
+Alternatively, since you have no guarantee that your user entered
 a valid regular expression, trap the exception this way:
 
     if (eval { $line =~ /$pattern/ }) { }
 
-But if all you really want to search for a string, not a pattern,
+If all you really want to search for a string, not a pattern,
 then you should either use the index() function, which is made for
 string searching, or if you can't be disabused of using a pattern
 match on a non-pattern, then be sure to use C<\Q>...C<\E>, documented
index 0d4876f..0299c2d 100644 (file)
@@ -29,18 +29,18 @@ They are type specifiers, as detailed in L<perldata>:
     * for all types of that symbol name.  In version 4 you used them like
       pointers, but in modern perls you can just use references.
 
-A couple of others that you're likely to encounter that aren't
-really type specifiers are:
+There are couple of other symbols that you're likely to encounter that aren't
+really type specifiers:
 
     <> are used for inputting a record from a filehandle.
     \  takes a reference to something.
 
 Note that <FILE> is I<neither> the type specifier for files
 nor the name of the handle.  It is the C<< <> >> operator applied
-to the handle FILE.  It reads one line (well, record - see
+to the handle FILE.  It reads one line (well, record--see
 L<perlvar/$/>) from the handle FILE in scalar context, or I<all> lines
 in list context.  When performing open, close, or any other operation
-besides C<< <> >> on files, or even talking about the handle, do
+besides C<< <> >> on files, or even when talking about the handle, do
 I<not> use the brackets.  These are correct: C<eof(FH)>, C<seek(FH, 0,
 2)> and "copying from STDIN to FILE".
 
@@ -106,15 +106,15 @@ use my() on C<$^W>, only local().
 
 =head2 What's an extension?
 
-A way of calling compiled C code from Perl.  Reading L<perlxstut>
-is a good place to learn more about extensions.
+An extension is a way of calling compiled C code from Perl.  Reading
+L<perlxstut> is a good place to learn more about extensions.
 
 =head2 Why do Perl operators have different precedence than C operators?
 
 Actually, they don't.  All C operators that Perl copies have the same
 precedence in Perl as they do in C.  The problem is with operators that C
 doesn't have, especially functions that give a list context to everything
-on their right, eg print, chmod, exec, and so on.  Such functions are
+on their right, eg. print, chmod, exec, and so on.  Such functions are
 called "list operators" and appear as such in the precedence table in
 L<perlop>.
 
@@ -258,7 +258,7 @@ is given no processes to signal):
     }
 
 This is not C<-w> clean, however.  There is no C<-w> clean way to
-detect taintedness - take this as a hint that you should untaint
+detect taintedness--take this as a hint that you should untaint
 all possibly-tainted data.
 
 =head2 What's a closure?
@@ -274,7 +274,7 @@ around when the subroutine was defined (deep binding).
 Closures make sense in any programming language where you can have the
 return value of a function be itself a function, as you can in Perl.
 Note that some languages provide anonymous functions but are not
-capable of providing proper closures; the Python language, for
+capable of providing proper closures: the Python language, for
 example.  For more information on closures, check out any textbook on
 functional programming.  Scheme is a language that not only supports
 but encourages closures.
@@ -349,11 +349,14 @@ With the exception of regexes, you need to pass references to these
 objects.  See L<perlsub/"Pass by Reference"> for this particular
 question, and L<perlref> for information on references.
 
+See ``Passing Regexes'', below, for information on passing regular
+expressions.
+
 =over 4
 
 =item Passing Variables and Functions
 
-Regular variables and functions are quite easy: just pass in a
+Regular variables and functions are quite easy to pass: just pass in a
 reference to an existing or anonymous variable or function:
 
     func( \$some_scalar );
@@ -370,7 +373,7 @@ reference to an existing or anonymous variable or function:
 =item Passing Filehandles
 
 To pass filehandles to subroutines, use the C<*FH> or C<\*FH> notations.
-These are "typeglobs" - see L<perldata/"Typeglobs and Filehandles">
+These are "typeglobs"--see L<perldata/"Typeglobs and Filehandles">
 and especially L<perlsub/"Pass by Reference"> for more information.
 
 Here's an excerpt:
@@ -394,7 +397,7 @@ they'll still work properly under C<use strict 'refs'>.  For example:
 If you're planning on generating new filehandles, you could do this:
 
     sub openit {
-        my $name = shift;
+        my $path = shift;
         local *FH;
         return open (FH, $path) ? *FH : undef;
     }
@@ -460,8 +463,8 @@ To pass an object method into a subroutine, you can do this:
         }
     }
 
-Or you can use a closure to bundle up the object and its method call
-and arguments:
+Or, you can use a closure to bundle up the object, its
+method call, and arguments:
 
     my $whatnot =  sub { $some_obj->obfuscate(@args) };
     func($whatnot);
@@ -495,8 +498,8 @@ Now prev_counter() and next_counter() share a private variable $counter
 that was initialized at compile time.
 
 To declare a file-private variable, you'll still use a my(), putting
-it at the outer scope level at the top of the file.  Assume this is in
-file Pax.pm:
+the declaration at the outer scope level at the top of the file.
+Assume this is in file Pax.pm:
 
     package Pax;
     my $started = scalar(localtime(time()));
@@ -516,14 +519,14 @@ See L<perlsub/"Persistent Private Variables"> for details.
 
 =head2 What's the difference between dynamic and lexical (static) scoping?  Between local() and my()?
 
-C<local($x)> saves away the old value of the global variable C<$x>,
-and assigns a new value for the duration of the subroutine, I<which is
+C<local($x)> saves away the old value of the global variable C<$x>
+and assigns a new value for the duration of the subroutine I<which is
 visible in other functions called from that subroutine>.  This is done
 at run-time, so is called dynamic scoping.  local() always affects global
 variables, also called package variables or dynamic variables.
 
 C<my($x)> creates a new variable that is only visible in the current
-subroutine.  This is done at compile-time, so is called lexical or
+subroutine.  This is done at compile-time, so it is called lexical or
 static scoping.  my() always affects private variables, also called
 lexical variables or (improperly) static(ly scoped) variables.
 
@@ -557,8 +560,8 @@ In summary, local() doesn't make what you think of as private, local
 variables.  It gives a global variable a temporary value.  my() is
 what you're looking for if you want private variables.
 
-See L<perlsub/"Private Variables via my()"> and L<perlsub/"Temporary
-Values via local()"> for excruciating details.
+See L<perlsub/"Private Variables via my()"> and 
+L<perlsub/"Temporary Values via local()"> for excruciating details.
 
 =head2 How can I access a dynamic variable while a similarly named lexical is in scope?
 
@@ -634,8 +637,8 @@ see L<perltoot/"Overridden Methods">.
 =head2 What's the difference between calling a function as &foo and foo()?
 
 When you call a function as C<&foo>, you allow that function access to
-your current @_ values, and you by-pass prototypes.  That means that
-the function doesn't get an empty @_, it gets yours!  While not
+your current @_ values, and you bypass prototypes.
+The function doesn't get an empty @_--it gets yours!  While not
 strictly speaking a bug (it's documented that way in L<perlsub>), it
 would be hard to consider this a feature in most cases.
 
@@ -709,7 +712,7 @@ Sometimes you should change the positions of the constant and the variable.
 For example, let's say you wanted to test which of many answers you were
 given, but in a case-insensitive way that also allows abbreviations.
 You can use the following technique if the strings all start with
-different characters, or if you want to arrange the matches so that
+different characters or if you want to arrange the matches so that
 one takes precedence over another, as C<"SEND"> has precedence over
 C<"STOP"> here:
 
@@ -767,15 +770,16 @@ C<__WARN__> like this:
 
 Some possible reasons: your inheritance is getting confused, you've
 misspelled the method name, or the object is of the wrong type.  Check
-out L<perltoot> for details on these.  You may also use C<print
-ref($object)> to find out the class C<$object> was blessed into.
+out L<perltoot> for details about any of the above cases.  You may
+also use C<print ref($object)> to find out the class C<$object> was
+blessed into.
 
 Another possible reason for problems is because you've used the
 indirect object syntax (eg, C<find Guru "Samy">) on a class name
 before Perl has seen that such a package exists.  It's wisest to make
 sure your packages are all defined before you start using them, which
 will be taken care of if you use the C<use> statement instead of
-C<require>.  If not, make sure to use arrow notation (eg,
+C<require>.  If not, make sure to use arrow notation (eg.,
 C<< Guru->find("Samy") >>) instead.  Object notation is explained in
 L<perlobj>.
 
@@ -789,7 +793,7 @@ out what the currently compiled package is:
 
     my $packname = __PACKAGE__;
 
-But if you're a method and you want to print an error message
+But, if you're a method and you want to print an error message
 that includes the kind of object you were called on (which is
 not necessarily the same as the one in which you were compiled):
 
@@ -861,19 +865,19 @@ of a variable.
 
 This works I<sometimes>, but it is a very bad idea for two reasons.
 
-The first reason is that they I<only work on global variables>.
-That means above that if $fred is a lexical variable created with my(),
-that the code won't work at all: you'll accidentally access the global
-and skip right over the private lexical altogether.  Global variables
-are bad because they can easily collide accidentally and in general make
-for non-scalable and confusing code.
+The first reason is that this technique I<only works on global
+variables>.  That means that if $fred is a lexical variable created
+with my() in the above example, the code wouldn't work at all: you'd
+accidentally access the global and skip right over the private lexical
+altogether.  Global variables are bad because they can easily collide
+accidentally and in general make for non-scalable and confusing code.
 
 Symbolic references are forbidden under the C<use strict> pragma.
 They are not true references and consequently are not reference counted
 or garbage collected.
 
 The other reason why using a variable to hold the name of another
-variable a bad idea is that the question often stems from a lack of
+variable is a bad idea is that the question often stems from a lack of
 understanding of Perl data structures, particularly hashes.  By using
 symbolic references, you are just using the package's symbol-table hash
 (like C<%main::>) instead of a user-defined hash.  The solution is to
@@ -894,7 +898,7 @@ own variables:
     $str = 'this has a $fred and $barney in it';
     $str =~ s/(\$\w+)/$1/eeg;            # need double eval
 
-Instead, it would be better to keep a hash around like %USER_VARS and have
+it would be better to keep a hash around like %USER_VARS and have
 variable references actually refer to entries in that hash:
 
     $str =~ s/\$(\w+)/$USER_VARS{$1}/g;   # no /e here at all
@@ -906,11 +910,11 @@ make it less confusing, like bracketed percent symbols, etc.
     $str = 'this has a %fred% and %barney% in it';
     $str =~ s/%(\w+)%/$USER_VARS{$1}/g;   # no /e here at all
 
-Another reason that folks sometimes think they want a variable to contain
-the name of a variable is because they don't know how to build proper
-data structures using hashes.  For example, let's say they wanted two
-hashes in their program: %fred and %barney, and to use another scalar
-variable to refer to those by name.
+Another reason that folks sometimes think they want a variable to
+contain the name of a variable is because they don't know how to build
+proper data structures using hashes.  For example, let's say they
+wanted two hashes in their program: %fred and %barney, and that they
+wanted to use another scalar variable to refer to those by name.
 
     $name = "fred";
     $$name{WIFE} = "wilma";     # set %fred
@@ -946,9 +950,9 @@ but the real code in the closure actually was compiled only once.
 
 So, sometimes you might want to use symbolic references to directly
 manipulate the symbol table.  This doesn't matter for formats, handles, and
-subroutines, because they are always global -- you can't use my() on them.
-But for scalars, arrays, and hashes -- and usually for subroutines --
-you probably want to use hard references only.
+subroutines, because they are always global--you can't use my() on them.
+For scalars, arrays, and hashes, though--and usually for subroutines--
+you probably only want to use hard references.
 
 =head1 AUTHOR AND COPYRIGHT
 
@@ -967,3 +971,4 @@ are hereby placed into the public domain.  You are permitted and
 encouraged to use this code in your own programs for fun
 or for profit as you see fit.  A simple comment in the code giving
 credit would be courteous but is not required.
+
index 0ac4620..d806ed6 100644 (file)
@@ -5,7 +5,7 @@ perlfaq8 - System Interaction ($Revision: 1.39 $, $Date: 1999/05/23 18:37:57 $)
 =head1 DESCRIPTION
 
 This section of the Perl FAQ covers questions involving operating
-system interaction.  This involves interprocess communication (IPC),
+system interaction.  Topics include interprocess communication (IPC),
 control over the user-interface (keyboard, screen and pointing
 devices), and most anything else not related to data manipulation.
 
@@ -95,10 +95,10 @@ It even includes limited support for Windows.
     $key = ReadKey(0);
     ReadMode('normal');
 
-However, that requires that you have a working C compiler and can use it
-to build and install a CPAN module.  Here's a solution using
-the standard POSIX module, which is already on your systems (assuming
-your system supports POSIX).
+However, using the code requires that you have a working C compiler
+and can use it to build and install a CPAN module.  Here's a solution
+using the standard POSIX module, which is already on your systems
+(assuming your system supports POSIX).
 
     use HotKey;
     $key = readkey();
@@ -214,10 +214,10 @@ illustrative:
 (This question has nothing to do with the web.  See a different
 FAQ for that.)
 
-There's an example of this in L<perlfunc/crypt>).  First, you put
-the terminal into "no echo" mode, then just read the password
-normally.  You may do this with an old-style ioctl() function, POSIX
-terminal control (see L<POSIX>, and Chapter 7 of the Camel), or a call
+There's an example of this in L<perlfunc/crypt>).  First, you put the
+terminal into "no echo" mode, then just read the password normally.
+You may do this with an old-style ioctl() function, POSIX terminal
+control (see L<POSIX> or its documentation the Camel Book), or a call
 to the B<stty> program, with varying degrees of portability.
 
 You can also do this for most systems using the Term::ReadKey module
@@ -232,16 +232,16 @@ from CPAN, which is easier to use and in theory more portable.
 
 This depends on which operating system your program is running on.  In
 the case of Unix, the serial ports will be accessible through files in
-/dev; on other systems, the devices names will doubtless differ.
+/dev; on other systems, device names will doubtless differ.
 Several problem areas common to all device interaction are the
-following
+following:
 
 =over 4
 
 =item lockfiles
 
 Your system may use lockfiles to control multiple access.  Make sure
-you follow the correct protocol.  Unpredictable behaviour can result
+you follow the correct protocol.  Unpredictable behavior can result
 from multiple processes reading from one device.
 
 =item open mode
@@ -264,7 +264,7 @@ give the numeric values you want directly, using octal ("\015"), hex
     print DEV "atv1\012";      # wrong, for some devices
     print DEV "atv1\015";      # right, for some devices
 
-Even though with normal text files, a "\n" will do the trick, there is
+Even though with normal text files a "\n" will do the trick, there is
 still no unified scheme for terminating a line that is portable
 between Unix, DOS/Win, and Macintosh, except to terminate I<ALL> line
 ends with "\015\012", and strip what you don't need from the output.
@@ -276,7 +276,8 @@ next.
 If you expect characters to get to your device when you print() them,
 you'll want to autoflush that filehandle.  You can use select()
 and the C<$|> variable to control autoflushing (see L<perlvar/$|>
-and L<perlfunc/select>):
+and L<perlfunc/select>, or L<perlfaq5>, ``How do I flush/unbuffer an
+output filehandle?  Why must I do this?''):
 
     $oldh = select(DEV);
     $| = 1;
@@ -331,7 +332,7 @@ go bump in the night, finally came up with this:
 You spend lots and lots of money on dedicated hardware, but this is
 bound to get you talked about.
 
-Seriously, you can't if they are Unix password files - the Unix
+Seriously, you can't if they are Unix password files--the Unix
 password system employs one-way encryption.  It's more like hashing than
 encryption.  The best you can check is whether something else hashes to
 the same string.  You can't turn a hash back into the original string.
@@ -388,7 +389,8 @@ Zombies are not an issue with C<system("prog &")>.
 You don't actually "trap" a control character.  Instead, that character
 generates a signal which is sent to your terminal's currently
 foregrounded process group, which you then trap in your process.
-Signals are documented in L<perlipc/"Signals"> and chapter 6 of the Camel.
+Signals are documented in L<perlipc/"Signals"> and the
+section on ``Signals'' in the Camel.
 
 Be warned that very few C libraries are re-entrant.  Therefore, if you
 attempt to print() in a handler that got invoked during another stdio
@@ -397,7 +399,7 @@ inconsistent state, and your program will dump core.  You can
 sometimes avoid this by using syswrite() instead of print().
 
 Unless you're exceedingly careful, the only safe things to do inside a
-signal handler are: set a variable and exit.  And in the first case,
+signal handler are (1) set a variable and (2) exit.  In the first case,
 you should only set a variable in such a way that malloc() is not
 called (eg, by setting a variable that already has a value).
 
@@ -413,15 +415,16 @@ However, because syscalls restart by default, you'll find that if
 you're in a "slow" call, such as <FH>, read(), connect(), or
 wait(), that the only way to terminate them is by "longjumping" out;
 that is, by raising an exception.  See the time-out handler for a
-blocking flock() in L<perlipc/"Signals"> or chapter 6 of the Camel.
+blocking flock() in L<perlipc/"Signals"> or the section on ``Signals''
+in the Camel book.
 
 =head2 How do I modify the shadow password file on a Unix system?
 
-If perl was installed correctly, and your shadow library was written
+If perl was installed correctly and your shadow library was written
 properly, the getpw*() functions described in L<perlfunc> should in
 theory provide (read-only) access to entries in the shadow password
 file.  To change the file, make a new shadow password file (the format
-varies from system to system - see L<passwd(5)> for specifics) and use
+varies from system to system--see L<passwd(5)> for specifics) and use
 pwd_mkdb(8) to install it (see L<pwd_mkdb(8)> for more details).
 
 =head2 How do I set the time and date?
@@ -494,15 +497,16 @@ managed to finish its output without filling up the disk:
        close(STDOUT) || die "stdout close failed: $!";
     } 
 
-The END block isn't called when untrapped signals kill the program, though, so if
-you use END blocks you should also use
+The END block isn't called when untrapped signals kill the program,
+though, so if you use END blocks you should also use
 
        use sigtrap qw(die normal-signals);
 
 Perl's exception-handling mechanism is its eval() operator.  You can
 use eval() as setjmp and die() as longjmp.  For details of this, see
 the section on signals, especially the time-out handler for a blocking
-flock() in L<perlipc/"Signals"> and chapter 6 of the Camel.
+flock() in L<perlipc/"Signals"> or the section on ``Signals'' in
+the Camel Book.
 
 If exception handling is all you're interested in, try the
 exceptions.pl library (part of the standard perl distribution).
@@ -510,7 +514,7 @@ exceptions.pl library (part of the standard perl distribution).
 If you want the atexit() syntax (and an rmexit() as well), try the
 AtExit module available from CPAN.
 
-=head2 Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean?
+=head2 Why doesn't my sockets program work under System V (Solaris)?  What does the error message "Protocol not supported" mean?
 
 Some Sys-V based systems, notably Solaris 2.X, redefined some of the
 standard socket constants.  Since these were constant across all
@@ -522,14 +526,14 @@ values are different.  Go figure.
 
 =head2 How can I call my system's unique C functions from Perl?
 
-In most cases, you write an external module to do it - see the answer
+In most cases, you write an external module to do it--see the answer
 to "Where can I learn about linking C with Perl? [h2xs, xsubpp]".
 However, if the function is a system call, and your system supports
 syscall(), you can use the syscall function (documented in
 L<perlfunc>).
 
 Remember to check the modules that came with your distribution, and
-CPAN as well - someone may already have written a module to do it.
+CPAN as well--someone may already have written a module to do it.
 
 =head2 Where do I get the include files to do ioctl() or syscall()?
 
@@ -567,9 +571,9 @@ scripts inherently insecure.  Perl gives you a number of options
 The IPC::Open2 module (part of the standard perl distribution) is an
 easy-to-use approach that internally uses pipe(), fork(), and exec() to do
 the job.  Make sure you read the deadlock warnings in its documentation,
-though (see L<IPC::Open2>).  See L<perlipc/"Bidirectional Communication
-with Another Process"> and L<perlipc/"Bidirectional Communication with
-Yourself">
+though (see L<IPC::Open2>).  See 
+L<perlipc/"Bidirectional Communication with Another Process"> and 
+L<perlipc/"Bidirectional Communication with Yourself">
 
 You may also use the IPC::Open3 module (part of the standard perl
 distribution), but be warned that it has a different order of
@@ -595,7 +599,7 @@ There are three basic ways of running external commands:
     open (PIPE, "cmd |");      # using open()
 
 With system(), both STDOUT and STDERR will go the same place as the
-script's versions of these, unless the command redirects them.
+script's STDOUT and STDERR, unless the system() command redirects them.
 Backticks and open() read B<only> the STDOUT of your command.
 
 With any of these, you can change file descriptors before the call:
@@ -688,7 +692,7 @@ In some cases, even this won't work.  If the second argument to a
 piped open() contains shell metacharacters, perl fork()s, then exec()s
 a shell to decode the metacharacters and eventually run the desired
 program.  Now when you call wait(), you only learn whether or not the
-I<shell> could be successfully started.  Best to avoid shell
+I<shell> could be successfully started...it's best to avoid shell
 metacharacters.
 
 On systems that follow the spawn() paradigm, open() I<might> do what
@@ -715,17 +719,17 @@ Consider this line:
     `cat /etc/termcap`;
 
 You haven't assigned the output anywhere, so it just wastes memory
-(for a little while).  Plus you forgot to check C<$?> to see whether
-the program even ran correctly.  Even if you wrote
+(for a little while).  You forgot to check C<$?> to see whether
+the program even ran correctly, too.  Even if you wrote
 
     print `cat /etc/termcap`;
 
-In most cases, this could and probably should be written as
+this code could and probably should be written as
 
     system("cat /etc/termcap") == 0
        or die "cat program failed!";
 
-Which will get the output quickly (as it is generated, instead of only
+which will get the output quickly (as it is generated, instead of only
 at the end) and also check the return value.
 
 system() also provides direct control over whether shell wildcard
@@ -762,7 +766,7 @@ and fix it for you.
 
 =head2 Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)?
 
-Because some stdio's set error and eof flags that need clearing.  The
+Some stdio's set error and eof flags that need clearing.  The
 POSIX module defines clearerr() that you can use.  That is the
 technically correct way to do it.  Here are some less reliable
 workarounds:
@@ -855,9 +859,9 @@ state there, as in:
 
 =item Unix
 
-In the strictest sense, it can't be done -- the script executes as a
+In the strictest sense, it can't be done--the script executes as a
 different process from the shell it was started from.  Changes to a
-process are not reflected in its parent, only in its own children
+process are not reflected in its parent--only in any children
 created after the change.  There is shell magic that may allow you to
 fake it by eval()ing the script's output in your shell; check out the
 comp.unix.questions FAQ for details.  
@@ -867,7 +871,7 @@ comp.unix.questions FAQ for details.
 =head2 How do I close a process's filehandle without waiting for it to complete?
 
 Assuming your system supports such things, just send an appropriate signal
-to the process (see L<perlfunc/"kill">.  It's common to first send a TERM
+to the process (see L<perlfunc/"kill">).  It's common to first send a TERM
 signal, wait a little bit, and then send a KILL signal to finish it off.
 
 =head2 How do I fork a daemon process?
@@ -930,9 +934,9 @@ the current process group of your controlling terminal as follows:
 =head2 How do I timeout a slow event?
 
 Use the alarm() function, probably in conjunction with a signal
-handler, as documented in L<perlipc/"Signals"> and chapter 6 of the
-Camel.  You may instead use the more flexible Sys::AlarmCall module
-available from CPAN.
+handler, as documented in L<perlipc/"Signals"> and the section on
+``Signals'' in the Camel.  You may instead use the more flexible
+Sys::AlarmCall module available from CPAN.
 
 =head2 How do I set CPU limits?
 
@@ -971,9 +975,6 @@ sysopen():
     sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT, 0644)
         or die "can't open /tmp/somefile: $!":
 
-
-
-
 =head2 How do I install a module from CPAN?
 
 The easiest way is to have a module also named CPAN do it for you.
@@ -1010,26 +1011,27 @@ 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.
 
 See L<ExtUtils::MakeMaker> for more details on building extensions.
-See also the next question.
+See also the next question, ``What's the difference between require
+and use?''.
 
 =head2 What's the difference between require and use?
 
 Perl offers several different ways to include code from one file into
 another.  Here are the deltas between the various inclusion constructs:
 
-    1)  do $file is like eval `cat $file`, except the former:
+    1)  do $file is like eval `cat $file`, except the former
        1.1: searches @INC and updates %INC.
        1.2: bequeaths an *unrelated* lexical scope on the eval'ed code.
 
-    2)  require $file is like do $file, except the former:
+    2)  require $file is like do $file, except the former
        2.1: checks for redundant loading, skipping already loaded files.
        2.2: raises an exception on failure to find, compile, or execute $file.
 
-    3)  require Module is like require "Module.pm", except the former:
+    3)  require Module is like require "Module.pm", except the former
        3.1: translates each "::" into your system's directory separator.
        3.2: primes the parser to disambiguate class Module as an indirect object.
 
-    4)  use Module is like require Module, except the former:
+    4)  use Module is like require Module, except the former
        4.1: loads the module at compile time, not run-time.
        4.2: imports symbols and semantics from that package to the current one.
 
@@ -1047,7 +1049,7 @@ scripts that use the modules/libraries (see L<perlrun>) or say
 
     use lib '/u/mydir/perl';
 
-This is almost the same as:
+This is almost the same as
 
     BEGIN {
        unshift(@INC, '/u/mydir/perl');
index d1bd593..4c701ca 100644 (file)
@@ -7,7 +7,7 @@ perlfaq9 - Networking ($Revision: 1.26 $, $Date: 1999/05/23 16:08:30 $)
 This section deals with questions related to networking, the internet,
 and a few on the web.
 
-=head2 My CGI script runs from the command line but not the browser.   (500 Server Error)
+=head2 My CGI script runs from the command line but not the browser.  (500 Server Error)
 
 If you can demonstrate that you've read the following FAQs and that
 your problem isn't something simple that can be easily answered, you'll
@@ -84,8 +84,8 @@ attempts to do a little simple formatting of the resulting plain text.
 Many folks attempt a simple-minded regular expression approach, like
 C<< s/<.*?>//g >>, but that fails in many cases because the tags
 may continue over line breaks, they may contain quoted angle-brackets,
-or HTML comment may be present.  Plus folks forget to convert
-entities, like C<&lt;> for example.
+or HTML comment may be present.  Plus, folks forget to convert
+entities--like C<&lt;> for example.
 
 Here's one "simple-minded" approach, that works for most files:
 
@@ -224,13 +224,11 @@ available from CPAN.
 
 =head2 How do I redirect to another page?
 
-Instead of sending back a C<Content-Type> as the headers of your
-reply, send back a C<Location:> header.  Officially this should be a
-C<URI:> header, so the CGI.pm module (available from CPAN) sends back
-both:
+According to RFC 2616, "Hypertext Transfer Protocol -- HTTP/1.1", the
+preferred method is to send a C<Location:> header instead of a
+C<Content-Type:> header:
 
     Location: http://www.domain.com/newpage
-    URI: http://www.domain.com/newpage
 
 Note that relative URLs in these headers can cause strange effects
 because of "optimizations" that servers do.
@@ -248,12 +246,12 @@ in the header.
 
     EOF
 
-To be correct to the spec, each of those virtual newlines should really be
-physical C<"\015\012"> sequences by the time you hit the client browser.
-Except for NPH scripts, though, that local newline should get translated
-by your server into standard form, so you shouldn't have a problem
-here, even if you are stuck on MacOS.  Everybody else probably won't
-even notice.
+To be correct to the spec, each of those virtual newlines should
+really be physical C<"\015\012"> sequences by the time your message is
+received by the client browser.  Except for NPH scripts, though, that
+local newline should get translated by your server into standard form,
+so you shouldn't have a problem here, even if you are stuck on MacOS.
+Everybody else probably won't even notice.
 
 =head2 How do I put a password on my web pages?
 
@@ -276,9 +274,9 @@ DBI compatible driver.  HTTPD::UserAdmin supports files used by the
 =head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
 
 Read the CGI security FAQ, at
-http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html, and the
+http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html , and the
 Perl/CGI FAQ at
-http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html.
+http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html .
 
 In brief: use tainting (see L<perlsec>), which makes sure that data
 from outside your script (eg, CGI parameters) are never used in
@@ -289,7 +287,7 @@ command and arguments as a list, which prevents shell globbing.
 =head2 How do I parse a mail header?
 
 For a quick-and-dirty solution, try this solution derived
-from page 222 of the 2nd edition of "Programming Perl":
+from L<perlfunc/split>:
 
     $/ = '';
     $header = <MSG>;
@@ -397,7 +395,7 @@ format after minor transliterations:
 
 =head2 How do I return the user's mail address?
 
-On systems that support getpwuid, the $< variable and the
+On systems that support getpwuid, the $< variable, and the
 Sys::Hostname module (which is part of the standard perl distribution),
 you can probably try using something like this:
 
@@ -465,7 +463,7 @@ include queueing, MX records, and security.
 
 While you could use the Mail::Folder module from CPAN (part of the
 MailFolder package) or the Mail::Internet module from CPAN (also part
-of the MailTools package), often a module is overkill, though.  Here's a
+of the MailTools package), often a module is overkill.  Here's a
 mail sorter.
 
     #!/usr/bin/perl
@@ -520,7 +518,7 @@ systems.)
 =head2 How do I fetch a news article or the active newsgroups?
 
 Use the Net::NNTP or News::NNTPClient modules, both available from CPAN.
-This can make tasks like fetching the newsgroup list as simple as:
+This can make tasks like fetching the newsgroup list as simple as
 
     perl -MNews::NNTPClient
       -e 'print News::NNTPClient->new->list("newsgroups")'
@@ -532,7 +530,7 @@ available from CPAN) is more complex but can put as well as fetch.
 
 =head2 How can I do RPC in Perl?
 
-A DCE::RPC module is being developed (but is not yet available), and
+A DCE::RPC module is being developed (but is not yet available) and
 will be released as part of the DCE-Perl package (available from
 CPAN).  The rpcgen suite, available from CPAN/authors/id/JAKE/, is
 an RPC stub generator and includes an RPC::ONC module.
index c3c8315..4327809 100644 (file)
@@ -2,7 +2,6 @@
 
 perlfilter - Source Filters
 
-
 =head1 DESCRIPTION
 
 This article is about a little-known feature of Perl called
index db90b86..82086e3 100644 (file)
@@ -91,7 +91,7 @@ functions, like some keywords and named operators)
 arranged by category.  Some functions appear in more
 than one place.
 
-=over
+=over 4
 
 =item Functions for SCALARs or strings
 
@@ -274,8 +274,8 @@ X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C>
     -O File is owned by real uid.
 
     -e File exists.
-    -z File has zero size.
-    -s File has nonzero size (returns size).
+    -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.
@@ -923,7 +923,10 @@ element to return happens to be C<undef>.
 
 You may also use C<defined(&func)> to check whether subroutine C<&func>
 has ever been defined.  The return value is unaffected by any forward
-declarations of C<&foo>.
+declarations of C<&foo>.  Note that a subroutine which is not defined
+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>.
 
 Use of C<defined> on aggregates (hashes and arrays) is deprecated.  It
 used to report whether memory for that aggregate has ever been
@@ -1193,7 +1196,7 @@ make your program I<appear> to run faster.
 
 When called in list context, returns a 2-element list consisting of the
 key and value for the next element of a hash, so that you can iterate over
-it.  When called in scalar context, returns the key for only the "next"
+it.  When called in scalar context, returns only the key for the next
 element in the hash.
 
 Entries are returned in an apparently random order.  The actual random
@@ -1208,7 +1211,14 @@ again.  There is a single iterator for each hash, shared by all C<each>,
 C<keys>, and C<values> function calls in the program; it can be reset by
 reading all the elements from the hash, or by evaluating C<keys HASH> or
 C<values HASH>.  If you add or delete elements of a hash while you're
-iterating over it, you may get entries skipped or duplicated, so don't.
+iterating over it, you may get entries skipped or duplicated, so
+don't.  Exception: It is always safe to delete the item most recently
+returned by C<each()>, which means that the following code will work:
+
+        while (($key, $value) = each %hash) {
+          print $key, "\n";
+          delete $hash{$key};   # This is safe
+        }
 
 The following prints out your environment like the printenv(1) program,
 only in a different order:
@@ -1472,7 +1482,10 @@ it exists, but the reverse doesn't necessarily hold true.
 Given an expression that specifies the name of a subroutine,
 returns true if the specified subroutine has ever been declared, even
 if it is undefined.  Mentioning a subroutine name for exists or defined
-does not count as declaring it.
+does not count as declaring it.  Note that a subroutine which does not
+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;
@@ -2341,8 +2354,8 @@ it succeeded, false otherwise.  See the example in L<perlipc/"Sockets: Client/Se
 =item local EXPR
 
 You really probably want to be using C<my> instead, because C<local> isn't
-what most people think of as "local".  See L<perlsub/"Private Variables
-via my()"> for details.
+what most people think of as "local".  See 
+L<perlsub/"Private Variables via my()"> for details.
 
 A local modifies the listed variables to be local to the enclosing
 block, file, or eval.  If more than one value is listed, the list must
@@ -2476,6 +2489,29 @@ Using a regular C<foreach> loop for this purpose would be clearer in
 most cases.  See also L</grep> for an array composed of those items of
 the original list for which the BLOCK or EXPR evaluates to true.
 
+C<{> starts both hash references and blocks, so C<map { ...> could be either
+the start of map BLOCK LIST or map EXPR, LIST. Because perl doesn't look
+ahead for the closing C<}> it has to take a guess at which its dealing with
+based what it finds just after the C<{>. Usually it gets it right, but if it
+doesn't it won't realize something is wrong until it gets to the C<}> and
+encounters the missing (or unexpected) comma. The syntax error will be
+reported close to the C<}> but you'll need to change something near the C<{>
+such as using a unary C<+> to give perl some help:
+
+    %hash = map {  "\L$_", 1  } @array  # perl guesses EXPR.  wrong
+    %hash = map { +"\L$_", 1  } @array  # perl guesses BLOCK. right
+    %hash = map { ("\L$_", 1) } @array  # this also works
+    %hash = map {  lc($_), 1  } @array  # as does this.
+    %hash = map +( lc($_), 1 ), @array  # this is EXPR and works!
+      
+    %hash = map  ( lc($_), 1 ), @array  # evaluates to (1, @array)
+
+or to force an anon hash constructor use C<+{>
+
+   @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end
+
+and you get list of anonymous hashes each with only 1 entry.
+
 =item mkdir FILENAME,MASK
 
 =item mkdir FILENAME
@@ -2846,7 +2882,7 @@ another way to protect your filenames from interpretation.  For example:
     sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL)
        or die "sysopen $path: $!";
     $oldfh = select(HANDLE); $| = 1; select($oldfh);
-    print HANDLE "stuff $$\n");
+    print HANDLE "stuff $$\n";
     seek(HANDLE, 0, 0);
     print "File contains: ", <HANDLE>;
 
@@ -3470,12 +3506,13 @@ with the wrong number of RANDBITS.)
 =item read FILEHANDLE,SCALAR,LENGTH
 
 Attempts to read LENGTH bytes of data into variable SCALAR from the
-specified FILEHANDLE.  Returns the number of bytes actually read,
-C<0> at end of file, or undef if there was an error.  SCALAR will be grown
-or shrunk to the length actually read.  An OFFSET may be specified to
-place the read data at some other place than the beginning of the
-string.  This call is actually implemented in terms of stdio's fread(3)
-call.  To get a true read(2) system call, see C<sysread>.
+specified FILEHANDLE.  Returns the number of bytes actually read, C<0>
+at end of file, or undef if there was an error.  SCALAR will be grown
+or shrunk to the length actually read.  If SCALAR needs growing, the
+new bytes will be zero bytes.  An OFFSET may be specified to place
+the read data into some other place in SCALAR than the beginning.
+The call is actually implemented in terms of stdio's fread(3) call.
+To get a true read(2) system call, see C<sysread>.
 
 =item readdir DIRHANDLE
 
@@ -4258,9 +4295,9 @@ Examples:
 If you're using strict, you I<must not> declare $a
 and $b as lexicals.  They are package globals.  That means
 if you're in the C<main> package and type
-  
+
     @articles = sort {$b <=> $a} @files;
-  
+
 then C<$a> and C<$b> are C<$main::a> and C<$main::b> (or C<$::a> and C<$::b>),
 but if you're in the C<FooPack> package, it's the same as typing
 
@@ -4345,6 +4382,15 @@ characters at each point it matches that way.  For example:
 
 produces the output 'h:i:t:h:e:r:e'.
 
+Empty leading (or trailing) fields are produced when there positive width
+matches at the beginning (or end) of the string; a zero-width match at the
+beginning (or end) of the string does not produce an empty field.  For
+example:
+
+   print join(':', split(/(?=\w)/, 'hi there!'));
+
+produces the output 'h:i :t:h:e:r:e!'.
+
 The LIMIT parameter can be used to split a line partially
 
     ($login, $passwd, $remainder) = split(/:/, $_, 3);
@@ -4478,13 +4524,31 @@ and the conversion letter:
    h       interpret integer as C type "short" or "unsigned short"
            If no flags, interpret integer as C type "int" or "unsigned"
 
+Perl supports parameter ordering, in other words, fetching the
+parameters in some explicitly specified "random" ordering as opposed
+to the default implicit sequential ordering.  The syntax is, instead
+of the C<%> and C<*>, to use C<%>I<digits>C<$> and C<*>I<digits>C<$>,
+where the I<digits> is the wanted index, from one upwards.  For example:
+
+   printf "%2\$d %1\$d\n", 12, 34;             # will print "34 12\n"
+   printf "%*2\$d\n",      12, 3;              # will print " 12\n"
+
+Note that using the reordering syntax does not interfere with the usual
+implicit sequential fetching of the parameters:
+
+   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 "%*3\$2\$d %d\n", 12, 34, 3;         # will print " 34 12\n"
+
 There are also two Perl-specific flags:
 
-   V       interpret integer as Perl's standard integer type
-   v       interpret string as a vector of integers, output as
-           numbers separated either by dots, or by an arbitrary
-          string received from the argument list when the flag
-          is preceded by C<*>
+    V       interpret integer as Perl's standard integer type
+    v       interpret string as a vector of integers, output as
+            numbers separated either by dots, or by an arbitrary
+           string received from the argument list when the flag
+           is preceded by C<*>
 
 Where a number would appear in the flags, an asterisk (C<*>) may be
 used instead, in which case Perl uses the next item in the parameter
@@ -5043,9 +5107,13 @@ case the SCALAR is empty you can use OFFSET but only zero offset.
 
 =item tell
 
-Returns the current position for FILEHANDLE.  FILEHANDLE may be an
-expression whose value gives the name of the actual filehandle.  If
-FILEHANDLE is omitted, assumes the file last read.  
+Returns the current position for FILEHANDLE, or -1 on error.  FILEHANDLE
+may be an expression whose value gives the name of the actual filehandle.
+If FILEHANDLE is omitted, assumes the file last read.  
+
+The return value of tell() for the standard streams like the STDIN
+depends on the operating system: it may return -1 or something else.
+tell() on pipes, fifos, and sockets usually returns -1.
 
 There is no C<systell> function.  Use C<sysseek(FH, 0, 1)> for that.
 
index 4d62774..f38bba3 100644 (file)
@@ -76,6 +76,10 @@ L<perlsec>).  This pointer may be NULL if that information is not
 important.  Note that this function requires you to specify the length of
 the format.
 
+STRLEN is an integer type (Size_t, usually defined as size_t in
+config.h) guaranteed to be large enough to represent the size of 
+any string that perl can handle.
+
 The C<sv_set*()> functions are not generic enough to operate on values
 that have "magic".  See L<Magic Virtual Tables> later in this document.
 
@@ -1088,7 +1092,7 @@ an C<ENTER>/C<LEAVE> pair.
 
 Inside such a I<pseudo-block> the following service is available:
 
-=over
+=over 4
 
 =item C<SAVEINT(int i)>
 
@@ -1161,7 +1165,7 @@ provide pointers to the modifiable data explicitly (either C pointers,
 or Perlish C<GV *>s).  Where the above macros take C<int>, a similar 
 function takes C<int *>.
 
-=over
+=over 4
 
 =item C<SV* save_scalar(GV *gv)>
 
@@ -1511,6 +1515,31 @@ The execution order is indicated by C<===E<gt>> marks, thus it is C<3
 4 5 6> (node C<6> is not included into above listing), i.e.,
 C<gvsv gvsv add whatever>.
 
+Each of these nodes represents an op, a fundamental operation inside the
+Perl core. The code which implements each operation can be found in the
+F<pp*.c> files; the function which implements the op with type C<gvsv>
+is C<pp_gvsv>, and so on. As the tree above shows, different ops have
+different numbers of children: C<add> is a binary operator, as one would
+expect, and so has two children. To accommodate the various different
+numbers of children, there are various types of op data structure, and
+they link together in different ways.
+
+The simplest type of op structure is C<OP>: this has no children. Unary
+operators, C<UNOP>s, have one child, and this is pointed to by the
+C<op_first> field. Binary operators (C<BINOP>s) have not only an
+C<op_first> field but also an C<op_last> field. The most complex type of
+op is a C<LISTOP>, which has any number of children. In this case, the
+first child is pointed to by C<op_first> and the last child by
+C<op_last>. The children in between can be found by iteratively
+following the C<op_sibling> pointer from the first child to the last.
+
+There are also two other op types: a C<PMOP> holds a regular expression,
+and has no children, and a C<LOOP> may or may not have children. If the
+C<op_children> field is non-zero, it behaves like a C<LISTOP>. To
+complicate matters, if a C<UNOP> is actually a C<null> op after
+optimization (see L</Compile pass 2: context propagation>) it will still
+have children in accordance with its former type.
+
 =head2 Compile pass 1: check routines
 
 The tree is created by the compiler while I<yacc> code feeds it
@@ -1571,6 +1600,41 @@ additional complications for conditionals).  These optimizations are
 done in the subroutine peep().  Optimizations performed at this stage
 are subject to the same restrictions as in the pass 2.
 
+=head1 Examining internal data structures with the C<dump> functions
+
+To aid debugging, the source file F<dump.c> contains a number of
+functions which produce formatted output of internal data structures.
+
+The most commonly used of these functions is C<Perl_sv_dump>; it's used
+for dumping SVs, AVs, HVs, and CVs. The C<Devel::Peek> module calls
+C<sv_dump> to produce debugging output from Perl-space, so users of that
+module should already be familiar with its format. 
+
+C<Perl_op_dump> can be used to dump an C<OP> structure or any of its
+derivatives, and produces output similiar to C<perl -Dx>; in fact,
+C<Perl_dump_eval> will dump the main root of the code being evaluated,
+exactly like C<-Dx>.
+
+Other useful functions are C<Perl_dump_sub>, which turns a C<GV> into an
+op tree, C<Perl_dump_packsubs> which calls C<Perl_dump_sub> on all the
+subroutines in a package like so: (Thankfully, these are all xsubs, so
+there is no op tree)
+
+    (gdb) print Perl_dump_packsubs(PL_defstash)
+
+    SUB attributes::bootstrap = (xsub 0x811fedc 0)
+
+    SUB UNIVERSAL::can = (xsub 0x811f50c 0)
+
+    SUB UNIVERSAL::isa = (xsub 0x811f304 0)
+
+    SUB UNIVERSAL::VERSION = (xsub 0x811f7ac 0)
+
+    SUB DynaLoader::boot_DynaLoader = (xsub 0x805b188 0)
+
+and C<Perl_dump_all>, which dumps all the subroutines in the stash and
+the op tree of the main root.
+
 =head1 How multiple interpreters and concurrency are supported
 
 =head2 Background and PERL_IMPLICIT_CONTEXT
index 3abc1f7..155773d 100644 (file)
@@ -194,6 +194,8 @@ around.  It refers to the standard distribution.  ``Hacking on the
 core'' means you're changing the C source code to the Perl
 interpreter.  ``A core module'' is one that ships with Perl.
 
+=head2 Keeping in sync
+
 The source code to the Perl interpreter, in its different versions, is
 kept in a repository managed by a revision control system (which is
 currently the Perforce program, see http://perforce.com/).  The
@@ -206,20 +208,267 @@ public release are available at this location:
 
     ftp://ftp.linux.activestate.com/pub/staff/gsar/APC/
 
-Selective parts are also visible via the rsync protocol.  To get all
-the individual changes to the mainline since the last development
-release, use the following command:
-
-    rsync -avz rsync://ftp.linux.activestate.com/perl-diffs perl-diffs
-
-Use this to get the latest source tree in full:
-
-    rsync -avz rsync://ftp.linux.activestate.com/perl-current perl-current
+If you are a member of the perl5-porters mailing list, it is a good
+thing to keep in touch with the most recent changes. If not only to
+verify if what you would have posted as a bug report isn't already
+solved in the most recent available perl development branch, also
+known as perl-current, bleading edge perl, bleedperl or bleadperl.
 
 Needless to say, the source code in perl-current is usually in a perpetual
 state of evolution.  You should expect it to be very buggy.  Do B<not> use
 it for any purpose other than testing and development.
 
+Keeping in sync with the most recent branch can be done in several ways,
+but the most convenient and reliable way is using B<rsync>, available at
+ftp://rsync.samba.org/pub/rsync/ .  (You can also get the most recent
+branch by FTP.)
+
+If you choose to keep in sync using rsync, there are two approaches
+to doing so:
+
+=over 4
+
+=item rsync'ing the source tree
+
+Presuming you are in the directory where your perl source resides
+and you have rsync installed and available, you can `upgrade' to
+the bleadperl using:
+
+ # rsync -avz rsync://ftp.linux.activestate.com/perl-current/ .
+
+This takes care of updating every single item in the source tree to
+the latest applied patch level, creating files that are new (to your
+distribution) and setting date/time stamps of existing files to
+reflect the bleadperl status.
+
+Note that this will not delete any files that were in '.' before
+the rsync. Once you are sure that the rsync is running correctly,
+run it with the --delete and the --dry-run options like this:
+
+ # rsync -avz --delete --dry-run rsync://ftp.linux.activestate.com/perl-current/ .
+
+This will I<simulate> an rsync run that also deletes files not
+present in the bleadperl master copy. Observe the results from
+this run closely. If you are sure that the actual run would delete
+no files precious to you, you could remove the '--dry-run' option.
+
+You can than check what patch was the latest that was applied by
+looking in the file B<.patch>, which will show the number of the
+latest patch.
+
+If you have more than one machine to keep in sync, and not all of
+them have access to the WAN (so you are not able to rsync all the
+source trees to the real source), there are some ways to get around
+this problem.
+
+=over 4
+
+=item Using rsync over the LAN
+
+Set up a local rsync server which makes the rsynced source tree
+available to the LAN and sync the other machines against this
+directory.
+
+From http://rsync.samba.org/README.html:
+
+   "Rsync uses rsh or ssh for communication. It does not need to be
+    setuid and requires no special privileges for installation.  It
+    does not require a inetd entry or a deamon.  You must, however,
+    have a working rsh or ssh system.  Using ssh is recommended for
+    its security features."
+
+=item Using pushing over the NFS
+
+Having the other systems mounted over the NFS, you can take an
+active pushing approach by checking the just updated tree against
+the other not-yet synced trees. An example would be
+
+  #!/usr/bin/perl -w
+
+  use strict;
+  use File::Copy;
+
+  my %MF = map {
+      m/(\S+)/;
+      $1 => [ (stat $1)[2, 7, 9] ];    # mode, size, mtime
+      } `cat MANIFEST`;
+
+  my %remote = map { $_ => "/$_/pro/3gl/CPAN/perl-5.7.1" } qw(host1 host2);
+
+  foreach my $host (keys %remote) {
+      unless (-d $remote{$host}) {
+         print STDERR "Cannot Xsync for host $host\n";
+         next;
+         }
+      foreach my $file (keys %MF) {
+         my $rfile = "$remote{$host}/$file";
+         my ($mode, $size, $mtime) = (stat $rfile)[2, 7, 9];
+         defined $size or ($mode, $size, $mtime) = (0, 0, 0);
+         $size == $MF{$file}[1] && $mtime == $MF{$file}[2] and next;
+         printf "%4s %-34s %8d %9d  %8d %9d\n",
+             $host, $file, $MF{$file}[1], $MF{$file}[2], $size, $mtime;
+         unlink $rfile;
+         copy ($file, $rfile);
+         utime time, $MF{$file}[2], $rfile;
+         chmod $MF{$file}[0], $rfile;
+         }
+      }
+
+though this is not perfect. It could be improved with checking
+file checksums before updating. Not all NFS systems support
+reliable utime support (when used over the NFS).
+
+=back
+
+=item rsync'ing the patches
+
+The source tree is maintained by the pumpking who applies patches to
+the files in the tree. These patches are either created by the
+pumpking himself using C<diff -c> after updating the file manually or
+by applying patches sent in by posters on the perl5-porters list.
+These patches are also saved and rsync'able, so you can apply them
+yourself to the source files.
+
+Presuming you are in a directory where your patches reside, you can
+get them in sync with
+
+ # rsync -avz rsync://ftp.linux.activestate.com/perl-current-diffs/ .
+
+This makes sure the latest available patch is downloaded to your
+patch directory.
+
+It's then up to you to apply these patches, using something like
+
+ # last=`ls -rt1 *.gz | tail -1`
+ # rsync -avz rsync://ftp.linux.activestate.com/perl-current-diffs/ .
+ # find . -name '*.gz' -newer $last -exec gzcat {} \; >blead.patch
+ # cd ../perl-current
+ # patch -p1 -N <../perl-current-diffs/blead.patch
+
+or, since this is only a hint towards how it works, use CPAN-patchaperl
+from Andreas König to have better control over the patching process.
+
+=back
+
+=head3 Why rsync the source tree
+
+=over 4
+
+=item It's easier
+
+Since you don't have to apply the patches yourself, you are sure all
+files in the source tree are in the right state.
+
+=item It's more recent
+
+According to Gurusamy Sarathy:
+
+   "... The rsync mirror is automatic and syncs with the repository
+    every five minutes.
+
+   "Updating the patch  area  still  requires  manual  intervention
+    (with all the goofiness that implies,  which you've noted)  and
+    is typically on a daily cycle.   Making this process  automatic
+    is on my tuit list, but don't ask me when."
+
+=item It's more reliable
+
+Well, since the patches are updated by hand, I don't have to say any
+more ... (see Sarathy's remark).
+
+=back
+
+=head3 Why rsync the patches
+
+=over 4
+
+=item It's easier
+
+If you have more than one machine that you want to keep in track with
+bleadperl, it's easier to rsync the patches only once and then apply
+them to all the source trees on the different machines.
+
+In case you try to keep in pace on 5 different machines, for which
+only one of them has access to the WAN, rsync'ing all the source
+trees should than be done 5 times over the NFS. Having
+rsync'ed the patches only once, I can apply them to all the source
+trees automatically. Need you say more ;-)
+
+=item It's a good reference
+
+If you do not only like to have the most recent development branch,
+but also like to B<fix> bugs, or extend features, you want to dive
+into the sources. If you are a seasoned perl core diver, you don't
+need no manuals, tips, roadmaps, perlguts.pod or other aids to find
+your way around. But if you are a starter, the patches may help you
+in finding where you should start and how to change the bits that
+bug you.
+
+The file B<Changes> is updated on occasions the pumpking sees as his
+own little sync points. On those occasions, he releases a tar-ball of
+the current source tree (i.e. perl@7582.tar.gz), which will be an
+excellent point to start with when choosing to use the 'rsync the
+patches' scheme. Starting with perl@7582, which means a set of source
+files on which the latest applied patch is number 7582, you apply all
+succeeding patches available from than on (7583, 7584, ...).
+
+You can use the patches later as a kind of search archive.
+
+=over 4
+
+=item Finding a start point
+
+If you want to fix/change the behaviour of function/feature Foo, just
+scan the patches for patches that mention Foo either in the subject,
+the comments, or the body of the fix. A good chance the patch shows
+you the files that are affected by that patch which are very likely
+to be the starting point of your journey into the guts of perl.
+
+=item Finding how to fix a bug
+
+If you've found I<where> the function/feature Foo misbehaves, but you
+don't know how to fix it (but you do know the change you want to
+make), you can, again, peruse the patches for similar changes and
+look how others apply the fix.
+
+=item Finding the source of misbehaviour
+
+When you keep in sync with bleadperl, the pumpking would love to
+I<see> that the community efforts realy work. So after each of his
+sync points, you are to 'make test' to check if everything is still
+in working order. If it is, you do 'make ok', which will send an OK
+report to perlbug@perl.org. (If you do not have access to a mailer
+from the system you just finished successfully 'make test', you can
+do 'make okfile', which creates the file C<perl.ok>, which you can
+than take to your favourite mailer and mail yourself).
+
+But of course, as always, things will not allways lead to a success
+path, and one or more test do not pass the 'make test'. Before
+sending in a bug report (using 'make nok' or 'make nokfile'), check
+the mailing list if someone else has reported the bug already and if
+so, confirm it by replying to that message. If not, you might want to
+trace the source of that misbehaviour B<before> sending in the bug,
+which will help all the other porters in finding the solution.
+
+Here the saved patches come in very handy. You can check the list of
+patches to see which patch changed what file and what change caused
+the misbehaviour. If you note that in the bug report, it saves the
+one trying to solve it, looking for that point.
+
+=back
+
+If searching the patches is too bothersome, you might consider using
+perl's bugtron to find more information about discussions and
+ramblings on posted bugs.
+
+=back
+
+If you want to get the best of both worlds, rsync both the source
+tree for convenience, reliability and ease and rsync the patches
+for reference.
+
+=head2 Submitting patches
+
 Always submit patches to I<perl5-porters@perl.org>.  This lets other
 porters review your patch, which catches a surprising number of errors
 in patches.  Either use the diff program (available in source code
@@ -827,7 +1076,7 @@ the tied C<push> is implemented; see C<av_push> in F<av.c>:
      7 call_method("PUSH", G_SCALAR|G_DISCARD);
      8 LEAVE;
      9 POPSTACK;
-       
+
 The lines which concern the mark stack are the first, fifth and last
 lines: they save away, restore and remove the current position of the
 argument stack. 
@@ -950,7 +1199,7 @@ useful options are probably
 
 Some of the functionality of the debugging code can be achieved using XS
 modules.
-    
+
     -Dr => use re 'debug'
     -Dx => use O 'Debug'
 
@@ -1012,7 +1261,7 @@ Run until the next breakpoint.
 
 Run until the end of the current function, then stop again.
 
-=item
+=item 'enter'
 
 Just pressing Enter will do the most recent operation again - it's a
 blessing when stepping through miles of source code.
@@ -1256,7 +1505,7 @@ this text in the description of C<pack>:
 All done. Now let's create the patch. F<Porting/patching.pod> tells us
 that if we're making major changes, we should copy the entire directory
 to somewhere safe before we begin fiddling, and then do
-    
+
     diff -ruN old new > patch
 
 However, we know which files we've changed, and we can simply do this:
@@ -1454,6 +1703,12 @@ working on and the changes they're making.
 
 =item *
 
+Do read the README associated with your operating system, e.g. README.aix
+on the IBM AIX OS. Don't hesitate to supply patches to that README if
+you find anything missing or changed over a new OS release.
+
+=item *
+
 Find an area of Perl that seems interesting to you, and see if you can
 work out how it works. Scan through the source, and step over it in the
 debugger. Play, poke, investigate, fiddle! You'll probably get to
index 2aa928c..f5a9602 100644 (file)
@@ -1,5 +1,3 @@
-=pod
-
 =head1 NAME
 
 perlhist - the Perl history records
index 11d9385..b63b694 100644 (file)
@@ -12,6 +12,18 @@ B<they are not for use in extensions>!
 
 =over 8
 
+=item djSP
+
+Declare Just C<SP>. This is actually identical to C<dSP>, and declares
+a local copy of perl's stack pointer, available via the C<SP> macro.
+See C<SP>.  (Available for backward source code compatibility with the
+old (Perl 5.005) thread model.)
+
+               djSP;
+
+=for hackers
+Found in file pp.h
+
 =item is_gv_magical
 
 Returns C<TRUE> if given the name of a magical GV.
@@ -27,6 +39,18 @@ allow selecting particular classes of magical variable.
 =for hackers
 Found in file gv.c
 
+=item start_glob
+
+Function called by C<do_readline> to spawn a glob (or do the glob inside
+perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
+this glob starter is only used by miniperl during the build proccess.
+Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
+
+       PerlIO* start_glob(SV* pattern, IO *io)
+
+=for hackers
+Found in file doio.c
+
 =back
 
 =head1 AUTHORS
index 94b6bde..a1df3e4 100644 (file)
@@ -660,14 +660,14 @@ instead.
     BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
     use Socket;
     use Carp;
-    $EOL = "\015\012";
+    my $EOL = "\015\012";
 
     sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
 
     my $port = shift || 2345;
     my $proto = getprotobyname('tcp');
 
-    ($port) = $port =~ /^(\d+)$/                        || die "invalid port";
+    ($port) = $port =~ /^(\d+)$/                        or die "invalid port";
 
     socket(Server, PF_INET, SOCK_STREAM, $proto)       || die "socket: $!";
     setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
@@ -703,7 +703,7 @@ go back to service a new client.
     BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
     use Socket;
     use Carp;
-    $EOL = "\015\012";
+    my $EOL = "\015\012";
 
     sub spawn;  # forward declaration
     sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
@@ -711,7 +711,7 @@ go back to service a new client.
     my $port = shift || 2345;
     my $proto = getprotobyname('tcp');
 
-    ($port) = $port =~ /^(\d+)$/                        || die "invalid port";
+    ($port) = $port =~ /^(\d+)$/                        or die "invalid port";
 
     socket(Server, PF_INET, SOCK_STREAM, $proto)       || die "socket: $!";
     setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
@@ -865,6 +865,7 @@ to be on the localhost, and thus everything works right.
     use Carp;
 
     BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
+    sub spawn;  # forward declaration
     sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
 
     my $NAME = '/tmp/catsock';
@@ -901,6 +902,29 @@ to be on the localhost, and thus everything works right.
        };
     }
 
+    sub spawn {
+       my $coderef = shift;
+
+       unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
+           confess "usage: spawn CODEREF";
+       }
+
+       my $pid;
+       if (!defined($pid = fork)) {
+           logmsg "cannot fork: $!";
+           return;
+       } elsif ($pid) {
+           logmsg "begat $pid";
+           return; # I'm the parent
+       }
+       # else I'm the child -- go spawn
+
+       open(STDIN,  "<&Client")   || die "can't dup client to stdin";
+       open(STDOUT, ">&Client")   || die "can't dup client to stdout";
+       ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
+       exit &$coderef();
+    }
+
 As you see, it's remarkably similar to the Internet domain TCP server, so
 much so, in fact, that we've omitted several duplicate functions--spawn(),
 logmsg(), ctime(), and REAPER()--which are exactly the same as in the
@@ -952,7 +976,7 @@ looks like this:
 
 Here are what those parameters to the C<new> constructor mean:
 
-=over
+=over 4
 
 =item C<Proto>
 
@@ -1147,7 +1171,7 @@ does nothing but listen on a particular port for incoming connections.
 It does this by calling the C<< IO::Socket::INET->new() >> method with
 slightly different arguments than the client did.
 
-=over
+=over 4
 
 =item Proto
 
index 3dd3ba9..b98e333 100644 (file)
@@ -468,7 +468,7 @@ Consider this example:
         bless [], $class ;
     }
 
-   
+
     1 ;
 
 The code below makes use of both modules, but it only enables warnings from 
index 3d9a58a..d37664c 100644 (file)
@@ -124,8 +124,8 @@ B<The POSIX date formatting function> (strftime()) uses C<LC_TIME>.
 
 =back
 
-C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in L<LOCALE
-CATEGORIES>.
+C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in 
+L<LOCALE CATEGORIES>.
 
 The default behavior is restored with the S<C<no locale>> pragma, or
 upon reaching the end of block enclosing C<use locale>.
@@ -348,8 +348,8 @@ commands.  You may see things like "en_US.ISO8859-1", but that isn't
 the same.  In this case, try running under a locale
 that you can list and which somehow matches what you tried.  The
 rules for matching locale names are a bit vague because
-standardization is weak in this area.  See again the L<Finding
-locales> about general rules.
+standardization is weak in this area.  See again the 
+L<Finding locales> about general rules.
 
 =head2 Fixing system locale configuration
 
@@ -445,7 +445,7 @@ The following collations all make sense and you may meet any of them
 if you "use locale".
 
        A B C D E a b c d e
-       A a B b C c D d D e
+       A a B b C c D d E e
        a A b B c C d D e E
        a b c d e A B C D E
 
@@ -453,13 +453,13 @@ Here is a code snippet to tell what "word"
 characters are in the current locale, in that locale's order:
 
         use locale;
-        print +(sort grep /\w/, map { chr() } 0..255), "\n";
+        print +(sort grep /\w/, map { chr } 0..255), "\n";
 
 Compare this with the characters that you see and their order if you
 state explicitly that the locale should be ignored:
 
         no locale;
-        print +(sort grep /\w/, map { chr() } 0..255), "\n";
+        print +(sort grep /\w/, map { chr } 0..255), "\n";
 
 This machine-native collation (which is what you get unless S<C<use
 locale>> has appeared earlier in the same block) must be used for
@@ -554,20 +554,20 @@ change the character used for the decimal point--perhaps from '.'  to ','.
 These functions aren't aware of such niceties as thousands separation and
 so on.  (See L<The localeconv function> if you care about these things.)
 
-Output produced by print() is B<never> affected by the
-current locale: it is independent of whether C<use locale> or C<no
-locale> is in effect, and corresponds to what you'd get from printf()
-in the "C" locale.  The same is true for Perl's internal conversions
-between numeric and string formats:
+Output produced by print() is also affected by the current locale: it
+depends on whether C<use locale> or C<no locale> is in effect, and
+corresponds to what you'd get from printf() in the "C" locale.  The
+same is true for Perl's internal conversions between numeric and
+string formats:
 
         use POSIX qw(strtod);
         use locale;
 
         $n = 5/2;   # Assign numeric 2.5 to $n
 
-        $a = " $n"; # Locale-independent conversion to string
+        $a = " $n"; # Locale-dependent conversion to string
 
-        print "half five is $n\n";       # Locale-independent output
+        print "half five is $n\n";       # Locale-dependent output
 
         printf "half five is %g\n", $n;  # Locale-dependent output
 
@@ -580,11 +580,12 @@ The C standard defines the C<LC_MONETARY> category, but no function
 that is affected by its contents.  (Those with experience of standards
 committees will recognize that the working group decided to punt on the
 issue.)  Consequently, Perl takes no notice of it.  If you really want
-to use C<LC_MONETARY>, you can query its contents--see L<The localeconv
-function>--and use the information that it returns in your application's
-own formatting of currency amounts.  However, you may well find that
-the information, voluminous and complex though it may be, still does not
-quite meet your requirements: currency formatting is a hard nut to crack.
+to use C<LC_MONETARY>, you can query its contents--see 
+L<The localeconv function>--and use the information that it returns in your 
+application's own formatting of currency amounts.  However, you may well 
+find that the information, voluminous and complex though it may be, still 
+does not quite meet your requirements: currency formatting is a hard nut 
+to crack.
 
 =head2 LC_TIME
 
@@ -642,15 +643,6 @@ case-mapping table is in effect.
 
 =item *
 
-Some systems are broken in that they allow the "C" locale to be
-overridden by users.  If the decimal point character in the
-C<LC_NUMERIC> category of the "C" locale is surreptitiously changed
-from a dot to a comma, C<sprintf("%g", 0.123456e3)> produces a
-string result of "123,456".  Many people would interpret this as
-one hundred and twenty-three thousand, four hundred and fifty-six.
-
-=item *
-
 A sneaky C<LC_COLLATE> locale could result in the names of students with
 "D" grades appearing ahead of those with "A"s.
 
@@ -686,16 +678,22 @@ the locale:
 
 =over 4
 
-=item B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):
+=item  *
+
+B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):
 
 Scalar true/false (or less/equal/greater) result is never tainted.
 
-=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>)
+=item  *
+
+B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>)
 
 Result string containing interpolated material is tainted if
 C<use locale> is in effect.
 
-=item B<Matching operator> (C<m//>):
+=item  *
+
+B<Matching operator> (C<m//>):
 
 Scalar true/false result never tainted.
 
@@ -708,7 +706,9 @@ expression contains C<\w> (to match an alphanumeric character), C<\W>
 C<use locale> is in effect and the regular expression contains C<\w>,
 C<\W>, C<\s>, or C<\S>.
 
-=item B<Substitution operator> (C<s///>):
+=item  *
+
+B<Substitution operator> (C<s///>):
 
 Has the same behavior as the match operator.  Also, the left
 operand of C<=~> becomes tainted when C<use locale> in effect
@@ -716,20 +716,30 @@ if modified as a result of a substitution based on a regular
 expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of
 case-mapping with C<\l>, C<\L>,C<\u> or C<\U>.
 
-=item B<Output formatting functions> (printf() and write()):
+=item *
 
-Success/failure result is never tainted.
+B<Output formatting functions> (printf() and write()):
 
-=item B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()):
+Results are never tainted because otherwise even output from print,
+for example C<print(1/7)>, should be tainted if C<use locale> is in
+effect.
+
+=item *
+
+B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()):
 
 Results are tainted if C<use locale> is in effect.
 
-=item B<POSIX locale-dependent functions> (localeconv(), strcoll(),
+=item *
+
+B<POSIX locale-dependent functions> (localeconv(), strcoll(),
 strftime(), strxfrm()):
 
 Results are never tainted.
 
-=item B<POSIX character class tests> (isalnum(), isalpha(), isdigit(),
+=item *
+
+B<POSIX character class tests> (isalnum(), isalpha(), isdigit(),
 isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(),
 isxdigit()):
 
index e1ba87b..c47affc 100644 (file)
@@ -580,6 +580,12 @@ If adding a new module to a set, follow the original author's
 standards for naming modules and the interface to methods in
 those modules.
 
+If developing modules for private internal or project specific use,
+that will never be released to the public, then you should ensure
+that their names will not clash with any future public module. You
+can do this either by using the reserved Local::* category or by
+using a category name that includes an underscore like Foo_Corp::*.
+
 To be portable each component of a module name should be limited to
 11 characters. If it might be used on MS-DOS then try to ensure each is
 unique in the first 8 characters. Nested modules make this easier.
index f37279d..d0bd1c9 100644 (file)
@@ -98,10 +98,6 @@ Compute arithmetic in integer instead of double
 
 Request less of something from the compiler
 
-=item lib
-
-Manipulate @INC at compile time
-
 =item locale
 
 Use and avoid POSIX locales for built-in operations
@@ -118,6 +114,10 @@ Restrict unsafe operations when compiling
 
 Package for overloading perl operations
 
+=item perlio
+
+Configure C level IO
+
 =item re
 
 Alter regular expression behaviour
@@ -146,6 +146,10 @@ Predeclare global variable names (obsolete)
 
 Control optional warnings
 
+=item warnings::register
+
+Warnings import function
+
 =back
 
 =head2 Standard Modules
@@ -220,6 +224,10 @@ Show lexical variables used in functions or files
 
 Helper module for CC backend
 
+=item B::Stash
+
+Show what stashes are loaded
+
 =item B::Terse
 
 Walk Perl syntax tree, printing terse info about ops
@@ -284,10 +292,6 @@ Wrapper around CPAN.pm without using any XS module
 
 Warn of errors (from perspective of caller)
 
-=item Carp::Heavy
-
-Carp guts
-
 =item Class::Struct
 
 Declare struct-like datatypes as Perl classes
@@ -316,6 +320,10 @@ Supply object methods for directory handles
 
 Provides screen dump of Perl data.
 
+=item Encode
+
+Character encodings
+
 =item English
 
 Use nice English (or awk) names for ugly punctuation variables
@@ -436,6 +444,10 @@ Create or remove directory trees
 
 Portably perform operations on file names
 
+=item File::Spec::Epoc
+
+Methods for Epoc file specs
+
 =item File::Spec::Functions
 
 Portably perform operations on file names
@@ -476,6 +488,10 @@ Keep more files open than the system permits
 
 Supply object methods for filehandles
 
+=item Filter::Simple
+
+Simplified source filtering
+
 =item FindBin
 
 Locate directory of original perl script
@@ -572,6 +588,10 @@ Module to convert pod files to HTML
 
 Objects representing POD input paragraphs, commands, etc.
 
+=item Pod::LaTeX
+
+Convert Pod data to formatted Latex
+
 =item Pod::Man
 
 Convert POD data to formatted *roff input
@@ -636,6 +656,10 @@ Run shell commands transparently within perl
 
 Load the C socket.h defines and structure manipulators 
 
+=item Storable
+
+Persistency for perl data structures
+
 =item Symbol
 
 Manipulate Perl symbols and their names
@@ -778,66 +802,87 @@ modules are:
 =over
 
 =item *
+
 Language Extensions and Documentation Tools
 
 =item *
+
 Development Support
 
 =item *
+
 Operating System Interfaces
 
 =item *
+
 Networking, Device Control (modems) and InterProcess Communication
 
 =item *
+
 Data Types and Data Type Utilities
 
 =item *
+
 Database Interfaces
 
 =item *
+
 User Interfaces
 
 =item *
+
 Interfaces to / Emulations of Other Programming Languages
 
 =item *
+
 File Names, File Systems and File Locking (see also File Handles)
 
 =item *
+
 String Processing, Language Text Processing, Parsing, and Searching
 
 =item *
+
 Option, Argument, Parameter, and Configuration File Processing
 
 =item *
+
 Internationalization and Locale
 
 =item *
+
 Authentication, Security, and Encryption
 
 =item *
+
 World Wide Web, HTML, HTTP, CGI, MIME
 
 =item *
+
 Server and Daemon Utilities
 
 =item *
+
 Archiving and Compression
 
 =item *
+
 Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing
 
 =item *
+
 Mail and Usenet News
 
 =item *
+
 Control Flow Utilities (callbacks and exceptions etc)
 
 =item *
+
 File Handle and Input/Output Stream Utilities
 
 =item *
+
 Miscellaneous Modules
 
 =back
@@ -1201,6 +1246,12 @@ If adding a new module to a set, follow the original author's
 standards for naming modules and the interface to methods in
 those modules.
 
+If developing modules for private internal or project specific use,
+that will never be released to the public, then you should ensure
+that their names will not clash with any future public module. You
+can do this either by using the reserved Local::* category or by
+using a category name that includes an underscore like Foo_Corp::*.
+
 To be portable each component of a module name should be limited to
 11 characters. If it might be used on MS-DOS then try to ensure each is
 unique in the first 8 characters. Nested modules make this easier.
@@ -1400,18 +1451,28 @@ Don't delete the original .pl file till the new .pm one works!
 
 =over 4
 
-=item Complete applications rarely belong in the Perl Module Library.
+=item *
+
+Complete applications rarely belong in the Perl Module Library.
+
+=item *
 
-=item Many applications contain some Perl code that could be reused.
+Many applications contain some Perl code that could be reused.
 
 Help save the world! Share your code in a form that makes it easy
 to reuse.
 
-=item Break-out the reusable code into one or more separate module files.
+=item *
+
+Break-out the reusable code into one or more separate module files.
+
+=item *
+
+Take the opportunity to reconsider and redesign the interfaces.
 
-=item Take the opportunity to reconsider and redesign the interfaces.
+=item *
 
-=item In some cases the 'application' can then be reduced to a small
+In some cases the 'application' can then be reduced to a small
 
 fragment of code built on top of the reusable modules. In these cases
 the application could invoked as:
index d179d8c..44d921c 100644 (file)
@@ -91,7 +91,7 @@ Six such conversions are possible:
 
 These conversions are governed by the following general rules:
 
-=over
+=over 4
 
 =item *
 
@@ -141,7 +141,7 @@ argument as in modular arithmetic, e.g., C<mod 2**32> on a 32-bit
 architecture.  C<sprintf "%u", -1> therefore provides the same result as
 C<sprintf "%u", ~0>.
 
-=over
+=over 4
 
 =item Arithmetic operators except, C<no integer>
 
index e97a25b..0bb506d 100644 (file)
@@ -300,8 +300,13 @@ to the right argument.
 Binary "<=>" returns -1, 0, or 1 depending on whether the left
 argument is numerically less than, equal to, or greater than the right
 argument.  If your platform supports NaNs (not-a-numbers) as numeric
-values, using them with "<=>" (or any other numeric comparison)
-returns undef.
+values, using them with "<=>" returns undef.  NaN is not "<", "==", ">",
+"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN
+returns true, as does NaN != anything else. If your platform doesn't
+support NaNs then NaN is just a string with numeric value 0.
+
+    perl -le '$a = NaN; print "No NaN support here" if $a == $a'
+    perl -le '$a = NaN; print "NaN support here" if $a != $a'
 
 Binary "eq" returns true if the left argument is stringwise equal to
 the right argument.
@@ -798,7 +803,7 @@ the trailing delimiter.  This avoids expensive run-time recompilations,
 and is useful when the value you are interpolating won't change over
 the life of the script.  However, mentioning C</o> constitutes a promise
 that you won't change the variables in the pattern.  If you change them,
-Perl won't even notice.  See also L<"qr//">.
+Perl won't even notice.  See also L<"qr/STRING/imosx">.
 
 If the PATTERN evaluates to the empty string, the last
 I<successfully> matched regular expression is used instead.
@@ -951,7 +956,7 @@ A double-quoted, interpolated string.
 
 =item qr/STRING/imosx
 
-This operators quotes--and compiles--its I<STRING> as a regular
+This operator quotes (and possibly compiles) its I<STRING> as a regular
 expression.  I<STRING> is interpolated the same way as I<PATTERN>
 in C<m/PATTERN/>.  If "'" is used as the delimiter, no interpolation
 is done.  Returns a Perl value which may be used instead of the
@@ -1338,7 +1343,7 @@ their results are the same, we consider them individually.  For different
 quoting constructs, Perl performs different numbers of passes, from
 one to five, but these passes are always performed in the same order.
 
-=over
+=over 4
 
 =item Finding the end
 
@@ -1392,7 +1397,7 @@ used in parsing.
 The next step is interpolation in the text obtained, which is now
 delimiter-independent.  There are four different cases.
 
-=over
+=over 4
 
 =item C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///>
 
@@ -1842,8 +1847,8 @@ integer>, if you take the C<sqrt(2)>, you'll still get C<1.4142135623731>
 or so.
 
 Used on numbers, the bitwise operators ("&", "|", "^", "~", "<<",
-and ">>") always produce integral results.  (But see also L<Bitwise
-String Operators>.)  However, C<use integer> still has meaning for
+and ">>") always produce integral results.  (But see also 
+L<Bitwise String Operators>.)  However, C<use integer> still has meaning for
 them.  By default, their results are interpreted as unsigned integers, but
 if C<use integer> is in effect, their results are interpreted
 as signed integers.  For example, C<~0> usually evaluates to a large
index 5d2d48e..b4003f4 100644 (file)
@@ -73,8 +73,8 @@ from a different file, and forget to trim it before opening:
 This is not a bug, but a feature.  Because C<open> mimics the shell in
 its style of using redirection arrows to specify how to open the file, it
 also does so with respect to extra white space around the filename itself
-as well.  For accessing files with naughty names, see L<"Dispelling
-the Dweomer">.
+as well.  For accessing files with naughty names, see 
+L<"Dispelling the Dweomer">.
 
 =head2 Pipe Opens
 
@@ -107,13 +107,13 @@ In most systems, such an C<open> will not return an error. That's
 because in the traditional C<fork>/C<exec> model, running the other
 program happens only in the forked child process, which means that
 the failed C<exec> can't be reflected in the return value of C<open>.
-Only a failed C<fork> shows up there.  See L<perlfaq8/"Why doesn't open()
-return an error when a pipe open fails?"> to see how to cope with this.
-There's also an explanation in L<perlipc>.
+Only a failed C<fork> shows up there.  See 
+L<perlfaq8/"Why doesn't open() return an error when a pipe open fails?"> 
+to see how to cope with this.  There's also an explanation in L<perlipc>.
 
 If you would like to open a bidirectional pipe, the IPC::Open2
-library will handle this for you.  Check out L<perlipc/"Bidirectional
-Communication with Another Process">
+library will handle this for you.  Check out 
+L<perlipc/"Bidirectional Communication with Another Process">
 
 =head2 The Minus File
 
@@ -126,8 +126,8 @@ access the standard output.
 If minus can be used as the default input or default output, what happens
 if you open a pipe into or out of minus?  What's the default command it
 would run?  The same script as you're currently running!  This is actually
-a stealth C<fork> hidden inside an C<open> call.  See L<perlipc/"Safe Pipe
-Opens"> for details.
+a stealth C<fork> hidden inside an C<open> call.  See 
+L<perlipc/"Safe Pipe Opens"> for details.
 
 =head2 Mixing Reads and Writes
 
@@ -684,9 +684,9 @@ also some high-level modules on CPAN that can help you with these games.
 Check out Term::ReadKey and Term::ReadLine.
 
 What else can you open?  To open a connection using sockets, you won't use
-one of Perl's two open functions.  See L<perlipc/"Sockets: Client/Server
-Communication"> for that.  Here's an example.  Once you have it,
-you can use FH as a bidirectional filehandle.
+one of Perl's two open functions.  See 
+L<perlipc/"Sockets: Client/Server Communication"> for that.  Here's an 
+example.  Once you have it, you can use FH as a bidirectional filehandle.
 
     use IO::Socket;
     local *FH = IO::Socket::INET->new("www.perl.com:80");
index 6c0c534..22a0256 100644 (file)
@@ -27,6 +27,8 @@ use however it pleases.  Currently recognized commands are
 
     =head1 heading
     =head2 heading
+    =head3 heading
+    =head4 heading
     =item text
     =over N
     =back
@@ -50,8 +52,13 @@ another paragraph to the doc if you're mixing up code and pod a lot.
 
 =item =head2
 
-Head1 and head2 produce first and second level headings, with the text in
-the same paragraph as the "=headn" directive forming the heading description.
+=item =head3
+
+=item =head4
+
+Head1, head2, head3 and head4 produce first, second, third and fourth
+level headings, with the text in the same paragraph as the "=headn"
+directive forming the heading description.
 
 =item =over
 
index 0c35546..1078e58 100644 (file)
@@ -334,7 +334,10 @@ operating systems put mandatory locks on such files.
 
 Don't count on a specific environment variable existing in C<%ENV>.
 Don't count on C<%ENV> entries being case-sensitive, or even
-case-preserving.
+case-preserving.  Don't try to clear %ENV by saying C<%ENV = ();>, or,
+if you really have to, make it conditional on C<$^O ne 'VMS'> since in
+VMS the C<%ENV> table is much more than a per-process key-value string
+table.
 
 Don't count on signals or C<%SIG> for anything.
 
@@ -683,7 +686,7 @@ The ActiveState Pages, http://www.activestate.com/
 =item *
 
 The Cygwin environment for Win32; F<README.cygwin> (installed 
-as L<perlcygwin>), http://sources.redhat.com/cygwin/
+as L<perlcygwin>), http://www.cygwin.com/
 
 =item *
 
@@ -890,9 +893,9 @@ vmsperl on the web, http://www.sidhe.org/vmsperl/index.html
 
 =head2 VOS
 
-Perl on VOS is discussed in F<README.vos> in the perl distribution.
-Perl on VOS can accept either VOS- or Unix-style file
-specifications as in either of the following:
+Perl on VOS is discussed in F<README.vos> in the perl distribution
+(installed as L<perlvos>).  Perl on VOS can accept either VOS- or
+Unix-style file specifications as in either of the following:
 
     $ perl -ne "print if /perl_setup/i" >system>notices
     $ perl -ne "print if /perl_setup/i" /system/notices
@@ -908,12 +911,11 @@ contain a slash character cannot be processed.  Such files must be
 renamed before they can be processed by Perl.  Note that VOS limits
 file names to 32 or fewer characters.
 
-The following C functions are unimplemented on VOS, and any attempt by
-Perl to use them will result in a fatal error message and an immediate
-exit from Perl:  dup, do_aspawn, do_spawn, fork, waitpid.  Once these
-functions become available in the VOS POSIX.1 implementation, you can
-either recompile and rebind Perl, or you can download a newer port from
-ftp.stratus.com.
+See F<README.vos> for restrictions that apply when Perl is built
+with the alpha version of VOS POSIX.1 support.
+
+Perl on VOS is built without any extensions and does not support
+dynamic loading.
 
 The value of C<$^O> on VOS is "VOS".  To determine the architecture that
 you are running on without resorting to loading all of C<%Config> you
@@ -1211,7 +1213,7 @@ A free perl5-based PERL.NLM for Novell Netware is available in
 precompiled binary and source code form from http://www.novell.com/
 as well as from CPAN.
 
-=item 
+=item  *
 
 Plan 9, F<README.plan9>
 
@@ -1995,9 +1997,9 @@ http://www.perl.com/CPAN/ports/index.html for binary distributions.
 
 =head1 SEE ALSO
 
-L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlebcdic>,
-L<perlhpux>, L<perlos2>, L<perlos390>, L<perlposix-bc>, L<perlwin32>,
-L<perlvms>, and L<Win32>.
+L<perlaix>, L<perlamiga>, L<perlcygwin>, L<perldos>, L<perlepoc>,
+L<perlebcdic>, L<perlhpux>, L<perlos2>, L<perlos390>, L<perlposix-bc>,
+L<perlwin32>, L<perlvms>, L<perlvos>, and L<Win32>.
 
 =head1 AUTHORS / CONTRIBUTORS
 
index 380bc5f..c5ecb13 100644 (file)
@@ -225,19 +225,21 @@ whole character class.  For example:
 matches zero, one, any alphabetic character, and the percentage sign.
 
 If the C<utf8> pragma is used, the following equivalences to Unicode
-\p{} constructs hold:
+\p{} constructs and equivalent backslash character classes (if available),
+will hold:
 
     alpha       IsAlpha
     alnum       IsAlnum
     ascii       IsASCII
     blank      IsSpace
     cntrl       IsCntrl
-    digit       IsDigit
+    digit       IsDigit        \d
     graph       IsGraph
     lower       IsLower
     print       IsPrint
     punct       IsPunct
     space       IsSpace
+                IsSpacePerl    \s
     upper       IsUpper
     word        IsWord
     xdigit      IsXDigit
@@ -910,10 +912,14 @@ ways they can use backtracking to try match.  For example, without
 internal optimizations done by the regular expression engine, this will
 take a painfully long time to run:
 
-    'aaaaaaaaaaaa' =~ /((a{0,5}){0,5}){0,5}[c]/
+    'aaaaaaaaaaaa' =~ /((a{0,5}){0,5})*[c]/
 
-And if you used C<*>'s instead of limiting it to 0 through 5 matches,
-then it would take forever--or until you ran out of stack space.
+And if you used C<*>'s in the internal groups instead of limiting them
+to 0 through 5 matches, then it would take forever--or until you ran
+out of stack space.  Moreover, these internal optimizations are not
+always applicable.  For example, if you put C<{0,5}> instead of C<*>
+on the external group, no current optimization is applicable, and the
+match takes a long time to finish.
 
 A powerful tool for optimizing such beasts is what is known as an
 "independent group",
@@ -1129,7 +1135,7 @@ one match at a given position is possible.  This section describes the
 notion of better/worse for combining operators.  In the description
 below C<S> and C<T> are regular subexpressions.
 
-=over
+=over 4
 
 =item C<ST>
 
index c8593fb..073d358 100644 (file)
@@ -386,7 +386,7 @@ to do with references.
 
 =head1 Credits
 
-Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref@plover.com>)
+Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref+@plover.com>)
 
 This article originally appeared in I<The Perl Journal>
 (http://tpj.com) volume 3, #2.  Reprinted with permission.  
index a14229c..5b72a35 100644 (file)
@@ -166,24 +166,31 @@ Perl has several abbreviations for common character classes:
 =over 4
 
 =item *
+
 \d is a digit and represents [0-9]
 
 =item *
+
 \s is a whitespace character and represents [\ \t\r\n\f]
 
 =item *
+
 \w is a word character (alphanumeric or _) and represents [0-9a-zA-Z_]
 
 =item *
+
 \D is a negated \d; it represents any character but a digit [^0-9]
 
 =item *
+
 \S is a negated \s; it represents any non-whitespace character [^\s]
 
 =item *
+
 \W is a negated \w; it represents any non-word character [^\w]
 
 =item *
+
 The period '.' matches any character but "\n"
 
 =back
@@ -297,18 +304,30 @@ have the following meanings:
 
 =over 4
 
-=item * C<a?> = match 'a' 1 or 0 times
+=item *
 
-=item * C<a*> = match 'a' 0 or more times, i.e., any number of times
+C<a?> = match 'a' 1 or 0 times
+
+=item *
 
-=item * C<a+> = match 'a' 1 or more times, i.e., at least once
+C<a*> = match 'a' 0 or more times, i.e., any number of times
 
-=item * C<a{n,m}> = match at least C<n> times, but not more than C<m>
+=item *
+
+C<a+> = match 'a' 1 or more times, i.e., at least once
+
+=item *
+
+C<a{n,m}> = match at least C<n> times, but not more than C<m>
 times.
 
-=item * C<a{n,}> = match at least C<n> or more times
+=item *
+
+C<a{n,}> = match at least C<n> or more times
+
+=item *
 
-=item * C<a{n}> = match exactly C<n> times
+C<a{n}> = match exactly C<n> times
 
 =back
 
index 2c449f8..a77b87e 100644 (file)
@@ -368,24 +368,31 @@ has several abbreviations for common character classes:
 =over 4
 
 =item *
+
 \d is a digit and represents [0-9]
 
 =item *
+
 \s is a whitespace character and represents [\ \t\r\n\f]
 
 =item *
+
 \w is a word character (alphanumeric or _) and represents [0-9a-zA-Z_]
 
 =item *
+
 \D is a negated \d; it represents any character but a digit [^0-9]
 
 =item *
+
 \S is a negated \s; it represents any non-whitespace character [^\s]
 
 =item *
+
 \W is a negated \w; it represents any non-word character [^\w]
 
 =item *
+
 The period '.' matches any character but "\n"
 
 =back
@@ -451,22 +458,26 @@ and C<$> are able to match.  Here are the four possible combinations:
 =over 4
 
 =item *
+
 no modifiers (//): Default behavior.  C<'.'> matches any character
 except C<"\n">.  C<^> matches only at the beginning of the string and
 C<$> matches only at the end or before a newline at the end.
 
 =item *
+
 s modifier (//s): Treat string as a single long line.  C<'.'> matches
 any character, even C<"\n">.  C<^> matches only at the beginning of
 the string and C<$> matches only at the end or before a newline at the
 end.
 
 =item *
+
 m modifier (//m): Treat string as a set of multiple lines.  C<'.'>
 matches any character except C<"\n">.  C<^> and C<$> are able to match
 at the start or end of I<any> line within the string.
 
 =item *
+
 both s and m modifiers (//sm): Treat string as a single long line, but
 detect multiple lines.  C<'.'> matches any character, even
 C<"\n">.  C<^> and C<$>, however, are able to match at the start or end
@@ -602,32 +613,52 @@ of what perl does when it tries to match the regexp
 
 =over 4
 
-=item 0 Start with the first letter in the string 'a'.
+=item 0
+
+Start with the first letter in the string 'a'.
+
+=item 1
 
-=item 1 Try the first alternative in the first group 'abd'.
+Try the first alternative in the first group 'abd'.
 
-=item 2 Match 'a' followed by 'b'. So far so good.
+=item 2
 
-=item 3 'd' in the regexp doesn't match 'c' in the string - a dead
+Match 'a' followed by 'b'. So far so good.
+
+=item 3
+
+'d' in the regexp doesn't match 'c' in the string - a dead
 end.  So backtrack two characters and pick the second alternative in
 the first group 'abc'.
 
-=item 4 Match 'a' followed by 'b' followed by 'c'.  We are on a roll
+=item 4
+
+Match 'a' followed by 'b' followed by 'c'.  We are on a roll
 and have satisfied the first group. Set $1 to 'abc'.
 
-=item 5 Move on to the second group and pick the first alternative
+=item 5
+
+Move on to the second group and pick the first alternative
 'df'.
 
-=item 6 Match the 'd'.
+=item 6
 
-=item 7 'f' in the regexp doesn't match 'e' in the string, so a dead
+Match the 'd'.
+
+=item 7
+
+'f' in the regexp doesn't match 'e' in the string, so a dead
 end.  Backtrack one character and pick the second alternative in the
 second group 'd'.
 
-=item 8 'd' matches. The second grouping is satisfied, so set $2 to
+=item 8
+
+'d' matches. The second grouping is satisfied, so set $2 to
 'd'.
 
-=item 9 We are at the end of the regexp, so we are done! We have
+=item 9
+
+We are at the end of the regexp, so we are done! We have
 matched 'abcd' out of the string "abcde".
 
 =back
@@ -770,18 +801,30 @@ meanings:
 
 =over 4
 
-=item * C<a?> = match 'a' 1 or 0 times
+=item *
 
-=item * C<a*> = match 'a' 0 or more times, i.e., any number of times
+C<a?> = match 'a' 1 or 0 times
 
-=item * C<a+> = match 'a' 1 or more times, i.e., at least once
+=item *
+
+C<a*> = match 'a' 0 or more times, i.e., any number of times
+
+=item *
 
-=item * C<a{n,m}> = match at least C<n> times, but not more than C<m>
+C<a+> = match 'a' 1 or more times, i.e., at least once
+
+=item *
+
+C<a{n,m}> = match at least C<n> times, but not more than C<m>
 times.
 
-=item * C<a{n,}> = match at least C<n> or more times
+=item *
+
+C<a{n,}> = match at least C<n> or more times
+
+=item *
 
-=item * C<a{n}> = match exactly C<n> times
+C<a{n}> = match exactly C<n> times
 
 =back
 
@@ -845,19 +888,23 @@ the principles above to predict which way the regexp will match:
 =over 4
 
 =item *
+
 Principle 0: Taken as a whole, any regexp will be matched at the
 earliest possible position in the string.
 
 =item *
+
 Principle 1: In an alternation C<a|b|c...>, the leftmost alternative
 that allows a match for the whole regexp will be the one used.
 
 =item *
+
 Principle 2: The maximal matching quantifiers C<?>, C<*>, C<+> and
 C<{n,m}> will in general match as much of the string as possible while
 still allowing the whole regexp to match.
 
 =item *
+
 Principle 3: If there are two or more elements in a regexp, the
 leftmost greedy quantifier, if any, will match as much of the string
 as possible while still allowing the whole regexp to match.  The next
@@ -925,21 +972,33 @@ following meanings:
 
 =over 4
 
-=item * C<a??> = match 'a' 0 or 1 times. Try 0 first, then 1.
+=item *
+
+C<a??> = match 'a' 0 or 1 times. Try 0 first, then 1.
 
-=item * C<a*?> = match 'a' 0 or more times, i.e., any number of times,
+=item *
+
+C<a*?> = match 'a' 0 or more times, i.e., any number of times,
 but as few times as possible
 
-=item * C<a+?> = match 'a' 1 or more times, i.e., at least once, but
+=item *
+
+C<a+?> = match 'a' 1 or more times, i.e., at least once, but
 as few times as possible
 
-=item * C<a{n,m}?> = match at least C<n> times, not more than C<m>
+=item *
+
+C<a{n,m}?> = match at least C<n> times, not more than C<m>
 times, as few times as possible
 
-=item * C<a{n,}?> = match at least C<n> times, but as few times as
+=item *
+
+C<a{n,}?> = match at least C<n> times, but as few times as
 possible
 
-=item * C<a{n}?> = match exactly C<n> times.  Because we match exactly
+=item *
+
+C<a{n}?> = match exactly C<n> times.  Because we match exactly
 C<n> times, C<a{n}?> is equivalent to C<a{n}> and is just there for
 notational consistency.
 
@@ -998,6 +1057,7 @@ quantifiers:
 =over 4
 
 =item *
+
 Principle 3: If there are two or more elements in a regexp, the
 leftmost greedy (non-greedy) quantifier, if any, will match as much
 (little) of the string as possible while still allowing the whole
@@ -1019,23 +1079,37 @@ backtracking.  Here is a step-by-step analysis of the example
 
 =over 4
 
-=item 0 Start with the first letter in the string 't'.
+=item 0
+
+Start with the first letter in the string 't'.
 
-=item 1 The first quantifier '.*' starts out by matching the whole
+=item 1
+
+The first quantifier '.*' starts out by matching the whole
 string 'the cat in the hat'.
 
-=item 2 'a' in the regexp element 'at' doesn't match the end of the
+=item 2
+
+'a' in the regexp element 'at' doesn't match the end of the
 string.  Backtrack one character.
 
-=item 3 'a' in the regexp element 'at' still doesn't match the last
+=item 3
+
+'a' in the regexp element 'at' still doesn't match the last
 letter of the string 't', so backtrack one more character.
 
-=item 4 Now we can match the 'a' and the 't'.
+=item 4
+
+Now we can match the 'a' and the 't'.
 
-=item 5 Move on to the third element '.*'.  Since we are at the end of
+=item 5
+
+Move on to the third element '.*'.  Since we are at the end of
 the string and '.*' can match 0 times, assign it the empty string.
 
-=item 6 We are done!
+=item 6
+
+We are done!
 
 =back
 
@@ -1180,15 +1254,25 @@ This is our final regexp.  To recap, we built a regexp by
 
 =over 4
 
-=item * specifying the task in detail,
+=item *
+
+specifying the task in detail,
 
-=item * breaking down the problem into smaller parts,
+=item *
+
+breaking down the problem into smaller parts,
+
+=item *
 
-=item * translating the small parts into regexps,
+translating the small parts into regexps,
 
-=item * combining the regexps,
+=item *
+
+combining the regexps,
+
+=item *
 
-=item * and optimizing the final combined regexp.
+and optimizing the final combined regexp.
 
 =back
 
index d8fb12c..4a4c957 100644 (file)
@@ -311,7 +311,7 @@ equivalent to B<-Dtls>):
         8  t  Trace execution
        16  o  Method and overloading resolution
        32  c  String/numeric conversions
-       64  P  Print preprocessor command for -P
+       64  P  Print preprocessor command for -P, source file input state
       128  m  Memory allocation
       256  f  Format processing
       512  r  Regular expression parsing and execution
@@ -322,6 +322,7 @@ equivalent to B<-Dtls>):
     16384  X  Scratchpad allocation
     32768  D  Cleaning up
     65536  S  Thread synchronization
+   131072  T  Tokenising
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable.  See the F<INSTALL> file in the Perl source distribution 
@@ -569,9 +570,23 @@ the implicit loop, just as in B<awk>.
 =item B<-P>
 
 causes your program to be run through the C preprocessor before
-compilation by Perl.  (Because both comments and B<cpp> directives begin
+compilation by Perl.  Because both comments and B<cpp> directives begin
 with the # character, you should avoid starting comments with any words
-recognized by the C preprocessor such as "if", "else", or "define".)
+recognized by the C preprocessor such as C<"if">, C<"else">, or C<"define">.
+Also, in some platforms the C preprocessor knows too much: it knows
+about the C++ -style until-end-of-line comments starting with C<"//">.
+This will cause problems with common Perl constructs like
+
+    s/foo//;
+
+because after -P this will became illegal code
+
+    s/foo
+
+The workaround is to use some other quoting separator than C<"/">,
+like for example C<"!">:
+
+    s!foo!!;
 
 =item B<-s>
 
index 6b50b92..3870c2e 100644 (file)
@@ -38,9 +38,22 @@ msgrcv(), the password, gcos and shell fields returned by the
 getpwxxx() calls), and all file input are marked as "tainted".
 Tainted data may not be used directly or indirectly in any command
 that invokes a sub-shell, nor in any command that modifies files,
-directories, or processes. (B<Important exception>: If you pass a list
-of arguments to either C<system> or C<exec>, the elements of that list
-are B<NOT> checked for taintedness.) Any variable set to a value
+directories, or processes, B<with the following exceptions>:
+
+=over 4
+
+=item *
+
+If you pass a list of arguments to either C<system> or C<exec>,
+the elements of that list are B<not> checked for taintedness.
+
+=item *
+
+Arguments to C<print> and C<syswrite> are B<not> checked for taintedness.
+
+=back
+
+Any variable set to a value
 derived from tainted data will itself be tainted, even if it is
 logically impossible for the tainted data to alter the variable.
 Because taintedness is associated with each scalar value, some
@@ -217,25 +230,31 @@ not called with a string that the shell could expand.  This is by far the
 best way to call something that might be subjected to shell escapes: just
 never call the shell at all.  
 
-    use English;
-    die "Can't fork: $!" unless defined $pid = open(KID, "-|");
-    if ($pid) {                  # parent
-       while (<KID>) {
-           # do something
-       }
-       close KID;
-    } else {
-       my @temp = ($EUID, $EGID);
-       $EUID = $UID;
-       $EGID = $GID;    #      initgroups() also called!
-       # Make sure privs are really gone
-       ($EUID, $EGID) = @temp;
-       die "Can't drop privileges" 
-               unless $UID == $EUID  && $GID eq $EGID; 
-       $ENV{PATH} = "/bin:/usr/bin";
-       exec 'myprog', 'arg1', 'arg2' 
-           or die "can't exec myprog: $!";
-    }
+        use English;
+        die "Can't fork: $!" unless defined($pid = open(KID, "-|"));
+        if ($pid) {           # parent
+            while (<KID>) {
+                # do something
+            }
+            close KID;
+        } else {
+            my @temp     = ($EUID, $EGID);
+            my $orig_uid = $UID;
+            my $orig_gid = $GID;
+            $EUID = $UID;
+            $EGID = $GID;
+            # Drop privileges
+            $UID  = $orig_uid;
+            $GID  = $orig_gid;
+            # Make sure privs are really gone
+            ($EUID, $EGID) = @temp;
+            die "Can't drop privileges"
+                unless $UID == $EUID  && $GID eq $EGID;
+            $ENV{PATH} = "/bin:/usr/bin"; # Minimal PATH.
+           # Consider sanitizing the environment even more.
+            exec 'myprog', 'arg1', 'arg2'
+                or die "can't exec myprog: $!";
+        }
 
 A similar strategy would work for wildcard expansion via C<glob>, although
 you can use C<readdir> instead.
index 9976316..cef8050 100644 (file)
@@ -169,8 +169,8 @@ Do not, however, be tempted to do this:
 
 Like the flattened incoming parameter list, the return list is also
 flattened on return.  So all you have managed to do here is stored
-everything in C<@a> and made C<@b> an empty list.  See L<Pass by
-Reference> for alternatives.
+everything in C<@a> and made C<@b> an empty list.  See 
+L<Pass by Reference> for alternatives.
 
 A subroutine may be called using an explicit C<&> prefix.  The
 C<&> is optional in modern Perl, as are parentheses if the
@@ -697,9 +697,11 @@ Despite the existence of C<my>, there are still three places where the
 C<local> operator still shines.  In fact, in these three places, you
 I<must> use C<local> instead of C<my>.
 
-=over
+=over 4
 
-=item 1. You need to give a global variable a temporary value, especially $_.
+=item 1.
+
+You need to give a global variable a temporary value, especially $_.
 
 The global variables, like C<@ARGV> or the punctuation variables, must be 
 C<local>ized with C<local()>.  This block reads in F</etc/motd>, and splits
@@ -716,7 +718,9 @@ in C<@Fields>.
 It particular, it's important to C<local>ize $_ in any routine that assigns
 to it.  Look out for implicit assignments in C<while> conditionals.
 
-=item 2. You need to create a local file or directory handle or a local function.
+=item 2.
+
+You need to create a local file or directory handle or a local function.
 
 A function that needs a filehandle of its own must use
 C<local()> on a complete typeglob.   This can be used to create new symbol
@@ -746,7 +750,9 @@ a local alias.
 See L<perlref/"Function Templates"> for more about manipulating
 functions by name in this way.
 
-=item 3. You want to temporarily change just one element of an array or hash.
+=item 3.
+
+You want to temporarily change just one element of an array or hash.
 
 You can C<local>ize just one element of an aggregate.  Usually this
 is done on dynamics:
index 1a58965..1bba005 100644 (file)
@@ -71,7 +71,7 @@ calls.  Here's the preamble of the class.
     use strict;
     $Nice::DEBUG = 0 unless defined $Nice::DEBUG;
 
-=over
+=over 4
 
 =item TIESCALAR classname, LIST
 
@@ -201,31 +201,22 @@ B<Tie::Array> simply C<croak>.
 In addition EXTEND will be called when perl would have pre-extended
 allocation in a real array.
 
-This means that tied arrays are now I<complete>. The example below needs
-upgrading to illustrate this. (The documentation in B<Tie::Array> is more
-complete.)
+For this discussion, we'll implement an array whose elements are a fixed
+size at creation.  If you try to create an element larger than the fixed
+size, you'll take an exception.  For example:
 
-For this discussion, we'll implement an array whose indices are fixed at
-its creation.  If you try to access anything beyond those bounds, you'll
-take an exception.  For example:
-
-    require Bounded_Array;
-    tie @ary, 'Bounded_Array', 2;
-    $| = 1;
-    for $i (0 .. 10) {
-        print "setting index $i: ";
-        $ary[$i] = 10 * $i;
-        $ary[$i] = 10 * $i;
-        print "value of elt $i now $ary[$i]\n";
-    }
+    use FixedElem_Array;
+    tie @array, 'FixedElem_Array', 3;
+    $array[0] = 'cat';  # ok.
+    $array[1] = 'dogs'; # exception, length('dogs') > 3.
 
 The preamble code for the class is as follows:
 
-    package Bounded_Array;
+    package FixedElem_Array;
     use Carp;
     use strict;
 
-=over
+=over 4
 
 =item TIEARRAY classname, LIST
 
@@ -235,21 +226,22 @@ anonymous ARRAY ref) will be accessed.
 
 In our example, just to show you that you don't I<really> have to return an
 ARRAY reference, we'll choose a HASH reference to represent our object.
-A HASH works out well as a generic record type: the C<{BOUND}> field will
-store the maximum bound allowed, and the C<{ARRAY}> field will hold the
+A HASH works out well as a generic record type: the C<{ELEMSIZE}> field will
+store the maximum element size allowed, and the C<{ARRAY}> field will hold the
 true ARRAY ref.  If someone outside the class tries to dereference the
 object returned (doubtless thinking it an ARRAY ref), they'll blow up.
 This just goes to show you that you should respect an object's privacy.
 
     sub TIEARRAY {
-       my $class = shift;
-       my $bound = shift;
-       confess "usage: tie(\@ary, 'Bounded_Array', max_subscript)"
-           if @_ || $bound =~ /\D/;
-       return bless {
-           BOUND => $bound,
-           ARRAY => [],
-       }, $class;
+      my $class    = shift;
+      my $elemsize = shift;
+      if ( @_ || $elemsize =~ /\D/ ) {
+        croak "usage: tie ARRAY, '" . __PACKAGE__ . "', elem_size";
+      }
+      return bless {
+        ELEMSIZE => $elemsize,
+        ARRAY    => [],
+      }, $class;
     }
 
 =item FETCH this, index
@@ -259,11 +251,9 @@ is accessed (read).  It takes one argument beyond its self reference: the
 index whose value we're trying to fetch.
 
     sub FETCH {
-      my($self,$idx) = @_;
-      if ($idx > $self->{BOUND}) {
-       confess "Array OOB: $idx > $self->{BOUND}";
-      }
-      return $self->{ARRAY}[$idx];
+      my $self  = shift;
+      my $index = shift;
+      return $self->{ARRAY}->[$index];
     }
 
 If a negative array index is used to read from an array, the index
@@ -281,19 +271,185 @@ to keep them at simply one tie type per class.
 This method will be triggered every time an element in the tied array is set
 (written).  It takes two arguments beyond its self reference: the index at
 which we're trying to store something and the value we're trying to put
-there.  For example:
+there.
+
+In our example, C<undef> is really C<$self-E<gt>{ELEMSIZE}> number of
+spaces so we have a little more work to do here:
 
     sub STORE {
-      my($self, $idx, $value) = @_;
-      print "[STORE $value at $idx]\n" if _debug;
-      if ($idx > $self->{BOUND} ) {
-        confess "Array OOB: $idx > $self->{BOUND}";
+      my $self = shift;
+      my( $index, $value ) = @_;
+      if ( length $value > $self->{ELEMSIZE} ) {
+        croak "length of $value is greater than $self->{ELEMSIZE}";
       }
-      return $self->{ARRAY}[$idx] = $value;
+      # fill in the blanks
+      $self->EXTEND( $index ) if $index > $self->FETCHSIZE();
+      # right justify to keep element size for smaller elements
+      $self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value;
     }
 
 Negative indexes are treated the same as with FETCH.
 
+=item FETCHSIZE this
+
+Returns the total number of items in the tied array associated with
+object I<this>. (Equivalent to C<scalar(@array)>).  For example:
+
+    sub FETCHSIZE {
+      my $self = shift;
+      return scalar @{$self->{ARRAY}};
+    }
+
+=item STORESIZE this, count
+
+Sets the total number of items in the tied array associated with
+object I<this> to be I<count>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+If the array becomes smaller then entries beyond count should be
+deleted. 
+
+In our example, 'undef' is really an element containing
+C<$self-E<gt>{ELEMSIZE}> number of spaces.  Observe:
+
+    sub STORESIZE {
+      my $self  = shift;
+      my $count = shift;
+      if ( $count > $self->FETCHSIZE() ) {
+        foreach ( $count - $self->FETCHSIZE() .. $count ) {
+          $self->STORE( $_, '' );
+        }
+      } elsif ( $count < $self->FETCHSIZE() ) {
+        foreach ( 0 .. $self->FETCHSIZE() - $count - 2 ) {
+          $self->POP();
+        }
+      }
+    }
+
+=item EXTEND this, count
+
+Informative call that array is likely to grow to have I<count> entries.
+Can be used to optimize allocation. This method need do nothing.
+
+In our example, we want to make sure there are no blank (C<undef>)
+entries, so C<EXTEND> will make use of C<STORESIZE> to fill elements
+as needed:
+
+    sub EXTEND {   
+      my $self  = shift;
+      my $count = shift;
+      $self->STORESIZE( $count );
+    }
+
+=item EXISTS this, key
+
+Verify that the element at index I<key> exists in the tied array I<this>.
+
+In our example, we will determine that if an element consists of
+C<$self-E<gt>{ELEMSIZE}> spaces only, it does not exist:
+
+    sub EXISTS {
+      my $self  = shift;
+      my $index = shift;
+      return 0 if ! defined $self->{ARRAY}->[$index] ||
+                  $self->{ARRAY}->[$index] eq ' ' x $self->{ELEMSIZE};
+      return 1;
+    }
+
+=item DELETE this, key
+
+Delete the element at index I<key> from the tied array I<this>.
+
+In our example, a deleted item is C<$self->{ELEMSIZE}> spaces:
+
+    sub DELETE {
+      my $self  = shift;
+      my $index = shift;
+      return $self->STORE( $index, '' );
+    }
+
+=item CLEAR this
+
+Clear (remove, delete, ...) all values from the tied array associated with
+object I<this>.  For example:
+
+    sub CLEAR {
+      my $self = shift;
+      return $self->{ARRAY} = [];
+    }
+
+=item PUSH this, LIST 
+
+Append elements of I<LIST> to the array.  For example:
+
+    sub PUSH {  
+      my $self = shift;
+      my @list = @_;
+      my $last = $self->FETCHSIZE();
+      $self->STORE( $last + $_, $list[$_] ) foreach 0 .. $#list;
+      return $self->FETCHSIZE();
+    }   
+
+=item POP this
+
+Remove last element of the array and return it.  For example:
+
+    sub POP {
+      my $self = shift;
+      return pop @{$self->{ARRAY}};
+    }
+
+=item SHIFT this
+
+Remove the first element of the array (shifting other elements down)
+and return it.  For example:
+
+    sub SHIFT {
+      my $self = shift;
+      return shift @{$self->{ARRAY}};
+    }
+
+=item UNSHIFT this, LIST 
+
+Insert LIST elements at the beginning of the array, moving existing elements
+up to make room.  For example:
+
+    sub UNSHIFT {
+      my $self = shift;
+      my @list = @_;
+      my $size = scalar( @list );
+      # make room for our list
+      @{$self->{ARRAY}}[ $size .. $#{$self->{ARRAY}} + $size ]
+       = @{$self->{ARRAY}};
+      $self->STORE( $_, $list[$_] ) foreach 0 .. $#list;
+    }
+
+=item SPLICE this, offset, length, LIST
+
+Perform the equivalent of C<splice> on the array. 
+
+I<offset> is optional and defaults to zero, negative values count back 
+from the end of the array. 
+
+I<length> is optional and defaults to rest of the array.
+
+I<LIST> may be empty.
+
+Returns a list of the original I<length> elements at I<offset>.
+
+In our example, we'll use a little shortcut if there is a I<LIST>:
+
+    sub SPLICE {
+      my $self   = shift;
+      my $offset = shift || 0;
+      my $length = shift || $self->FETCHSIZE() - $offset;
+      my @list   = (); 
+      if ( @_ ) {
+        tie @list, __PACKAGE__, $self->{ELEMSIZE};
+        @list   = @_;
+      }
+      return splice @{$self->{ARRAY}}, $offset, $length, @list;
+    }
+
 =item UNTIE this
 
 Will be called when C<untie> happens. (See below.)
@@ -307,17 +463,6 @@ just leave it out.
 
 =back
 
-The code we presented at the top of the tied array class accesses many
-elements of the array, far more than we've set the bounds to.  Therefore,
-it will blow up once they try to access beyond the 2nd element of @ary, as
-the following output demonstrates:
-
-    setting index 0: value of elt 0 now 0
-    setting index 1: value of elt 1 now 10
-    setting index 2: value of elt 2 now 20
-    setting index 3: Array OOB: 3 > 2 at Bounded_Array.pm line 39
-            Bounded_Array::FETCH called at testba line 12
-
 =head2 Tying Hashes
 
 Hashes were the first Perl data type to be tied (see dbmopen()).  A class
@@ -400,7 +545,7 @@ that calls it.
 
 Here are the methods for the DotFiles tied hash.
 
-=over
+=over 4
 
 =item TIEHASH classname, LIST
 
@@ -655,7 +800,7 @@ In our example we're going to create a shouting handle.
 
     package Shout;
 
-=over
+=over 4
 
 =item TIEHANDLE classname, LIST
 
@@ -936,3 +1081,4 @@ TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<
 
 UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
 
+Tying Arrays by Casey Tweten <F<crt@kiski.net>>
index b87b3ab..c0750e8 100644 (file)
@@ -13,22 +13,12 @@ through to locate the proper section you're looking for.
 
 =head2 perl - Practical Extraction and Report Language
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-modularity and reusability using innumerable modules, embeddable and
-extensible, roll-your-own magic variables (including multiple simultaneous
-DBM implementations), subroutines can now be overridden, autoloaded, and
-prototyped, arbitrarily nested data structures and anonymous functions,
-object-oriented programming, compilability into C code or Perl bytecode,
-support for light-weight processes (threads), support for
-internationalization, localization, and Unicode, lexical scoping, regular
-expression enhancements, enhanced debugger and interactive Perl
-environment, with integrated editor support, POSIX 1003.1 compliant library
-
 =item AVAILABILITY
 
 =item ENVIRONMENT
@@ -50,7 +40,7 @@ environment, with integrated editor support, POSIX 1003.1 compliant library
 =head2 perlfaq - frequently asked questions about Perl ($Date: 1999/05/23
 20:38:02 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -63,7 +53,7 @@ I do [task] in Perl?, When shouldn't I program in Perl?, What's the
 difference between "perl" and "Perl"?, Is it a Perl program or a Perl
 script?, What is a JAPH?, Where can I get a list of Larry Wall witticisms?,
 How can I convince my sysadmin/supervisor/employees to use version
-(5/5.005/Perl instead of some other language)?, L<perlfaq2>: Obtaining and
+5/5.005/Perl instead of some other language?, L<perlfaq2>: Obtaining and
 Learning about Perl, What machines support Perl?  Where do I get it?, How
 can I get a binary version of Perl?, I don't have a C compiler on my
 system.  How can I compile perl?, I copied the Perl binary from one machine
@@ -72,80 +62,81 @@ compile but gdbm/dynamic loading/malloc/linking/... failed.  How do I make
 it work?, What modules and extensions are available for Perl?  What is
 CPAN?  What does CPAN/src/... mean?, Is there an ISO or ANSI certified
 version of Perl?, Where can I get information on Perl?, What are the Perl
-newsgroups on USENET?  Where do I post questions?, Where should I post
+newsgroups on Usenet?  Where do I post questions?, Where should I post
 source code?, Perl Books, Perl in Magazines, Perl on the Net: FTP and WWW
-Access, What mailing lists are there for perl?, Archives of
+Access, What mailing lists are there for Perl?, Archives of
 comp.lang.perl.misc, Where can I buy a commercial version of Perl?, Where
-do I send bug reports?, What is perl.com?, L<perlfaq3>: Programming Tools,
-How do I do (anything)?, How can I use Perl interactively?, Is there a Perl
-shell?, How do I debug my Perl programs?, How do I profile my Perl
-programs?, How do I cross-reference my Perl programs?, Is there a
-pretty-printer (formatter) for Perl?, Is there a ctags for Perl?, Is there
-an IDE or Windows Perl Editor?, Where can I get Perl macros for vi?, Where
-can I get perl-mode for emacs?, How can I use curses with Perl?, How can I
-use X or Tk with Perl?, How can I generate simple menus without using CGI
-or Tk?, What is undump?, How can I make my Perl program run faster?, How
-can I make my Perl program take less memory?, Is it unsafe to return a
-pointer to local data?, How can I free an array or hash so my program
-shrinks?, How can I make my CGI script more efficient?, How can I hide the
-source for my Perl program?, How can I compile my Perl program into byte
-code or C?, How can I compile Perl into Java?, How can I get C<#!perl> to
-work on [MS-DOS,NT,...]?, Can I write useful perl programs on the command
-line?, Why don't perl one-liners work on my DOS/Mac/VMS system?, Where can
-I learn about CGI or Web programming in Perl?, Where can I learn about
-object-oriented Perl programming?, Where can I learn about linking C with
-Perl? [h2xs, xsubpp], I've read perlembed, perlguts, etc., but I can't
-embed perl in my C program, what am I doing wrong?, When I tried to run my
-script, I got this message. What does it mean?, What's MakeMaker?,
-L<perlfaq4>: Data Manipulation, Why am I getting long decimals (eg,
-19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?,
-Why isn't my octal data interpreted correctly?, Does Perl have a round()
-function?  What about ceil() and floor()?  Trig functions?, How do I
-convert bits into ints?, Why doesn't & work the way I want it to?, How do I
-multiply matrices?, How do I perform an operation on a series of integers?,
-How can I output Roman numerals?, Why aren't my random numbers random?, How
-do I find the week-of-the-year/day-of-the-year?, How do I find the current
-century or millennium?, How can I compare two dates and find the
-difference?, How can I take a string and turn it into epoch seconds?, How
-can I find the Julian Day?, How do I find yesterday's date?, Does Perl have
-a year 2000 problem?  Is Perl Y2K compliant?, How do I validate input?, How
-do I unescape a string?, How do I remove consecutive pairs of characters?,
-How do I expand function calls in a string?, How do I find matching/nesting
-anything?, How do I reverse a string?, How do I expand tabs in a string?,
-How do I reformat a paragraph?, How can I access/change the first N letters
-of a string?, How do I change the Nth occurrence of something?, How can I
-count the number of occurrences of a substring within a string?, How do I
-capitalize all the words on one line?, How can I split a [character]
-delimited string except when inside [character]? (Comma-separated files),
-How do I strip blank space from the beginning/end of a string?, How do I
-pad a string with blanks or pad a number with zeroes?, How do I extract
-selected columns from a string?, How do I find the soundex value of a
-string?, How can I expand variables in text strings?, What's wrong with
-always quoting "$vars"?, Why don't my <<HERE documents work?, What is the
-difference between a list and an array?, What is the difference between
-$array[1] and @array[1]?, How can I remove duplicate elements from a list
-or array?, How can I tell whether a list or array contains a certain
-element?, How do I compute the difference of two arrays?  How do I compute
-the intersection of two arrays?, How do I test whether two arrays or hashes
-are equal?, How do I find the first array element for which a condition is
-true?, How do I handle linked lists?, How do I handle circular lists?, How
-do I shuffle an array randomly?, How do I process/modify each element of an
-array?, How do I select a random element from an array?, How do I permute N
-elements of a list?, How do I sort an array by (anything)?, How do I
-manipulate arrays of bits?, Why does defined() return true on empty arrays
-and hashes?, How do I process an entire hash?, What happens if I add or
-remove keys from a hash while iterating over it?, How do I look up a hash
-element by value?, How can I know how many entries are in a hash?, How do I
-sort a hash (optionally by value instead of key)?, How can I always keep my
-hash sorted?, What's the difference between "delete" and "undef" with
-hashes?, Why don't my tied hashes make the defined/exists distinction?, How
-do I reset an each() operation part-way through?, How can I get the unique
-keys from two hashes?, How can I store a multidimensional array in a DBM
-file?, How can I make my hash remember the order I put elements into it?,
-Why does passing a subroutine an undefined element in a hash create it?,
-How can I make the Perl equivalent of a C structure/C++ class/hash or array
-of hashes or arrays?, How can I use a reference as a hash key?, How do I
-handle binary data correctly?, How do I determine whether a scalar is a
+do I send bug reports?, What is perl.com? Perl Mongers? pm.org? perl.org?,
+L<perlfaq3>: Programming Tools, How do I do (anything)?, How can I use Perl
+interactively?, Is there a Perl shell?, How do I debug my Perl programs?,
+How do I profile my Perl programs?, How do I cross-reference my Perl
+programs?, Is there a pretty-printer (formatter) for Perl?, Is there a
+ctags for Perl?, Is there an IDE or Windows Perl Editor?, Where can I get
+Perl macros for vi?, Where can I get perl-mode for emacs?, How can I use
+curses with Perl?, How can I use X or Tk with Perl?, How can I generate
+simple menus without using CGI or Tk?, What is undump?, How can I make my
+Perl program run faster?, How can I make my Perl program take less memory?,
+Is it unsafe to return a pointer to local data?, How can I free an array or
+hash so my program shrinks?, How can I make my CGI script more efficient?,
+How can I hide the source for my Perl program?, How can I compile my Perl
+program into byte code or C?, How can I compile Perl into Java?, How can I
+get C<#!perl> to work on [MS-DOS,NT,...]?, Can I write useful Perl programs
+on the command line?, Why don't Perl one-liners work on my DOS/Mac/VMS
+system?, Where can I learn about CGI or Web programming in Perl?, Where can
+I learn about object-oriented Perl programming?, Where can I learn about
+linking C with Perl? [h2xs, xsubpp], I've read perlembed, perlguts, etc.,
+but I can't embed perl in my C program; what am I doing wrong?, When I
+tried to run my script, I got this message. What does it mean?, What's
+MakeMaker?, L<perlfaq4>: Data Manipulation, Why am I getting long decimals
+(eg, 19.9499999999999) instead of the numbers I should be getting (eg,
+19.95)?, Why isn't my octal data interpreted correctly?, Does Perl have a
+round() function?  What about ceil() and floor()?  Trig functions?, How do
+I convert bits into ints?, Why doesn't & work the way I want it to?, How do
+I multiply matrices?, How do I perform an operation on a series of
+integers?, How can I output Roman numerals?, Why aren't my random numbers
+random?, How do I find the week-of-the-year/day-of-the-year?, How do I find
+the current century or millennium?, How can I compare two dates and find
+the difference?, How can I take a string and turn it into epoch seconds?,
+How can I find the Julian Day?, How do I find yesterday's date?, Does Perl
+have a Year 2000 problem?  Is Perl Y2K compliant?, How do I validate
+input?, How do I unescape a string?, How do I remove consecutive pairs of
+characters?, How do I expand function calls in a string?, How do I find
+matching/nesting anything?, How do I reverse a string?, How do I expand
+tabs in a string?, How do I reformat a paragraph?, How can I access/change
+the first N letters of a string?, How do I change the Nth occurrence of
+something?, How can I count the number of occurrences of a substring within
+a string?, How do I capitalize all the words on one line?, How can I split
+a [character] delimited string except when inside [character]?
+(Comma-separated files), How do I strip blank space from the beginning/end
+of a string?, How do I pad a string with blanks or pad a number with
+zeroes?, How do I extract selected columns from a string?, How do I find
+the soundex value of a string?, How can I expand variables in text
+strings?, What's wrong with always quoting "$vars"?, Why don't my <<HERE
+documents work?, What is the difference between a list and an array?, What
+is the difference between $array[1] and @array[1]?, How can I remove
+duplicate elements from a list or array?, How can I tell whether a list or
+array contains a certain element?, How do I compute the difference of two
+arrays?  How do I compute the intersection of two arrays?, How do I test
+whether two arrays or hashes are equal?, How do I find the first array
+element for which a condition is true?, How do I handle linked lists?, How
+do I handle circular lists?, How do I shuffle an array randomly?, How do I
+process/modify each element of an array?, How do I select a random element
+from an array?, How do I permute N elements of a list?, How do I sort an
+array by (anything)?, How do I manipulate arrays of bits?, Why does
+defined() return true on empty arrays and hashes?, How do I process an
+entire hash?, What happens if I add or remove keys from a hash while
+iterating over it?, How do I look up a hash element by value?, How can I
+know how many entries are in a hash?, How do I sort a hash (optionally by
+value instead of key)?, How can I always keep my hash sorted?, What's the
+difference between "delete" and "undef" with hashes?, Why don't my tied
+hashes make the defined/exists distinction?, How do I reset an each()
+operation part-way through?, How can I get the unique keys from two
+hashes?, How can I store a multidimensional array in a DBM file?, How can I
+make my hash remember the order I put elements into it?, Why does passing a
+subroutine an undefined element in a hash create it?, How can I make the
+Perl equivalent of a C structure/C++ class/hash or array of hashes or
+arrays?, How can I use a reference as a hash key?, How do I handle binary
+data correctly?, How do I determine whether a scalar is a
 number/whole/integer/float?, How do I keep persistent data across program
 calls?, How do I print out or copy a recursive data structure?, How do I
 define methods for every class/object?, How do I verify a credit card
@@ -183,7 +174,7 @@ unmaintainable code?, I'm having trouble matching over more than one line.
 What's wrong?, How can I pull out lines between two patterns that are
 themselves on different lines?, I put a regular expression into $/ but it
 didn't work. What's wrong?, How do I substitute case insensitively on the
-LHS, but preserving case on the RHS?, How can I make C<\w> match national
+LHS while preserving case on the RHS?, How can I make C<\w> match national
 character sets?, How can I match a locale-smart version of C</[a-zA-Z]/>?,
 How can I quote a variable to use in a regex?, What is C</o> really for?,
 How do I use a regular expression to strip C style comments from a file?,
@@ -229,7 +220,7 @@ background?, How do I trap control characters/signals?, How do I modify the
 shadow password file on a Unix system?, How do I set the time and date?,
 How can I sleep() or alarm() for under a second?, How can I measure time
 under a second?, How can I do an atexit() or setjmp()/longjmp()? (Exception
-handling), Why doesn't my sockets program work under System V (Solaris)?
+handling), Why doesn't my sockets program work under System V (Solaris)? 
 What does the error message "Protocol not supported" mean?, How can I call
 my system's unique C functions from Perl?, Where do I get the include files
 to do ioctl() or syscall()?, Why do setuid perl scripts complain about
@@ -245,33 +236,32 @@ command line from programs such as "ps"?, I {changed directory, modified my
 environment} in a perl script. How come the change disappeared when I
 exited the script?  How do I get my changes to be visible?, How do I close
 a process's filehandle without waiting for it to complete?, How do I fork a
-daemon process?, How do I make my program run with sh and csh?, How do I
-find out if I'm running interactively or not?, How do I timeout a slow
-event?, How do I set CPU limits?, How do I avoid zombies on a Unix system?,
-How do I use an SQL database?, How do I make a system() exit on control-C?,
-How do I open a file without blocking?, How do I install a module from
-CPAN?, What's the difference between require and use?, How do I keep my own
-module/library directory?, How do I add the directory my program lives in
-to the module/library search path?, How do I add a directory to my include
-path at runtime?, What is socket.ph and where do I get it?, L<perlfaq9>:
-Networking, My CGI script runs from the command line but not the browser.  
-(500 Server Error), How can I get better error messages from a CGI
-program?, How do I remove HTML from a string?, How do I extract URLs?, How
-do I download a file from the user's machine?  How do I open a file on
-another machine?, How do I make a pop-up menu in HTML?, How do I fetch an
-HTML file?, How do I automate an HTML form submission?, How do I decode or
-create those %-encodings on the web?, How do I redirect to another page?,
-How do I put a password on my web pages?, How do I edit my .htpasswd and
-.htgroup files with Perl?, How do I make sure users can't enter values into
-a form that cause my CGI script to do bad things?, How do I parse a mail
-header?, How do I decode a CGI form?, How do I check a valid mail address?,
-How do I decode a MIME/BASE64 string?, How do I return the user's mail
-address?, How do I send mail?, How do I read mail?, How do I find out my
-hostname/domainname/IP address?, How do I fetch a news article or the
-active newsgroups?, How do I fetch/put an FTP file?, How can I do RPC in
-Perl?
-
-=over
+daemon process?, How do I find out if I'm running interactively or not?,
+How do I timeout a slow event?, How do I set CPU limits?, How do I avoid
+zombies on a Unix system?, How do I use an SQL database?, How do I make a
+system() exit on control-C?, How do I open a file without blocking?, How do
+I install a module from CPAN?, What's the difference between require and
+use?, How do I keep my own module/library directory?, How do I add the
+directory my program lives in to the module/library search path?, How do I
+add a directory to my include path at runtime?, What is socket.ph and where
+do I get it?, L<perlfaq9>: Networking, My CGI script runs from the command
+line but not the browser.  (500 Server Error), How can I get better error
+messages from a CGI program?, How do I remove HTML from a string?, How do I
+extract URLs?, How do I download a file from the user's machine?  How do I
+open a file on another machine?, How do I make a pop-up menu in HTML?, How
+do I fetch an HTML file?, How do I automate an HTML form submission?, How
+do I decode or create those %-encodings on the web?, How do I redirect to
+another page?, How do I put a password on my web pages?, How do I edit my
+.htpasswd and .htgroup files with Perl?, How do I make sure users can't
+enter values into a form that cause my CGI script to do bad things?, How do
+I parse a mail header?, How do I decode a CGI form?, How do I check a valid
+mail address?, How do I decode a MIME/BASE64 string?, How do I return the
+user's mail address?, How do I send mail?, How do I read mail?, How do I
+find out my hostname/domainname/IP address?, How do I fetch a news article
+or the active newsgroups?, How do I fetch/put an FTP file?, How can I do
+RPC in Perl?
+
+=over 4
 
 =item Where to get this document
 
@@ -286,7 +276,7 @@ authors
 
 =item Author and Copyright Information
 
-=over
+=over 4
 
 =item Bundled Distributions
 
@@ -296,20 +286,21 @@ authors
 
 =item Changes
 
-23/May/99, 13/April/99, 7/January/99, 22/June/98, 24/April/97, 23/April/97,
-25/March/97, 18/March/97, 17/March/97 Version, Initial Release: 11/March/97
+1/November/2000, 23/May/99, 13/April/99, 7/January/99, 22/June/98,
+24/April/97, 23/April/97, 25/March/97, 18/March/97, 17/March/97 Version,
+Initial Release: 11/March/97
 
 =back
 
 =head2 perltoc - perl documentation table of contents
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item BASIC DOCUMENTATION
 
-=over
+=over 4
 
 =item perl - Practical Extraction and Report Language
 
@@ -319,7 +310,7 @@ DIAGNOSTICS, BUGS, NOTES
 =item perlfaq - frequently asked questions about Perl ($Date: 1999/05/23
 20:38:02 $)
 
-DESCRIPTION
+DESCRIPTION, Where to get this document, How to contribute
 
 =back
 
@@ -327,7 +318,7 @@ DESCRIPTION
 
 =head2 perlbook - Perl book information
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -335,11 +326,11 @@ DESCRIPTION
 
 =head2 perlsyn - Perl syntax
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Declarations
 
@@ -367,11 +358,11 @@ DESCRIPTION
 
 =head2 perldata - Perl data types
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Variable names
 
@@ -395,13 +386,13 @@ DESCRIPTION
 
 =head2 perlop - Perl operators and precedence
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Terms and List Operators (Leftward)
 
@@ -490,13 +481,13 @@ regular expressions
 
 =head2 perlsub - Perl subroutines
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Private Variables via my()
 
@@ -510,10 +501,6 @@ regular expressions
 
 =item When to Still Use local()
 
-1. You need to give a global variable a temporary value, especially $_, 2.
-You need to create a local file or directory handle or a local function, 3.
-You want to temporarily change just one element of an array or hash
-
 =item Pass by Reference
 
 =item Prototypes
@@ -534,11 +521,11 @@ You want to temporarily change just one element of an array or hash
 
 =head2 perlfunc - Perl builtin functions
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Perl Functions by Category
 
@@ -636,7 +623,7 @@ LIST, write FILEHANDLE, write EXPR, write, y///
 
 =head2 perlreftut - Mark's very short tutorial about references
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -646,7 +633,7 @@ LIST, write FILEHANDLE, write EXPR, write, y///
 
 =item Syntax
 
-=over
+=over 4
 
 =item Making References
 
@@ -666,7 +653,7 @@ LIST, write FILEHANDLE, write EXPR, write, y///
 
 =item Credits
 
-=over
+=over 4
 
 =item Distribution Conditions
 
@@ -676,7 +663,7 @@ LIST, write FILEHANDLE, write EXPR, write, y///
 
 =head2 perldsc - Perl Data Structures Cookbook
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -697,7 +684,7 @@ more elaborate constructs
 
 =item ARRAYS OF ARRAYS
 
-=over
+=over 4
 
 =item Declaration of a ARRAY OF ARRAYS
 
@@ -709,7 +696,7 @@ more elaborate constructs
 
 =item HASHES OF ARRAYS
 
-=over
+=over 4
 
 =item Declaration of a HASH OF ARRAYS
 
@@ -721,7 +708,7 @@ more elaborate constructs
 
 =item ARRAYS OF HASHES
 
-=over
+=over 4
 
 =item Declaration of a ARRAY OF HASHES
 
@@ -733,7 +720,7 @@ more elaborate constructs
 
 =item HASHES OF HASHES
 
-=over
+=over 4
 
 =item Declaration of a HASH OF HASHES
 
@@ -745,7 +732,7 @@ more elaborate constructs
 
 =item MORE ELABORATE RECORDS
 
-=over
+=over 4
 
 =item Declaration of MORE ELABORATE RECORDS
 
@@ -765,25 +752,18 @@ more elaborate constructs
 
 =head2 perlrequick - Perl regular expressions quick start
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item The Guide
 
-=over
+=over 4
 
 =item Simple word matching
 
 =item Using character classes
 
-\d is a digit and represents [0-9], \s is a whitespace character and
-represents [\ \t\r\n\f], \w is a word character (alphanumeric or _) and
-represents [0-9a-zA-Z_], \D is a negated \d; it represents any character
-but a digit [^0-9], \S is a negated \s; it represents any non-whitespace
-character [^\s], \W is a negated \w; it represents any non-word character
-[^\w], The period '.' matches any character but "\n"
-
 =item Matching this or that
 
 =item Grouping things and hierarchical matching
@@ -812,7 +792,7 @@ times
 
 =item AUTHOR AND COPYRIGHT
 
-=over
+=over 4
 
 =item Acknowledgments
 
@@ -822,11 +802,11 @@ times
 
 =head2 perlpod - plain old documentation
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Verbatim Paragraph
 
@@ -850,7 +830,7 @@ times
 
 =head2 perlstyle - Perl style guide
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -858,11 +838,11 @@ times
 
 =head2 perltrap - Perl traps for the unwary
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Awk Traps
 
@@ -943,13 +923,13 @@ LIMIT specified
 
 =head2 perlrun - how to execute the Perl interpreter
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item #! and quoting on non-Unix systems
 
@@ -979,7 +959,7 @@ PERL_ROOT (specific to the VMS port), SYS$LOGIN (specific to the VMS port)
 
 =head2 perldiag - various Perl diagnostics
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -987,11 +967,11 @@ PERL_ROOT (specific to the VMS port), SYS$LOGIN (specific to the VMS port)
 
 =head2 perllexwarn - Perl Lexical Warnings
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Default Warnings and Optional Warnings
 
@@ -1021,7 +1001,7 @@ B<-w>, B<-W>, B<-X>
 
 =head2 perldebtut - Perl debugging tutorial
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -1055,13 +1035,13 @@ B<-w>, B<-W>, B<-X>
 
 =head2 perldebug - Perl debugging
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item The Perl Debugger
 
-=over
+=over 4
 
 =item Debugger Commands
 
@@ -1113,11 +1093,11 @@ listing
 
 =head2 perlvar - Perl predefined variables
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Predefined Names
 
@@ -1163,7 +1143,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =head2 perllol - Manipulating Arrays of Arrays in Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -1183,13 +1163,13 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =head2 perlopentut - tutorial on opening things in Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Open E<agrave> la shell
 
-=over
+=over 4
 
 =item Simple Opens
 
@@ -1205,7 +1185,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =item Open E<agrave> la C
 
-=over
+=over 4
 
 =item Permissions E<agrave> la mode
 
@@ -1213,7 +1193,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =item Obscure Open Tricks
 
-=over
+=over 4
 
 =item Re-Opening Files (dups)
 
@@ -1229,7 +1209,7 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =item Other I/O Issues
 
-=over
+=over 4
 
 =item Opening Non-File Files
 
@@ -1249,109 +1229,35 @@ ${^WIDE_SYSTEM_CALLS}, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, @_, %INC,
 
 =head2 perlretut - Perl regular expressions tutorial
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Part 1: The basics
 
-=over
+=over 4
 
 =item Simple word matching
 
 =item Using character classes
 
-\d is a digit and represents [0-9], \s is a whitespace character and
-represents [\ \t\r\n\f], \w is a word character (alphanumeric or _) and
-represents [0-9a-zA-Z_], \D is a negated \d; it represents any character
-but a digit [^0-9], \S is a negated \s; it represents any non-whitespace
-character [^\s], \W is a negated \w; it represents any non-word character
-[^\w], The period '.' matches any character but "\n", no modifiers (//):
-Default behavior.  C<'.'> matches any character except C<"\n">.  C<^>
-matches only at the beginning of the string and C<$> matches only at the
-end or before a newline at the end, s modifier (//s): Treat string as a
-single long line.  C<'.'> matches any character, even C<"\n">. C<^>
-matches only at the beginning of the string and C<$> matches only at the
-end or before a newline at the end, m modifier (//m): Treat string as a set
-of multiple lines.  C<'.'> matches any character except C<"\n">.  C<^> and
-C<$> are able to match at the start or end of I<any> line within the
-string, both s and m modifiers (//sm): Treat string as a single long line,
-but detect multiple lines.  C<'.'> matches any character, even C<"\n">. 
-C<^> and C<$>, however, are able to match at the start or end of I<any>
-line within the string
-
 =item Matching this or that
 
 =item Grouping things and hierarchical matching
 
-0 Start with the first letter in the string 'a', 1 Try the first
-alternative in the first group 'abd', 2 Match 'a' followed by 'b'. So far
-so good, 3 'd' in the regexp doesn't match 'c' in the string - a dead end. 
-So backtrack two characters and pick the second alternative in the first
-group 'abc', 4 Match 'a' followed by 'b' followed by 'c'.  We are on a roll
-and have satisfied the first group. Set $1 to 'abc', 5 Move on to the
-second group and pick the first alternative 'df', 6 Match the 'd', 7 'f' in
-the regexp doesn't match 'e' in the string, so a dead end.  Backtrack one
-character and pick the second alternative in the second group 'd', 8 'd'
-matches. The second grouping is satisfied, so set $2 to 'd', 9 We are at
-the end of the regexp, so we are done! We have matched 'abcd' out of the
-string "abcde"
-
 =item Extracting matches
 
 =item Matching repetitions
 
-C<a?> = match 'a' 1 or 0 times, C<a*> = match 'a' 0 or more times, i.e.,
-any number of times, C<a+> = match 'a' 1 or more times, i.e., at least
-once, C<a{n,m}> = match at least C<n> times, but not more than C<m> times,
-C<a{n,}> = match at least C<n> or more times, C<a{n}> = match exactly C<n>
-times, Principle 0: Taken as a whole, any regexp will be matched at the
-earliest possible position in the string, Principle 1: In an alternation
-C<a|b|c...>, the leftmost alternative that allows a match for the whole
-regexp will be the one used, Principle 2: The maximal matching quantifiers
-C<?>, C<*>, C<+> and C<{n,m}> will in general match as much of the string
-as possible while still allowing the whole regexp to match, Principle 3: If
-there are two or more elements in a regexp, the leftmost greedy quantifier,
-if any, will match as much of the string as possible while still allowing
-the whole regexp to match.  The next leftmost greedy quantifier, if any,
-will try to match as much of the string remaining available to it as
-possible, while still allowing the whole regexp to match.  And so on, until
-all the regexp elements are satisfied, C<a??> = match 'a' 0 or 1 times. Try
-0 first, then 1, C<a*?> = match 'a' 0 or more times, i.e., any number of
-times, but as few times as possible, C<a+?> = match 'a' 1 or more times,
-i.e., at least once, but as few times as possible, C<a{n,m}?> = match at
-least C<n> times, not more than C<m> times, as few times as possible,
-C<a{n,}?> = match at least C<n> times, but as few times as possible,
-C<a{n}?> = match exactly C<n> times.  Because we match exactly C<n> times,
-C<a{n}?> is equivalent to C<a{n}> and is just there for notational
-consistency, Principle 3: If there are two or more elements in a regexp,
-the leftmost greedy (non-greedy) quantifier, if any, will match as much
-(little) of the string as possible while still allowing the whole regexp to
-match. The next leftmost greedy (non-greedy) quantifier, if any, will try
-to match as much (little) of the string remaining available to it as
-possible, while still allowing the whole regexp to match.  And so on, until
-all the regexp elements are satisfied, 0 Start with the first letter in the
-string 't', 1 The first quantifier '.*' starts out by matching the whole
-string 'the cat in the hat', 2 'a' in the regexp element 'at' doesn't match
-the end of the string. Backtrack one character, 3 'a' in the regexp
-element 'at' still doesn't match the last letter of the string 't', so
-backtrack one more character, 4 Now we can match the 'a' and the 't', 5
-Move on to the third element '.*'.  Since we are at the end of the string
-and '.*' can match 0 times, assign it the empty string, 6 We are done!
-
 =item Building a regexp
 
-specifying the task in detail,, breaking down the problem into smaller
-parts,, translating the small parts into regexps,, combining the regexps,,
-and optimizing the final combined regexp
-
 =item Using regular expressions in Perl
 
 =back
 
 =item Part 2: Power tools
 
-=over
+=over 4
 
 =item More on characters, strings, and character classes
 
@@ -1379,7 +1285,7 @@ and optimizing the final combined regexp
 
 =item AUTHOR AND COPYRIGHT
 
-=over
+=over 4
 
 =item Acknowledgments
 
@@ -1389,13 +1295,13 @@ and optimizing the final combined regexp
 
 =head2 perlre - Perl regular expressions
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 i, m, s, x
 
-=over
+=over 4
 
 =item Regular Expressions
 
@@ -1435,13 +1341,13 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perlref - Perl references and nested data structures
 
-=over
+=over 4
 
 =item NOTE
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Making References
 
@@ -1465,11 +1371,11 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perlform - Perl formats
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Format Variables
 
@@ -1477,7 +1383,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item NOTES
 
-=over
+=over 4
 
 =item Footers
 
@@ -1491,11 +1397,11 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perlboot - Beginner's Object-Oriented Tutorial
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item If we could talk to the animals...
 
@@ -1549,13 +1455,13 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perltoot - Tom's object-oriented tutorial for perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Creating a Class
 
-=over
+=over 4
 
 =item Object Representation
 
@@ -1573,7 +1479,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item Class Data
 
-=over
+=over 4
 
 =item Accessing Class Data
 
@@ -1589,7 +1495,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item Inheritance
 
-=over
+=over 4
 
 =item Overridden Methods
 
@@ -1601,7 +1507,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item Alternate Object Representations
 
-=over
+=over 4
 
 =item Arrays as Objects
 
@@ -1611,7 +1517,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item AUTOLOAD: Proxy Methods
 
-=over
+=over 4
 
 =item Autoloaded Data Methods
 
@@ -1621,14 +1527,18 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item Metaclassical Tools
 
-=over
+=over 4
 
 =item Class::Struct
 
 =item Data Members as Variables
 
+=back
+
 =item NOTES
 
+=over 4
+
 =item Object Terminology
 
 =back
@@ -1639,7 +1549,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item COPYRIGHT
 
-=over
+=over 4
 
 =item Acknowledgments
 
@@ -1649,13 +1559,13 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perltootc - Tom's OO Tutorial for Class Data in Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Class Data as Package Variables
 
-=over
+=over 4
 
 =item Putting All Your Eggs in One Basket
 
@@ -1673,7 +1583,7 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =item Class Data as Lexical Variables
 
-=over
+=over 4
 
 =item Privacy and Responsibility 
 
@@ -1701,11 +1611,11 @@ C<(?(condition)yes-pattern|no-pattern)>
 
 =head2 perlobj - Perl objects
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item An Object is Simply a Reference
 
@@ -1735,7 +1645,7 @@ isa(CLASS), can(METHOD), VERSION( [NEED] )
 
 =head2 perlbot - Bag'o Object Tricks (the BOT)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -1765,13 +1675,13 @@ isa(CLASS), can(METHOD), VERSION( [NEED] )
 
 =head2 perltie - how to hide an object class in a simple variable
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Tying Scalars
 
@@ -1781,7 +1691,10 @@ DESTROY this
 =item Tying Arrays
 
 TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value,
-UNTIE this, DESTROY this
+FETCHSIZE this, STORESIZE this, count, EXTEND this, count, EXISTS this,
+key, DELETE this, key, CLEAR this, PUSH this, LIST, POP this, SHIFT this,
+UNSHIFT this, LIST, SPLICE this, offset, length, LIST, UNTIE this, DESTROY
+this
 
 =item Tying Hashes
 
@@ -1812,7 +1725,7 @@ DESTROY this
 =head2 perlipc - Perl interprocess communication (signals, fifos, pipes,
 safe subprocesses, sockets, and semaphores)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -1820,7 +1733,7 @@ safe subprocesses, sockets, and semaphores)
 
 =item Named Pipes
 
-=over
+=over 4
 
 =item WARNING
 
@@ -1828,7 +1741,7 @@ safe subprocesses, sockets, and semaphores)
 
 =item Using open() for IPC
 
-=over
+=over 4
 
 =item Filehandles
 
@@ -1846,7 +1759,7 @@ safe subprocesses, sockets, and semaphores)
 
 =item Sockets: Client/Server Communication
 
-=over
+=over 4
 
 =item Internet Line Terminators
 
@@ -1858,7 +1771,7 @@ safe subprocesses, sockets, and semaphores)
 
 =item TCP Clients with IO::Socket
 
-=over
+=over 4
 
 =item A Simple Client
 
@@ -1890,13 +1803,13 @@ Proto, LocalPort, Listen, Reuse
 
 =head2 perlfork - Perl's fork() emulation
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Behavior of other Perl features in forked pseudo-processes
 
@@ -1928,7 +1841,7 @@ application, Thread-safety of extensions
 
 =head2 perlnumber - semantics of numbers and numeric operations in Perl
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -1953,7 +1866,7 @@ string
 
 =head2 perlthrtut - tutorial on threads in Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -1961,7 +1874,7 @@ string
 
 =item Threaded Program Models
 
-=over
+=over 4
 
 =item Boss/Worker
 
@@ -1979,7 +1892,7 @@ string
 
 =item Thread Basics
 
-=over
+=over 4
 
 =item Basic Thread Support
 
@@ -1997,7 +1910,7 @@ string
 
 =item Threads And Data
 
-=over
+=over 4
 
 =item Shared And Unshared Data
 
@@ -2013,7 +1926,7 @@ string
 
 =item Threads And Code
 
-=over
+=over 4
 
 =item Semaphores: Synchronizing Data Access
 
@@ -2031,7 +1944,7 @@ Basic semaphores, Advanced Semaphores
 
 =item General Thread Utility Routines
 
-=over
+=over 4
 
 =item What Thread Am I In?
 
@@ -2049,7 +1962,7 @@ Basic semaphores, Advanced Semaphores
 
 =item Bibliography
 
-=over
+=over 4
 
 =item Introductory Texts
 
@@ -2069,7 +1982,7 @@ Basic semaphores, Advanced Semaphores
 
 =head2 perlport - Writing portable Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -2078,7 +1991,7 @@ portable
 
 =item ISSUES
 
-=over
+=over 4
 
 =item Newlines
 
@@ -2115,7 +2028,7 @@ http://testers.cpan.org/
 
 =item PLATFORMS
 
-=over
+=over 4
 
 =item Unix
 
@@ -2139,7 +2052,7 @@ Build instructions for OS/2, L<perlos2>
 
 =item FUNCTION IMPLEMENTATIONS
 
-=over
+=over 4
 
 =item Alphabetical Listing of Perl Functions
 
@@ -2193,7 +2106,7 @@ v1.23, 10 July 1998
 =head2 perllocale - Perl locale handling (internationalization and
 localization)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -2201,7 +2114,7 @@ localization)
 
 =item USING LOCALES
 
-=over
+=over 4
 
 =item The use locale pragma
 
@@ -2225,7 +2138,7 @@ localization)
 
 =item LOCALE CATEGORIES
 
-=over
+=over 4
 
 =item Category LC_COLLATE: Collation
 
@@ -2243,15 +2156,6 @@ localization)
 
 =item SECURITY
 
-B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):,
-B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>),
-B<Matching operator> (C<m//>):, B<Substitution operator> (C<s///>):,
-B<Output formatting functions> (printf() and write()):, B<Case-mapping
-functions> (lc(), lcfirst(), uc(), ucfirst()):, B<POSIX locale-dependent
-functions> (localeconv(), strcoll(), strftime(), strxfrm()):, B<POSIX
-character class tests> (isalnum(), isalpha(), isdigit(), isgraph(),
-islower(), isprint(), ispunct(), isspace(), isupper(), isxdigit()):
-
 =item ENVIRONMENT
 
 PERL_BADLANG, LC_ALL, LANGUAGE, LC_CTYPE, LC_COLLATE, LC_MONETARY,
@@ -2259,7 +2163,7 @@ LC_NUMERIC, LC_TIME, LANG
 
 =item NOTES
 
-=over
+=over 4
 
 =item Backward compatibility
 
@@ -2279,7 +2183,7 @@ LC_NUMERIC, LC_TIME, LANG
 
 =item BUGS
 
-=over
+=over 4
 
 =item Broken systems
 
@@ -2293,11 +2197,11 @@ LC_NUMERIC, LC_TIME, LANG
 
 =head2 perlunicode - Unicode support in Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Important Caveat
 
@@ -2320,13 +2224,13 @@ to enable a few features
 
 =head2 perlebcdic - Considerations for running Perl on EBCDIC platforms
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item COMMON CHARACTER CODE SETS
 
-=over
+=over 4
 
 =item ASCII
 
@@ -2354,7 +2258,7 @@ recipe 0, recipe 1, recipe 2, recipe 3, recipe 4
 
 =item CONVERSIONS
 
-=over
+=over 4
 
 =item tr///
 
@@ -2376,7 +2280,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack()
 
 =item SORTING
 
-=over
+=over 4
 
 =item Ignore ASCII vs. EBCDIC sort differences.
 
@@ -2390,7 +2294,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack()
 
 =item TRANFORMATION FORMATS
 
-=over
+=over 4
 
 =item URL decoding and encoding
 
@@ -2410,7 +2314,7 @@ chr(), ord(), pack(), print(), printf(), sort(), sprintf(), unpack()
 
 =item OS ISSUES
 
-=over
+=over 4
 
 =item OS/400 
 
@@ -2438,11 +2342,11 @@ chcp, dataset access, OS/390 iconv, locales
 
 =head2 perlsec - Perl security
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Laundering and Detecting Tainted Data
 
@@ -2462,11 +2366,11 @@ chcp, dataset access, OS/390 iconv, locales
 
 =head2 perlmod - Perl modules (packages and symbol tables)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Packages
 
@@ -2486,49 +2390,51 @@ chcp, dataset access, OS/390 iconv, locales
 
 =head2 perlmodlib - constructing new Perl modules and finding existing ones
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item THE PERL MODULE LIBRARY
 
-=over
+=over 4
 
 =item Pragmatic Modules
 
 attributes, attrs, autouse, base, blib, bytes, charnames, constant,
-diagnostics, fields, filetest, integer, less, lib, locale, open, ops,
-overload, re, sigtrap, strict, subs, utf8, vars, warnings
+diagnostics, fields, filetest, integer, less, locale, open, ops, overload,
+perlio, re, sigtrap, strict, subs, utf8, vars, warnings, warnings::register
 
 =item Standard Modules
 
 AnyDBM_File, AutoLoader, AutoSplit, B, B::Asmdata, B::Assembler, B::Bblock,
 B::Bytecode, B::C, B::CC, B::Debug, B::Deparse, B::Disassembler, B::Lint,
-B::Showlex, B::Stackobj, B::Terse, B::Xref, Benchmark, ByteLoader, CGI,
-CGI::Apache, CGI::Carp, CGI::Cookie, CGI::Fast, CGI::Pretty, CGI::Push,
-CGI::Switch, CPAN, CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy,
-Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, DirHandle, Dumpvalue,
-English, Env, Exporter, Exporter::Heavy, ExtUtils::Command,
-ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed, ExtUtils::Liblist,
-ExtUtils::MM_Cygwin, ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS,
-ExtUtils::MM_Win32, ExtUtils::MakeMaker, ExtUtils::Manifest,
-ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::Packlist,
-ExtUtils::testlib, Fatal, Fcntl, File::Basename, File::CheckTree,
-File::Compare, File::Copy, File::DosGlob, File::Find, File::Path,
-File::Spec, File::Spec::Functions, File::Spec::Mac, File::Spec::OS2,
-File::Spec::Unix, File::Spec::VMS, File::Spec::Win32, File::Temp,
-File::stat, FileCache, FileHandle, FindBin, Getopt::Long, Getopt::Std,
+B::Showlex, B::Stackobj, B::Stash, B::Terse, B::Xref, Benchmark,
+ByteLoader, CGI, CGI::Apache, CGI::Carp, CGI::Cookie, CGI::Fast,
+CGI::Pretty, CGI::Push, CGI::Switch, CPAN, CPAN::FirstTime, CPAN::Nox,
+Carp, Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, DirHandle,
+Dumpvalue, Encode, English, Env, Exporter, Exporter::Heavy,
+ExtUtils::Command, ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed,
+ExtUtils::Liblist, ExtUtils::MM_Cygwin, ExtUtils::MM_OS2,
+ExtUtils::MM_Unix, ExtUtils::MM_VMS, ExtUtils::MM_Win32,
+ExtUtils::MakeMaker, ExtUtils::Manifest, ExtUtils::Mkbootstrap,
+ExtUtils::Mksymlists, ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl,
+File::Basename, File::CheckTree, File::Compare, File::Copy, File::DosGlob,
+File::Find, File::Path, File::Spec, File::Spec::Epoc,
+File::Spec::Functions, File::Spec::Mac, File::Spec::OS2, File::Spec::Unix,
+File::Spec::VMS, File::Spec::Win32, File::Temp, File::stat, FileCache,
+FileHandle, Filter::Simple, FindBin, Getopt::Long, Getopt::Std,
 I18N::Collate, IO, IPC::Open2, IPC::Open3, Math::BigFloat, Math::BigInt,
 Math::Complex, Math::Trig, NDBM_File, Net::Ping, Net::hostent, Net::netent,
 Net::protoent, Net::servent, O, ODBM_File, Opcode, Pod::Checker, Pod::Find,
-Pod::Html, Pod::InputObjects, Pod::Man, Pod::ParseUtils, Pod::Parser,
-Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, Pod::Text::Termcap,
-Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell,
-Socket, Symbol, Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine,
-Test, Test::Harness, Text::Abbrev, Text::ParseWords, Text::Soundex,
-Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash, Tie::RefHash, Tie::Scalar,
-Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, Time::tm,
-UNIVERSAL, User::grent, User::pwent
+Pod::Html, Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils,
+Pod::Parser, Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color,
+Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver,
+SelfLoader, Shell, Socket, Storable, Symbol, Term::ANSIColor, Term::Cap,
+Term::Complete, Term::ReadLine, Test, Test::Harness, Text::Abbrev,
+Text::ParseWords, Text::Soundex, Text::Wrap, Tie::Array, Tie::Handle,
+Tie::Hash, Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local,
+Time::gmtime, Time::localtime, Time::tm, UNIVERSAL, User::grent,
+User::pwent
 
 =item Extension Modules
 
@@ -2536,24 +2442,12 @@ UNIVERSAL, User::grent, User::pwent
 
 =item CPAN
 
-Language Extensions and Documentation Tools, Development Support, Operating
-System Interfaces, Networking, Device Control (modems) and InterProcess
-Communication, Data Types and Data Type Utilities, Database Interfaces,
-User Interfaces, Interfaces to / Emulations of Other Programming Languages,
-File Names, File Systems and File Locking (see also File Handles), String
-Processing, Language Text Processing, Parsing, and Searching, Option,
-Argument, Parameter, and Configuration File Processing,
-Internationalization and Locale, Authentication, Security, and Encryption,
-World Wide Web, HTML, HTTP, CGI, MIME, Server and Daemon Utilities,
-Archiving and Compression, Images, Pixmap and Bitmap Manipulation, Drawing,
-and Graphing, Mail and Usenet News, Control Flow Utilities (callbacks and
-exceptions etc), File Handle and Input/Output Stream Utilities,
-Miscellaneous Modules, Africa, Asia, Australasia, Central America, Europe,
-North America, South America
+Africa, Asia, Australasia, Central America, Europe, North America, South
+America
 
 =item Modules: Creation, Use, and Abuse
 
-=over
+=over 4
 
 =item Guidelines for Module Creation
 
@@ -2578,12 +2472,6 @@ to ::, Converts die(...) to croak(...), Several other minor changes
 
 =item Guidelines for Reusing Application Code
 
-Complete applications rarely belong in the Perl Module Library, Many
-applications contain some Perl code that could be reused, Break-out the
-reusable code into one or more separate module files, Take the opportunity
-to reconsider and redesign the interfaces, In some cases the 'application'
-can then be reduced to a small
-
 =back
 
 =item NOTE
@@ -2592,11 +2480,11 @@ can then be reduced to a small
 
 =head2 perlmodinstall - Installing CPAN Modules
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item PREAMBLE
 
@@ -2617,11 +2505,11 @@ module (sometimes unnecessary), B<INSTALL> the module
 
 =head2 perlnewmod - preparing a new module for distribution
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Warning
 
@@ -2653,11 +2541,11 @@ tarball, Announce to the modules list, Announce to clpa, Fix bugs!
 =head2 perlfaq1 - General Questions About Perl ($Revision: 1.23 $, $Date:
 1999/05/23 16:08:30 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item What is Perl?
 
@@ -2689,7 +2577,7 @@ Scheme, or Tcl?
 =item Where can I get a list of Larry Wall witticisms?
 
 =item How can I convince my sysadmin/supervisor/employees to use version
-(5/5.005/Perl instead of some other language)?
+5/5.005/Perl instead of some other language?
 
 =back
 
@@ -2700,11 +2588,11 @@ Scheme, or Tcl?
 =head2 perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.32 $,
 $Date: 1999/10/14 18:46:09 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item What machines support Perl?  Where do I get it?
 
@@ -2756,11 +2644,11 @@ References, Tutorials, Task-Oriented, Special Topics
 =head2 perlfaq3 - Programming Tools ($Revision: 1.38 $, $Date: 1999/05/23
 16:08:30 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How do I do (anything)?
 
@@ -2821,7 +2709,7 @@ References, Tutorials, Task-Oriented, Special Topics
 =item Where can I learn about linking C with Perl? [h2xs, xsubpp]
 
 =item I've read perlembed, perlguts, etc., but I can't embed perl in
-my C program, what am I doing wrong?
+my C program; what am I doing wrong?
 
 =item When I tried to run my script, I got this message. What does it
 mean?
@@ -2837,13 +2725,13 @@ mean?
 =head2 perlfaq4 - Data Manipulation ($Revision: 1.49 $, $Date: 1999/05/23
 20:37:49 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Data: Numbers
 
-=over
+=over 4
 
 =item Why am I getting long decimals (eg, 19.9499999999999) instead of the
 numbers I should be getting (eg, 19.95)?
@@ -2869,7 +2757,7 @@ Trig functions?
 
 =item Data: Dates
 
-=over
+=over 4
 
 =item How do I find the week-of-the-year/day-of-the-year?
 
@@ -2889,7 +2777,7 @@ Trig functions?
 
 =item Data: Strings
 
-=over
+=over 4
 
 =item How do I validate input?
 
@@ -2941,7 +2829,7 @@ the tag
 
 =item Data: Arrays
 
-=over
+=over 4
 
 =item What is the difference between a list and an array?
 
@@ -2949,11 +2837,7 @@ the tag
 
 =item How can I remove duplicate elements from a list or array?
 
-a) If @in is sorted, and you want @out to be sorted: (this assumes all true
-values in the array), b) If you don't know whether @in is sorted:, c) Like
-(b), but @in contains only small integers:, d) A way to do (b) without any
-loops or greps:, e) Like (d), but @in contains only small positive
-integers:
+a), b), c), d), e)
 
 =item How can I tell whether a list or array contains a certain element?
 
@@ -2986,7 +2870,7 @@ intersection of two arrays?
 
 =item Data: Hashes (Associative Arrays)
 
-=over
+=over 4
 
 =item How do I process an entire hash?
 
@@ -3025,7 +2909,7 @@ array of hashes or arrays?
 
 =item Data: Misc
 
-=over
+=over 4
 
 =item How do I handle binary data correctly?
 
@@ -3050,11 +2934,11 @@ array of hashes or arrays?
 =head2 perlfaq5 - Files and Formats ($Revision: 1.38 $, $Date: 1999/05/23
 16:08:30 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How do I flush/unbuffer an output filehandle?  Why must I do this?
 
@@ -3139,11 +3023,11 @@ protected files?  Isn't this a bug in Perl?
 
 =head2 perlfaq6 - Regexes ($Revision: 1.27 $, $Date: 1999/05/23 16:08:30 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How can I hope to use regular expressions without creating illegible
 and unmaintainable code?
@@ -3157,7 +3041,7 @@ different lines?
 
 =item I put a regular expression into $/ but it didn't work. What's wrong?
 
-=item How do I substitute case insensitively on the LHS, but preserving
+=item How do I substitute case insensitively on the LHS while preserving
 case on the RHS?
 
 =item How can I make C<\w> match national character sets?
@@ -3175,7 +3059,7 @@ file?
 
 =item What does it mean that regexes are greedy?  How can I get around it?
 
-=item  How do I process each word on each line?
+=item How do I process each word on each line?
 
 =item How can I print out a word-frequency or line-frequency summary?
 
@@ -3206,11 +3090,11 @@ file?
 =head2 perlfaq7 - Perl Language Issues ($Revision: 1.28 $, $Date:
 1999/05/23 20:36:18 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Can I get a BNF/yacc/RE for the Perl language?
 
@@ -3285,11 +3169,11 @@ is in scope?
 =head2 perlfaq8 - System Interaction ($Revision: 1.39 $, $Date: 1999/05/23
 18:37:57 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How do I find out which operating system I'm running under?
 
@@ -3333,7 +3217,7 @@ STDIN, STDOUT, and STDERR are shared, Signals, Zombies
 
 =item How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
 
-=item Why doesn't my sockets program work under System V (Solaris)? What
+=item Why doesn't my sockets program work under System V (Solaris)?  What
 does the error message "Protocol not supported" mean?
 
 =item How can I call my system's unique C functions from Perl?
@@ -3413,13 +3297,13 @@ search path?
 =head2 perlfaq9 - Networking ($Revision: 1.26 $, $Date: 1999/05/23 16:08:30
 $)
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
-=item My CGI script runs from the command line but not the browser.   (500
+=item My CGI script runs from the command line but not the browser.  (500
 Server Error)
 
 =item How can I get better error messages from a CGI program?
@@ -3478,11 +3362,11 @@ CGI script to do bad things?
 
 =head2 perlcompile - Introduction to the Perl Compiler-Translator 
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Layout
 
@@ -3492,7 +3376,7 @@ B::Bytecode, B::C, B::CC, B::Lint, B::Deparse, B::Xref
 
 =item Using The Back Ends
 
-=over
+=over 4
 
 =item The Cross Referencing Back End
 
@@ -3522,11 +3406,11 @@ B::Stash, B::Terse, B::Xref
 
 =head2 perlembed - how to embed perl in your C program
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item PREAMBLE
 
@@ -3556,7 +3440,7 @@ program
 
 =back
 
-=item Embedding Perl under Windows
+=item Embedding Perl under Win32
 
 =item MORAL
 
@@ -3568,13 +3452,13 @@ program
 
 =head2 perldebguts - Guts of Perl debugging 
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Debugger Internals
 
-=over
+=over 4
 
 =item Writing Your Own Debugger
 
@@ -3584,7 +3468,7 @@ program
 
 =item Debugging regular expressions
 
-=over
+=over 4
 
 =item Compile-time output
 
@@ -3601,7 +3485,7 @@ C<anchored(TYPE)>
 
 =item Debugging Perl memory usage
 
-=over
+=over 4
 
 =item Using C<$ENV{PERL_DEBUG_MSTATS}>
 
@@ -3627,13 +3511,13 @@ C<!!!>, C<!!>, C<!>
 
 =head2 perlxstut, perlXStut - Tutorial for writing XSUBs
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item SPECIAL NOTES
 
-=over
+=over 4
 
 =item make
 
@@ -3645,7 +3529,7 @@ C<!!!>, C<!!>, C<!>
 
 =item TUTORIAL
 
-=over
+=over 4
 
 =item EXAMPLE 1
 
@@ -3707,7 +3591,7 @@ C<!!!>, C<!!>, C<!>
 
 =item Author
 
-=over
+=over 4
 
 =item Last Changed
 
@@ -3717,11 +3601,11 @@ C<!!!>, C<!!>, C<!>
 
 =head2 perlxs - XS language reference manual
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Introduction
 
@@ -3759,7 +3643,7 @@ C<!!!>, C<!!>, C<!>
 
 =item The INPUT: Keyword
 
-=item The IN/OUTLIST/IN_OUTLIST Keywords
+=item The IN/OUTLIST/IN_OUTLIST/OUT/IN_OUT Keywords
 
 =item Variable-length Parameter Lists
 
@@ -3795,7 +3679,7 @@ C<!!!>, C<!!>, C<!>
 
 =item The & Unary Operator
 
-=item Inserting Comments and C Preprocessor Directives
+=item Inserting POD, Comments and C Preprocessor Directives
 
 =item Using XS With C++
 
@@ -3817,13 +3701,13 @@ C<!!!>, C<!!>, C<!>
 
 =head2 perlguts - Introduction to the Perl API
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Variables
 
-=over
+=over 4
 
 =item Datatypes
 
@@ -3879,7 +3763,7 @@ C<void save_hptr(HV **hptr)>
 
 =item Subroutines
 
-=over
+=over 4
 
 =item XSUBs and the Argument Stack
 
@@ -3899,7 +3783,7 @@ C<void save_hptr(HV **hptr)>
 
 =item Compiled code
 
-=over
+=over 4
 
 =item Code tree
 
@@ -3915,9 +3799,11 @@ C<void save_hptr(HV **hptr)>
 
 =back
 
+=item Examining internal data structures with the C<dump> functions
+
 =item How multiple interpreters and concurrency are supported
 
-=over
+=over 4
 
 =item Background and PERL_IMPLICIT_CONTEXT
 
@@ -3931,7 +3817,7 @@ C<void save_hptr(HV **hptr)>
 
 A, p, d, s, n, r, f, m, o, j, x
 
-=over
+=over 4
 
 =item Formatted Printing of IVs, UVs, and NVs
 
@@ -3943,7 +3829,7 @@ A, p, d, s, n, r, f, m, o, j, x
 
 =item Unicode Support
 
-=over
+=over 4
 
 =item What B<is> Unicode, anyway?
 
@@ -3967,7 +3853,7 @@ A, p, d, s, n, r, f, m, o, j, x
 
 =head2 perlcall - Perl calling conventions from C
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -3979,7 +3865,7 @@ call_sv, call_pv, call_method, call_argv
 
 =item FLAG VALUES
 
-=over
+=over 4
 
 =item  G_VOID
 
@@ -4003,7 +3889,7 @@ call_sv, call_pv, call_method, call_argv
 
 =item EXAMPLES
 
-=over
+=over 4
 
 =item No Parameters, Nothing returned
 
@@ -4053,11 +3939,11 @@ callback
 
 =head2 perlutil - utilities packaged with the Perl distribution
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item DOCUMENTATION
 
@@ -4083,7 +3969,7 @@ L<h2xs|h2xs>, L<dprofpp|dprofpp>, L<perlcc|perlcc>
 
 =head2 perlfilter - Source Filters
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -4115,7 +4001,7 @@ B<Decryption Filters>
 
 =head2 perldbmfilter - Perl DBM Filters
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -4124,7 +4010,7 @@ B<Decryption Filters>
 B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>,
 B<filter_fetch_value>
 
-=over
+=over 4
 
 =item The Filter
 
@@ -4142,16 +4028,16 @@ B<filter_fetch_value>
 
 =head2 perlapi - autogenerated documentation for the perl public API
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 AvFILL, av_clear, av_delete, av_exists, av_extend, av_fetch, av_fill,
 av_len, av_make, av_pop, av_push, av_shift, av_store, av_undef, av_unshift,
 bytes_to_utf8, call_argv, call_method, call_pv, call_sv, CLASS, Copy,
-croak, CvSTASH, dMARK, dORIGMARK, dSP, dXSARGS, dXSI32, ENTER, eval_pv,
-eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS, get_av, get_cv, get_hv,
-get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth, gv_fetchmethod,
+croak, CvSTASH, cv_const_sv, dMARK, dORIGMARK, dSP, dXSARGS, dXSI32, ENTER,
+eval_pv, eval_sv, EXTEND, fbm_compile, fbm_instr, FREETMPS, get_av, get_cv,
+get_hv, get_sv, GIMME, GIMME_V, GvSV, gv_fetchmeth, gv_fetchmethod,
 gv_fetchmethod_autoload, gv_stashpv, gv_stashsv, G_ARRAY, G_DISCARD,
 G_EVAL, G_NOARGS, G_SCALAR, G_VOID, HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV,
 HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, HvNAME, hv_clear, hv_delete,
@@ -4177,8 +4063,8 @@ SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only_UTF8, SvPV, SvPVX, SvPV_force,
 SvPV_nolen, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off,
 SvROK_on, SvRV, SvSETMAGIC, SvSetSV, SvSetSV_nosteal, SvSTASH, SvTAINT,
 SvTAINTED, SvTAINTED_off, SvTAINTED_on, SvTRUE, svtype, SvTYPE, SVt_IV,
-SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUPGRADE, SvUTF8,
-SvUTF8_off, SvUTF8_on, SvUV, SvUVX, sv_2mortal, sv_bless, sv_catpv,
+SVt_NV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SvUOK, SvUPGRADE,
+SvUTF8, SvUTF8_off, SvUTF8_on, SvUV, SvUVX, sv_2mortal, sv_bless, sv_catpv,
 sv_catpvf, sv_catpvf_mg, sv_catpvn, sv_catpvn_mg, sv_catpv_mg, sv_catsv,
 sv_catsv_mg, sv_chop, sv_clear, sv_cmp, sv_cmp_locale, sv_dec,
 sv_derived_from, sv_eq, sv_free, sv_gets, sv_grow, sv_inc, sv_insert,
@@ -4188,13 +4074,14 @@ sv_rvweaken, sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv,
 sv_setpvf, sv_setpvf_mg, sv_setpviv, sv_setpviv_mg, sv_setpvn,
 sv_setpvn_mg, sv_setpv_mg, sv_setref_iv, sv_setref_nv, sv_setref_pv,
 sv_setref_pvn, sv_setsv, sv_setsv_mg, sv_setuv, sv_setuv_mg, sv_true,
-sv_unmagic, sv_unref, sv_upgrade, sv_usepvn, sv_usepvn_mg,
+sv_unmagic, sv_unref, sv_unref_flags, sv_upgrade, sv_usepvn, sv_usepvn_mg,
 sv_utf8_downgrade, sv_utf8_encode, sv_utf8_upgrade, sv_vcatpvfn,
-sv_vsetpvfn, THIS, toLOWER, toUPPER, U8 *s, utf8_to_bytes, utf8_to_uv,
-utf8_to_uv_chk, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN,
-XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV,
-XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNO, XST_mNV, XST_mPV,
-XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
+sv_vsetpvfn, THIS, toLOWER, toUPPER, U8 *s, utf8_distance, utf8_hop,
+utf8_length, utf8_to_bytes, utf8_to_uv, utf8_to_uv_simple, warn, XPUSHi,
+XPUSHn, XPUSHp, XPUSHs, XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV,
+XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES,
+XST_mIV, XST_mNO, XST_mNV, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION,
+XS_VERSION_BOOTCHECK, Zero
 
 =item AUTHORS
 
@@ -4205,11 +4092,11 @@ XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
 =head2 perlintern - autogenerated documentation of purely B<internal>
                 Perl functions
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-is_gv_magical
+djSP, is_gv_magical, start_glob
 
 =item AUTHORS
 
@@ -4219,7 +4106,7 @@ is_gv_magical
 
 =head2 perlapio - perl's IO abstraction interface.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -4236,7 +4123,7 @@ B<PerlIO_clearerr(f)>, B<PerlIO_flush(f)>, B<PerlIO_tell(f)>,
 B<PerlIO_seek(f,o,w)>, B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>,
 B<PerlIO_rewind(f)>, B<PerlIO_tmpfile()>
 
-=over
+=over 4
 
 =item Co-existence with stdio
 
@@ -4253,13 +4140,13 @@ B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)>
 
 =head2 perltodo - Perl TO-DO List
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Infrastructure
 
-=over
+=over 4
 
 =item Mailing list archives
 
@@ -4274,7 +4161,7 @@ perl5
 
 =item Configure
 
-=over
+=over 4
 
 =item Install HTML
 
@@ -4282,9 +4169,7 @@ perl5
 
 =item Perl Language
 
-=over
-
-=item our ($var)
+=over 4
 
 =item 64-bit Perl
 
@@ -4296,7 +4181,7 @@ Named prototypes, Indirect objects, Method calls, Context, Scoped subs
 
 =item Perl Internals
 
-=over
+=over 4
 
 =item magic_setisa
 
@@ -4325,7 +4210,7 @@ sighandler, Add tests for Thread::Signal, Automatic tests against CPAN
 
 =item Documentation
 
-=over
+=over 4
 
 =item A clear division into tutorial and reference
 
@@ -4357,7 +4242,7 @@ Regular expressions, I/O, pack/unpack, Debugging
 
 =item Modules
 
-=over
+=over 4
 
 =item Update the POSIX extension to conform with the POSIX 1003.1 Edition 2
 
@@ -4395,8 +4280,6 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice
 
 =item Update semibroken auxiliary tools; h2ph, a2p, etc.
 
-=item POD Converters
-
 =item pod2html
 
 =item Podchecker
@@ -4405,7 +4288,7 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice
 
 =item Tom's Wishes
 
-=over
+=over 4
 
 =item Webperl
 
@@ -4419,7 +4302,7 @@ VecArray, SubstrArray, VirtualArray, ShiftSplice
 
 =item Win32 Stuff
 
-=over
+=over 4
 
 =item Rename new headers to be consistent with the rest
 
@@ -4441,7 +4324,7 @@ debugger, lvalue functions
 
 =item Possible pragmas
 
-=over
+=over 4
 
 =item 'less'
 
@@ -4449,7 +4332,7 @@ debugger, lvalue functions
 
 =item Optimizations
 
-=over
+=over 4
 
 =item constant function cache
 
@@ -4479,7 +4362,7 @@ threaded code, structured types, Modifiable $1 et al
 
 =item To Do Or Not To Do
 
-=over
+=over 4
 
 =item Making my() work on "package" variables
 
@@ -4493,7 +4376,7 @@ threaded code, structured types, Modifiable $1 et al
 
 =item Threading
 
-=over
+=over 4
 
 =item Modules
 
@@ -4515,7 +4398,7 @@ threaded code, structured types, Modifiable $1 et al
 
 =item Compiler
 
-=over
+=over 4
 
 =item Optimization
 
@@ -4541,7 +4424,7 @@ threaded code, structured types, Modifiable $1 et al
 
 =item Recently Finished Tasks
 
-=over
+=over 4
 
 =item Figure a way out of $^(capital letter)
 
@@ -4563,7 +4446,7 @@ threaded code, structured types, Modifiable $1 et al
 
 =head2 perlhack - How to hack at the Perl internals
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -4573,10 +4456,21 @@ the feature generic enough?, Does it potentially introduce new bugs?, Does
 it preclude other desirable features?, Is the implementation robust?, Is
 the implementation generic enough to be portable?, Is there enough
 documentation?, Is there another way to do it?, Does it create too much
-work?, Patches speak louder than words, L<perlguts>, L<perlxstut> and
-L<perlxs>, L<perlapi>, F<Porting/pumpkin.pod>, The perl5-porters FAQ
+work?, Patches speak louder than words
 
-=over
+=over 4
+
+=item Keeping in sync
+
+rsync'ing the source tree, Using rsync over the LAN, Using pushing over the
+NFS, rsync'ing the patches, It's easier, It's more recent, It's more
+reliable, It's easier, It's a good reference, Finding a start point,
+Finding how to fix a bug, Finding the source of misbehaviour
+
+=item Submitting patches
+
+L<perlguts>, L<perlxstut> and L<perlxs>, L<perlapi>,
+F<Porting/pumpkin.pod>, The perl5-porters FAQ
 
 =item Finding Your Way Around
 
@@ -4601,7 +4495,7 @@ Argument stack, Mark stack, Save stack
 =item Using a source-level debugger
 
 run [args], break function_name, break source.c:xxx, step, next, continue,
-finish, print
+finish, 'enter', print
 
 =item Dumping Perl Data Structures
 
@@ -4611,7 +4505,7 @@ finish, print
 
 =item EXTERNAL TOOLS FOR DEBUGGING PERL
 
-=over
+=over 4
 
 =item Rational Software's Purify
 
@@ -4635,7 +4529,7 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =head2 perlhist - the Perl history records
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -4643,7 +4537,7 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item THE KEEPERS OF THE PUMPKIN
 
-=over
+=over 4
 
 =item PUMPKIN?
 
@@ -4651,7 +4545,7 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item THE RECORDS
 
-=over
+=over 4
 
 =item SELECTED RELEASE SIZES
 
@@ -4665,7 +4559,7 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =head2 perldelta - what's new for perl v5.7.0
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -4677,7 +4571,7 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item Modules and Pragmata
 
-=over
+=over 4
 
 =item New Modules
 
@@ -4691,18 +4585,9 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item Performance Enhancements
 
-sort() has been changed to use mergesort internally as opposed to the
-earlier quicksort.  For very small lists this may result in slightly slower
-sorting times, but in general the speedup should be at least 20%. 
-Additional bonuses are that the worst case behaviour of sort() is now
-better (in computer science terms it now runs in time O(N log N), as
-opposed to quicksort's Theta(N**2) worst-case run time behaviour), and that
-sort() is now stable (meaning that elements with identical keys will stay
-ordered as they were before the sort)
-
 =item Installation and Configuration Improvements
 
-=over
+=over 4
 
 =item Generic Improvements
 
@@ -4710,10 +4595,7 @@ ordered as they were before the sort)
 
 =item Selected Bug Fixes
 
-sort() arguments are now compiled in the right wantarray context (they were
-accidentally using the context of the sort() itself)
-
-=over
+=over 4
 
 =item Platform Specific Changes and Fixes
 
@@ -4725,7 +4607,7 @@ accidentally using the context of the sort() itself)
 
 =item Known Problems
 
-=over
+=over 4
 
 =item Unicode Support Still Far From Perfect
 
@@ -4741,6 +4623,8 @@ accidentally using the context of the sort() itself)
 
 =item Linux With Sfio Fails op/misc Test 48
 
+=item sprintf tests 129 and 130
+
 =item Storable tests fail in some platforms
 
 =item Threads Are Still Experimental
@@ -4759,13 +4643,13 @@ accidentally using the context of the sort() itself)
 
 =head2 perl56delta, perldelta - what's new for perl v5.6.0
 
-=over
+=over 4
 
 =item DESCRIPTION
 
 =item Core Enhancements
 
-=over
+=over 4
 
 =item Interpreter cloning, threads, and concurrency
 
@@ -4881,7 +4765,7 @@ accidentally using the context of the sort() itself)
 
 =item Modules and Pragmata
 
-=over
+=over 4
 
 =item Modules
 
@@ -4900,7 +4784,7 @@ Term::ANSIColor, Time::Local, Win32, XSLoader, DBM Filters
 
 =item Utility Changes
 
-=over
+=over 4
 
 =item dprofpp
 
@@ -4925,7 +4809,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod
 
 =item Performance enhancements
 
-=over
+=over 4
 
 =item Simple sort() using { $a <=> $b } and the like are optimized
 
@@ -4939,7 +4823,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod
 
 =item Installation and Configuration Improvements
 
-=over
+=over 4
 
 =item -Dusethreads means something different
 
@@ -4965,7 +4849,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod
 
 =item Platform specific changes
 
-=over
+=over 4
 
 =item Supported platforms
 
@@ -4981,7 +4865,7 @@ perlreftut.pod, perltootc.pod, perltodo.pod, perlunicode.pod
 
 =item Significant bug fixes
 
-=over
+=over 4
 
 =item <HANDLE> on empty files
 
@@ -5072,7 +4956,7 @@ CLI symbol "%s" too long, Version number must be a constant number
 
 =item Incompatible Changes
 
-=over
+=over 4
 
 =item Perl Source Incompatibilities
 
@@ -5081,8 +4965,7 @@ Format of $English::PERL_VERSION is different, Literals of the form
 C<1.2.3> parse differently, Possibly changed pseudo-random number
 generator, Hashing function for hash keys has changed, C<undef> fails on
 read only values, Close-on-exec bit may be set on pipe and socket handles,
-Writing C<"$$1"> to mean C<"${$}1"> is unsupported, delete(), values() and
-C<\(%h)> operate on aliases to values, not copies, vec(EXPR,OFFSET,BITS)
+Writing C<"$$1"> to mean C<"${$}1"> is unsupported, vec(EXPR,OFFSET,BITS)
 enforces powers-of-two BITS, Text of some diagnostic output has changed,
 C<%@> has been removed, Parenthesized not() behaves like a list operator,
 Semantics of bareword prototype C<(*)> have changed, Semantics of bit
@@ -5103,7 +4986,7 @@ C<PATCHLEVEL> is now C<PERL_VERSION>
 
 =item Known Problems
 
-=over
+=over 4
 
 =item Thread test failures
 
@@ -5146,7 +5029,7 @@ to mean "${$}<digit>" is deprecated
 
 =head2 perl5005delta, perldelta - what's new for perl5.005
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -5154,7 +5037,7 @@ to mean "${$}<digit>" is deprecated
 
 =item Incompatible Changes
 
-=over
+=over 4
 
 =item WARNING: This version is not binary compatible with Perl 5.004.
 
@@ -5164,10 +5047,6 @@ to mean "${$}<digit>" is deprecated
 
 =item C Source Compatibility
 
-Core sources now require ANSI C compiler, All Perl global variables must
-now be referenced with an explicit prefix, Enabling threads has source
-compatibility issues
-
 =item Binary Compatibility
 
 =item Security fixes may affect compatibility
@@ -5180,7 +5059,7 @@ compatibility issues
 
 =item Core Changes
 
-=over
+=over 4
 
 =item Threads
 
@@ -5260,7 +5139,7 @@ improvements, Incompatible changes
 
 =item Supported Platforms
 
-=over
+=over 4
 
 =item New Platforms
 
@@ -5270,7 +5149,7 @@ improvements, Incompatible changes
 
 =item Modules and Pragmata
 
-=over
+=over 4
 
 =item New Modules
 
@@ -5305,9 +5184,9 @@ Eval-group not allowed at run time, Explicit blessing to '' (assuming
 package main), Illegal hex digit ignored, No such array field, No such
 field "%s" in variable %s of type %s, Out of memory during ridiculously
 large request, Range iterator outside integer range, Recursive inheritance
-detected while looking for method '%s' in package '%s', Reference found
-where even-sized list expected, Undefined value assigned to typeglob, Use
-of reserved word "%s" is deprecated, perl: warning: Setting locale failed
+detected while looking for method '%s' %s, Reference found where even-sized
+list expected, Undefined value assigned to typeglob, Use of reserved word
+"%s" is deprecated, perl: warning: Setting locale failed
 
 =item Obsolete Diagnostics
 
@@ -5326,7 +5205,7 @@ temporary file, regexp too big
 
 =head2 perl5004delta, perldelta - what's new for perl5.004
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -5334,11 +5213,11 @@ temporary file, regexp too big
 
 =item Core Changes
 
-=over
+=over 4
 
 =item List assignment to %ENV works
 
-=item "Can't locate Foo.pm in @INC" error now lists @INC
+=item Change to "Can't locate Foo.pm in @INC" error
 
 =item Compilation option: Binary compatibility with 5.003
 
@@ -5418,7 +5297,7 @@ LIST, READLINE this, GETC this, DESTROY this
 
 =item Support for More Operating Systems
 
-=over
+=over 4
 
 =item Win32
 
@@ -5437,7 +5316,7 @@ constant NAME => VALUE, use locale, use ops, use vmsish
 
 =item Modules
 
-=over
+=over 4
 
 =item Required Updates
 
@@ -5463,7 +5342,7 @@ constant NAME => VALUE, use locale, use ops, use vmsish
 
 =item Utility Changes
 
-=over
+=over 4
 
 =item pod2html
 
@@ -5504,14 +5383,14 @@ possible typo, Null picture in formline, Offset outside string, Out of
 memory!, Out of memory during request for %s, panic: frexp, Possible
 attempt to put comments in qw() list, Possible attempt to separate words
 with commas, Scalar value @%s{%s} better written as $%s{%s}, Stub found
-while resolving method `%s' overloading `%s' in package `%s', Too late for
-"B<-T>" option, untie attempted while %d inner references still exist,
-Unrecognized character %s, Unsupported function fork, Use of "$$<digit>" to
-mean "${$}<digit>" is deprecated, Value of %s can be "0"; test with
-defined(), Variable "%s" may be unavailable, Variable "%s" will not stay
-shared, Warning: something's wrong, Ill-formed logical name |%s| in
-prime_env_iter, Got an error from DosAllocMem, Malformed PERLLIB_PREFIX,
-PERL_SH_DIR too long, Process terminated by SIG%s
+while resolving method `%s' overloading `%s' in %s, Too late for "B<-T>"
+option, untie attempted while %d inner references still exist, Unrecognized
+character %s, Unsupported function fork, Use of "$$<digit>" to mean
+"${$}<digit>" is deprecated, Value of %s can be "0"; test with defined(),
+Variable "%s" may be unavailable, Variable "%s" will not stay shared,
+Warning: something's wrong, Ill-formed logical name |%s| in prime_env_iter,
+Got an error from DosAllocMem, Malformed PERLLIB_PREFIX, PERL_SH_DIR too
+long, Process terminated by SIG%s
 
 =item BUGS
 
@@ -5523,11 +5402,11 @@ PERL_SH_DIR too long, Process terminated by SIG%s
 
 =head2 perlaix, README.aix - Perl version 5 on IBM Unix (AIX) systems
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Compiling Perl 5 on AIX
 
@@ -5557,19 +5436,19 @@ PERL_SH_DIR too long, Process terminated by SIG%s
 
 =back
 
-=head2 perlamiga - Perl under Amiga OS (possibly very outdated information)
+=head2 perlamiga - Perl under Amiga OS
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =back
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Prerequisites
 
@@ -5590,7 +5469,7 @@ finally close()d
 
 =item Accessing documentation
 
-=over
+=over 4
 
 =item Manpages
 
@@ -5604,7 +5483,7 @@ finally close()d
 
 =item BUILD
 
-=over
+=over 4
 
 =item Prerequisites
 
@@ -5612,13 +5491,15 @@ finally close()d
 
 =item Making
 
+sh Configure -Dprefix=/ade -Dloclibpth=/ade/lib
+
 =item Testing
 
 =item Installing the built perl
 
 =back
 
-=item AUTHOR
+=item AUTHORS
 
 =item SEE ALSO
 
@@ -5626,13 +5507,13 @@ finally close()d
 
 =head2 perlcygwin, README.cygwin - Perl for Cygwin
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item PREREQUISITES
 
-=over
+=over 4
 
 =item Cygwin = GNU+Cygnus+Windows (Don't leave UNIX without it)
 
@@ -5644,7 +5525,7 @@ C<PATH>, I<nroff>, Permissions
 
 =item CONFIGURE
 
-=over
+=over 4
 
 =item Strip Binaries
 
@@ -5660,14 +5541,13 @@ C<-Duse64bitint>, C<-Duselongdouble>, C<-Dusethreads>, C<-Duselargefiles>
 
 =item Suspicious Warnings
 
-I<dlsym()>, Win9x and C<d_eofnblk>, Checking how std your stdio is..,
-Compiler/Preprocessor defines
+I<dlsym()>, Win9x and C<d_eofnblk>, Compiler/Preprocessor defines
 
 =back
 
 =item MAKE
 
-=over
+=over 4
 
 =item Warnings
 
@@ -5677,7 +5557,7 @@ Compiler/Preprocessor defines
 
 =item TEST
 
-=over
+=over 4
 
 =item File Permissions
 
@@ -5712,13 +5592,13 @@ Source, Compiled Module Source, Perl Modules/Scripts
 
 =head2 perldos - Perl under DOS, W31, W95.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Prerequisites
 
@@ -5734,20 +5614,70 @@ DJGPP, Pthreads
 
 =back
 
+=item BUILDING AND INSTALLING MODULES
+
+=over 4
+
+=item Prerequisites
+
+=item Unpacking CPAN Modules
+
+=item Building Non-XS Modules
+
+=item Building XS Modules
+
+=back
+
 =item AUTHOR
 
 =item SEE ALSO
 
 =back
 
+=head2 perlepoc, README.epoc - Perl for EPOC
+
+=over 4
+
+=item SYNOPSIS
+
+=item INTRODUCTION
+
+=item INSTALLING PERL ON EPOC
+
+=item USING PERL ON EPOC
+
+=over 4
+
+=item IO Redirection
+
+=item PATH Names
+
+=item Editors
+
+=item Features
+
+=item Restrictions
+
+=item Compiling Perl 5 on the EPOC cross compiling environment
+
+=back
+
+=item SUPPORT STATUS
+
+=item AUTHOR
+
+=item LAST UPDATE
+
+=back
+
 =head2 perlhpux, README.hpux - Perl version 5 on Hewlett-Packard Unix
 (HP-UX) systems
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Compiling Perl 5 on HP-UX
 
@@ -5788,11 +5718,11 @@ DJGPP, Pthreads
 =head2 perlmachten, README.machten - Perl version 5 on Power MachTen
 systems
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Compiling Perl 5 on MachTen
 
@@ -5810,15 +5740,43 @@ op/lexassign.t, pragma/warnings.t
 
 =back
 
+=head2 perlmpeix, README.mpeix - Perl/iX for HP e3000 MPE
+
+=head1 SYNOPSIS
+
+=over 4
+
+=item What's New
+
+=item System Requirements
+
+=item How to Obtain Perl/iX
+
+=item Distribution Contents Highlights
+
+README, public_html/feedback.cgi,  4,  6
+
+=item Getting Started with Perl/iX
+
+=item MPE/iX Implementation Considerations
+
+=item Change History
+
+=back
+
 =head2 perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =back
 
-=over
+=over 4
+
+=item DESCRIPTION
+
+=over 4
 
 =item Target
 
@@ -5834,11 +5792,9 @@ EMX, RSX, HPFS, pdksh
 
 =back
 
-=over
-
 =item Frequently asked questions
 
-=over
+=over 4
 
 =item I cannot run external programs
 
@@ -5856,7 +5812,7 @@ L<ExtUtils::Embed>?
 
 =item INSTALLATION
 
-=over
+=over 4
 
 =item Automatic binary installation
 
@@ -5876,7 +5832,7 @@ Perl manual in F<.INF> format, Pdksh
 
 =item Accessing documentation
 
-=over
+=over 4
 
 =item OS/2 F<.INF> file
 
@@ -5896,7 +5852,7 @@ Perl manual in F<.INF> format, Pdksh
 
 =item BUILD
 
-=over
+=over 4
 
 =item Prerequisites
 
@@ -5921,7 +5877,7 @@ F<lib/io_pipe.t>, F<lib/io_sock.t>, F<op/stat.t>, F<lib/io_udp.t>
 
 =item Build FAQ
 
-=over
+=over 4
 
 =item Some C</> became C<\> in pdksh.
 
@@ -5941,7 +5897,7 @@ F<lib/io_pipe.t>, F<lib/io_sock.t>, F<op/stat.t>, F<lib/io_udp.t>
 
 =item Specific (mis)features of OS/2 port
 
-=over
+=over 4
 
 =item C<setpriority>, C<getpriority>
 
@@ -5970,7 +5926,7 @@ C<popen>, C<tmpnam>, C<tmpfile>, C<ctermid>, C<stat>, C<flock>
 
 =item Perl flavors
 
-=over
+=over 4
 
 =item F<perl.exe>
 
@@ -5992,7 +5948,7 @@ explicit fork(), open FH, "|-", open FH, "-|"
 
 =item ENVIRONMENT
 
-=over
+=over 4
 
 =item C<PERLLIB_PREFIX>
 
@@ -6010,7 +5966,7 @@ explicit fork(), open FH, "|-", open FH, "-|"
 
 =item Evolution
 
-=over
+=over 4
 
 =item Priorities
 
@@ -6030,7 +5986,7 @@ C<COND_WAIT>, F<os2.c>
 
 =back
 
-=over
+=over 4
 
 =item AUTHOR
 
@@ -6040,13 +5996,13 @@ C<COND_WAIT>, F<os2.c>
 
 =head2 perlos390, README.os390 - building and installing Perl for OS/390.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Unpacking
 
@@ -6056,9 +6012,13 @@ C<COND_WAIT>, F<os2.c>
 
 =item Build, test, install
 
+=item build anomalies
+
+=item testing anomalies
+
 =item Usage Hints
 
-=item Extensions
+=item Modules and Extensions
 
 =back
 
@@ -6066,7 +6026,7 @@ C<COND_WAIT>, F<os2.c>
 
 =item SEE ALSO
 
-=over
+=over 4
 
 =item Mailing list
 
@@ -6079,13 +6039,13 @@ C<COND_WAIT>, F<os2.c>
 =head2 perlposix-bc, README.posix-bc - building and installing Perl for
 BS2000 POSIX.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item gzip
 
@@ -6107,7 +6067,7 @@ BS2000 POSIX.
 
 =item SEE ALSO
 
-=over
+=over 4
 
 =item Mailing list
 
@@ -6117,9 +6077,93 @@ BS2000 POSIX.
 
 =back
 
+=head2 perlsolaris, README.solaris - Perl version 5 on Solaris systems
+
+=over 4
+
+=item DESCRIPTION
+
+=over 4
+
+=item Solaris Version Numbers.
+
+=back
+
+=item RESOURCES
+
+Solaris FAQ, Precompiled Binaries, Solaris Documentation
+
+=item SETTING UP
+
+=over 4
+
+=item File Extraction Problems.
+
+=item Compiler and Related Tools.
+
+=item Environment
+
+=back
+
+=item RUN CONFIGURE.
+
+=over 4
+
+=item 64-bit Issues.
+
+=item Threads.
+
+=item Malloc Issues.
+
+=back
+
+=item MAKE PROBLEMS.
+
+Dynamic Loading Problems With GNU as and GNU ld, ld.so.1: ./perl: fatal:
+relocation error:, dlopen: stub interception failed, #error "No
+DATAMODEL_NATIVE specified", sh: ar: not found
+
+=item MAKE TEST
+
+=over 4
+
+=item op/stat.t test 4
+
+=back
+
+=item PREBUILT BINARIES.
+
+=item RUNTIME ISSUES.
+
+=over 4
+
+=item Limits on Numbers of Open Files.
+
+=back
+
+=item SOLARIS-SPECIFIC MODULES.
+
+=item SOLARIS-SPECIFIC PROBLEMS WITH MODULES.
+
+=over 4
+
+=item Proc::ProcessTable
+
+=item BSD::Resource
+
+=item Net::SSLeay
+
+=back
+
+=item AUTHOR
+
+=item LAST MODIFIED
+
+=back
+
 =head2 perlvms - VMS-specific documentation for Perl
 
-=over
+=over 4
 
 =item DESCRIPTION
 
@@ -6127,7 +6171,7 @@ BS2000 POSIX.
 
 =item Organization of Perl Images
 
-=over
+=over 4
 
 =item Core Images
 
@@ -6141,7 +6185,7 @@ BS2000 POSIX.
 
 =item File specifications
 
-=over
+=over 4
 
 =item Syntax
 
@@ -6155,7 +6199,7 @@ BS2000 POSIX.
 
 =item Command line
 
-=over
+=over 4
 
 =item I/O redirection and backgrounding
 
@@ -6178,7 +6222,7 @@ LIST, waitpid PID,FLAGS
 
 =item Standard modules with VMS-specific differences
 
-=over
+=over 4
 
 =item SDBM_File
 
@@ -6190,15 +6234,55 @@ LIST, waitpid PID,FLAGS
 
 =back
 
+=head2 perlvos, README.vos - Perl for Stratus VOS
+
+=over 4
+
+=item SYNOPSIS
+
+=over 4
+
+=item Stratus POSIX Support
+
+=back
+
+=item INSTALLING PERL IN VOS
+
+=over 4
+
+=item Compiling Perl 5 on VOS
+
+=item Installing Perl 5 on VOS
+
+=back
+
+=item USING PERL IN VOS
+
+=over 4
+
+=item Unimplemented Features
+
+=item Restrictions
+
+=back
+
+=item SUPPORT STATUS
+
+=item AUTHOR
+
+=item LAST UPDATE
+
+=back
+
 =head2 perlwin32 - Perl under Win32
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Setting Up
 
@@ -6222,6 +6306,10 @@ Extensions, Running Perl Scripts, Miscellaneous Things
 
 =item AUTHORS
 
+Gary Ng E<lt>71564.1743@CompuServe.COME<gt>, Gurusamy Sarathy
+E<lt>gsar@activestate.comE<gt>, Nick Ing-Simmons
+E<lt>nick@ing-simmons.netE<gt>
+
 =item SEE ALSO
 
 =item HISTORY
@@ -6232,7 +6320,7 @@ Extensions, Running Perl Scripts, Miscellaneous Things
 
 =head2 attrs - set/get attributes of a subroutine (deprecated)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6244,7 +6332,7 @@ method, locked
 
 =head2 re - Perl pragma to alter regular expression behaviour
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6254,13 +6342,13 @@ method, locked
 
 =head2 attributes - get/set subroutine or variable attributes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Built-in Attributes
 
@@ -6280,7 +6368,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES
 
 =item EXPORTS
 
-=over
+=over 4
 
 =item Default exports
 
@@ -6298,7 +6386,7 @@ FETCH_I<type>_ATTRIBUTES, MODIFY_I<type>_ATTRIBUTES
 
 =head2 attrs - set/get attributes of a subroutine (deprecated)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6310,7 +6398,7 @@ method, locked
 
 =head2 autouse - postpone load of modules until a function is used
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6326,7 +6414,7 @@ method, locked
 
 =head2 base - Establish IS-A relationship with base class at compile time
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6340,7 +6428,7 @@ method, locked
 
 =head2 blib - Use MakeMaker's uninstalled version of a package
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6355,7 +6443,7 @@ method, locked
 =head2 bytes - Perl pragma to force byte semantics rather than character
 semantics
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6368,7 +6456,7 @@ semantics
 =head2 charnames - define character names for C<\N{named}> string literal
 escape.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6382,7 +6470,7 @@ escape.
 
 =head2 constant - Perl pragma to declare constants
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6403,13 +6491,13 @@ escape.
 =head2 diagnostics - Perl compiler pragma to force verbose warning
 diagnostics
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item The C<diagnostics> Pragma
 
@@ -6429,7 +6517,7 @@ diagnostics
 
 =head2 fields - compile-time class fields
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6443,13 +6531,13 @@ new, phash
 
 =head2 filetest - Perl pragma to control the filetest permission operators
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item subpragma access
 
@@ -6460,7 +6548,7 @@ new, phash
 =head2 integer - Perl pragma to compute arithmetic in integer instead of
 double
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6470,7 +6558,7 @@ double
 
 =head2 less - perl pragma to request less of something from the compiler
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6480,13 +6568,13 @@ double
 
 =head2 lib - manipulate @INC at compile time
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Adding directories to @INC
 
@@ -6505,7 +6593,7 @@ double
 =head2 locale - Perl pragma to use and avoid POSIX locales for built-in
 operations
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6515,7 +6603,7 @@ operations
 
 =head2 open - perl pragma to set default disciplines for input and output
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6529,7 +6617,7 @@ operations
 
 =head2 ops - Perl pragma to restrict unsafe operations when compiling
 
-=over
+=over 4
 
 =item SYNOPSIS 
 
@@ -6541,13 +6629,13 @@ operations
 
 =head2 overload - Package for overloading perl operations
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Declaration of overloaded functions
 
@@ -6576,7 +6664,7 @@ is inherited by derived classes
 
 =item SPECIAL SYMBOLS FOR C<use overload>
 
-=over
+=over 4
 
 =item Last Resort
 
@@ -6615,7 +6703,7 @@ integer, float, binary, q, qr
 
 =item Cookbook
 
-=over
+=over 4
 
 =item Two-face scalars
 
@@ -6638,9 +6726,29 @@ type, `%s' is not a code reference
 
 =back
 
+=head2 perlio - perl pragma to configure C level IO
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+unix, stdio, perlio
+
+=over 4
+
+=item Defaults and how to override them
+
+=back
+
+=item AUTHOR
+
+=back
+
 =head2 re - Perl pragma to alter regular expression behaviour
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6650,7 +6758,7 @@ type, `%s' is not a code reference
 
 =head2 sigtrap - Perl pragma to enable simple signal handling
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6658,7 +6766,7 @@ type, `%s' is not a code reference
 
 =item OPTIONS
 
-=over
+=over 4
 
 =item SIGNAL HANDLERS
 
@@ -6680,7 +6788,7 @@ B<untrapped>, B<any>, I<signal>, I<number>
 
 =head2 strict - Perl pragma to restrict unsafe constructs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6692,17 +6800,30 @@ C<strict refs>, C<strict vars>, C<strict subs>
 
 =head2 subs - Perl pragma to predeclare sub names
 
-=over
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=back
+
+=head2 unicode::distinct - Perl pragma to strictly distinguish UTF8 data
+and non-UTF data.
+
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
+=item SEE ALSO
+
 =back
 
 =head2 utf8 - Perl pragma to enable/disable UTF-8 in source code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6714,7 +6835,7 @@ C<strict refs>, C<strict vars>, C<strict subs>
 
 =head2 vars - Perl pragma to predeclare global variable names (obsolete)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6724,7 +6845,7 @@ C<strict refs>, C<strict vars>, C<strict subs>
 
 =head2 warnings - Perl pragma to control optional warnings
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6744,13 +6865,13 @@ warnings::warnif($object, $message)
 
 =head2 AnyDBM_File - provide framework for multiple DBMs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item DBM Comparisons
 
@@ -6764,13 +6885,13 @@ warnings::warnif($object, $message)
 
 =head2 AutoLoader - load subroutines only on demand
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Subroutine Stubs
 
@@ -6794,7 +6915,7 @@ warnings::warnif($object, $message)
 
 =head2 AutoSplit - split a package for autoloading
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6802,7 +6923,7 @@ warnings::warnif($object, $message)
 
 $keep, $check, $modtime
 
-=over
+=over 4
 
 =item Multiple packages
 
@@ -6814,7 +6935,7 @@ $keep, $check, $modtime
 
 =head2 B - The Perl Compiler
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6822,7 +6943,7 @@ $keep, $check, $modtime
 
 =item OVERVIEW OF CLASSES
 
-=over
+=over 4
 
 =item SV-RELATED CLASSES
 
@@ -6879,7 +7000,7 @@ FILL, MAX, OFF, ARRAY, AvFLAGS
 =item B::CV METHODS
 
 STASH, START, ROOT, GV, FILE, DEPTH, PADLIST, OUTSIDE, XSUB, XSUBANY,
-CvFLAGS
+CvFLAGS, const_sv
 
 =item B::HV METHODS
 
@@ -6947,7 +7068,7 @@ hash(STR), cast_I32(I), minus_c, cstring(STR), class(OBJ), threadsv_names
 =head2 B::Asmdata - Autogenerated data about Perl ops, used to generate
 bytecode
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6959,7 +7080,7 @@ bytecode
 
 =head2 B::Assembler - Assemble Perl bytecode
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6971,7 +7092,7 @@ bytecode
 
 =head2 B::Bblock - Walk basic blocks
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -6983,7 +7104,7 @@ bytecode
 
 =head2 B::Bytecode - Perl compiler's bytecode backend
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7006,7 +7127,7 @@ output.    =back
 
 =head2 B::C - Perl compiler's C backend
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7027,7 +7148,7 @@ B<-DC>, B<-DM>, B<-f>, B<-fcog>, B<-fno-cog>, B<-On>, B<-llimit>
 
 =head2 B::CC - Perl compiler's optimized C translation backend
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7045,7 +7166,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On>
 
 =item DIFFERENCES
 
-=over
+=over 4
 
 =item Loops
 
@@ -7063,7 +7184,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On>
 
 =head2 B::Debug - Walk Perl syntax tree, printing debug info about ops
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7075,7 +7196,7 @@ B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On>
 
 =head2 B::Deparse - Perl compiler backend to produce perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7088,7 +7209,7 @@ B<T>, B<v>I<STRING>B<.>
 
 =item USING B::Deparse AS A MODULE
 
-=over
+=over 4
 
 =item Synopsis
 
@@ -7108,7 +7229,7 @@ B<T>, B<v>I<STRING>B<.>
 
 =head2 B::Disassembler - Disassemble Perl bytecode
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7120,7 +7241,7 @@ B<T>, B<v>I<STRING>B<.>
 
 =head2 B::Lint - Perl lint
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7143,7 +7264,7 @@ B<-u Package>
 
 =head2 B::O, O - Generic interface to Perl Compiler backends
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7159,7 +7280,7 @@ B<-u Package>
 
 =head2 B::Showlex - Show lexical variables used in functions or files
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7171,7 +7292,7 @@ B<-u Package>
 
 =head2 B::Stackobj - Helper module for CC backend
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7185,7 +7306,7 @@ B<-u Package>
 
 =head2 B::Terse - Walk Perl syntax tree, printing terse info about ops
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7197,7 +7318,7 @@ B<-u Package>
 
 =head2 B::Xref - Generates cross reference reports for Perl programs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7215,7 +7336,7 @@ C<-oFILENAME>, C<-r>, C<-D[tO]>
 
 =head2 Bblock, B::Bblock - Walk basic blocks
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7227,13 +7348,13 @@ C<-oFILENAME>, C<-r>, C<-D[tO]>
 
 =head2 Benchmark - benchmark running times of Perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Methods
 
@@ -7271,7 +7392,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache (
 
 =head2 ByteLoader - load byte compiled perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7285,7 +7406,7 @@ STYLE ] ), cmpthese ( RESULTSHASHREF ), countit(TIME, CODE), disablecache (
 
 =head2 Bytecode, B::Bytecode - Perl compiler's bytecode backend
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7308,7 +7429,7 @@ output.    =back
 
 =head2 CGI - Simple Common Gateway Interface Class
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7316,16 +7437,12 @@ output.    =back
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item PROGRAMMING STYLE
 
 =item CALLING CGI.PM ROUTINES
 
-1. Use another name for the argument, if one is available.  For example,
--value is an alias for -values, 2. Change the capitalization, e.g. -Values,
-3. Put quotes around the argument name, e.g. '-values'
-
 =item CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
 
 =item CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
@@ -7374,7 +7491,7 @@ a </UL> tag)
 
 =item GENERATING DYNAMIC DOCUMENTS
 
-=over
+=over 4
 
 =item CREATING A STANDARD HTTP HEADER:
 
@@ -7399,7 +7516,7 @@ B<-absolute>, B<-relative>, B<-full>, B<-path> (B<-path_info>), B<-query>
 
 =item CREATING STANDARD HTML ELEMENTS:
 
-=over
+=over 4
 
 =item PROVIDING ARGUMENTS TO HTML SHORTCUTS
 
@@ -7420,7 +7537,7 @@ charset([$charset]);, $flag = autoEscape([$flag]);
 
 =item CREATING FILL-OUT FORMS:
 
-=over
+=over 4
 
 =item CREATING AN ISINDEX TAG
 
@@ -7472,8 +7589,7 @@ B<Parameters:>
 
 =item CREATING A CLICKABLE IMAGE BUTTON
 
-B<Parameters:>, 3. The third option (-align, optional) is an alignment
-type, and may be TOP, BOTTOM or MIDDLE
+B<Parameters:>
 
 =item CREATING A JAVASCRIPT ACTION BUTTON
 
@@ -7494,7 +7610,7 @@ the <FORM> tag
 
 =item DEBUGGING
 
-=over
+=over 4
 
 =item DUMPING OUT ALL THE NAME/VALUE PAIRS
 
@@ -7503,16 +7619,15 @@ the <FORM> tag
 =item FETCHING ENVIRONMENT VARIABLES
 
 B<Accept()>, B<raw_cookie()>, B<user_agent()>, B<path_info()>,
-B<path_translated()>, B<remote_host()>, B<script_name()> Return the script
-name as a partial URL, for self-refering scripts, B<referer()>, B<auth_type
-()>, B<server_name ()>, B<virtual_host ()>, B<server_port ()>,
+B<path_translated()>, B<remote_host()>, B<script_name()>, B<referer()>,
+B<auth_type ()>, B<server_name ()>, B<virtual_host ()>, B<server_port ()>,
 B<server_software ()>, B<remote_user ()>, B<user_name ()>,
 B<request_method()>, B<content_type()>, B<http()>, B<https()>
 
 =item USING NPH SCRIPTS
 
 In the B<use> statement, By calling the B<nph()> method:, By using B<-nph>
-parameters in the B<header()> and B<redirect()>  statements:
+parameters
 
 =item Server Push
 
@@ -7552,7 +7667,7 @@ MacEachern (dougm@opengroup.org), Robin Houston (robin@oneworld.org),
 
 =head2 CGI::Apache - Backward compatibility module for CGI.pm
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7571,7 +7686,7 @@ MacEachern (dougm@opengroup.org), Robin Houston (robin@oneworld.org),
 =head2 CGI::Carp, B<CGI::Carp> - CGI routines for writing to the HTTPD (or
 other) error log
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7581,7 +7696,7 @@ other) error log
 
 =item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
 
-=over
+=over 4
 
 =item Changing the default message
 
@@ -7599,7 +7714,7 @@ other) error log
 
 =head2 CGI::Cookie - Interface to Netscape Cookies
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7609,7 +7724,7 @@ other) error log
 
 B<1. expiration date>, B<2. domain>, B<3. path>, B<4. secure flag>
 
-=over
+=over 4
 
 =item Creating New Cookies
 
@@ -7633,7 +7748,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 =head2 CGI::Fast - CGI Interface for Fast CGI
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7659,13 +7774,13 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 =head2 CGI::Pretty - module to produce nicely formatted HTML code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Tags that won't be formatted
 
@@ -7683,7 +7798,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 =head2 CGI::Push - Simple Interface to Server Push
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7693,7 +7808,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 -next_page, -last_page, -type, -delay, -cookie, -target, -expires
 
-=over
+=over 4
 
 =item Heterogeneous Pages
 
@@ -7713,7 +7828,7 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 =head2 CGI::Switch - Backward compatibility module for defunct CGI::Switch
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7731,13 +7846,13 @@ B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
 
 =head2 CPAN - query, download and build perl modules from CPAN sites
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Interactive Mode
 
@@ -7755,9 +7870,36 @@ distribution, Signals
 
 =item Programmer's interface
 
-expand($type,@things), Programming Examples
-
-=item Methods in the four Classes
+expand($type,@things), expandany(@things), Programming Examples
+
+=item Methods in the other Classes
+
+CPAN::Author::as_glimpse(), CPAN::Author::as_string(),
+CPAN::Author::email(), CPAN::Author::fullname(), CPAN::Author::name(),
+CPAN::Bundle::as_glimpse(), CPAN::Bundle::as_string(),
+CPAN::Bundle::clean(), CPAN::Bundle::contains(),
+CPAN::Bundle::force($method,@args), CPAN::Bundle::get(),
+CPAN::Bundle::inst_file(), CPAN::Bundle::inst_version(),
+CPAN::Bundle::uptodate(), CPAN::Bundle::install(), CPAN::Bundle::make(),
+CPAN::Bundle::readme(), CPAN::Bundle::test(),
+CPAN::Distribution::as_glimpse(), CPAN::Distribution::as_string(),
+CPAN::Distribution::clean(), CPAN::Distribution::containsmods(),
+CPAN::Distribution::cvs_import(), CPAN::Distribution::dir(),
+CPAN::Distribution::force($method,@args), CPAN::Distribution::get(),
+CPAN::Distribution::install(), CPAN::Distribution::isa_perl(),
+CPAN::Distribution::look(), CPAN::Distribution::make(),
+CPAN::Distribution::prereq_pm(), CPAN::Distribution::readme(),
+CPAN::Distribution::test(), CPAN::Distribution::uptodate(),
+CPAN::Index::force_reload(), CPAN::Index::reload(), CPAN::InfoObj::dump(),
+CPAN::Module::as_glimpse(), CPAN::Module::as_string(),
+CPAN::Module::clean(), CPAN::Module::cpan_file(),
+CPAN::Module::cpan_version(), CPAN::Module::cvs_import(),
+CPAN::Module::description(), CPAN::Module::force($method,@args),
+CPAN::Module::get(), CPAN::Module::inst_file(),
+CPAN::Module::inst_version(), CPAN::Module::install(),
+CPAN::Module::look(), CPAN::Module::make(),
+CPAN::Module::manpage_headline(), CPAN::Module::readme(),
+CPAN::Module::test(), CPAN::Module::uptodate(), CPAN::Module::userid()
 
 =item Cache Manager
 
@@ -7780,7 +7922,7 @@ E<lt>valueE<gt>>, C<o conf E<lt>list optionE<gt>>, C<o conf E<lt>list
 optionE<gt> [shift|pop]>, C<o conf E<lt>list optionE<gt>
 [unshift|push|splice] E<lt>listE<gt>>
 
-=over
+=over 4
 
 =item Note on urllist parameter's format
 
@@ -7796,7 +7938,7 @@ optionE<gt> [shift|pop]>, C<o conf E<lt>list optionE<gt>
 
 =item WORKING WITH CPAN.pm BEHIND FIREWALLS
 
-=over
+=over 4
 
 =item Three basic types of firewalls
 
@@ -7808,16 +7950,7 @@ http firewall, ftp firewall, One way visibility, SOCKS, IP Masquerade
 
 =item FAQ
 
-1) I installed a new version of module X but CPAN keeps saying,       I
-have the old version installed, 2) So why is UNINST=1 not the default?, 3)
-When I install bundles or multiple modules with one command      there is
-too much output to keep track of, 4) I am not root, how can I install a
-module in a personal      directory?, 5) How to get a package, unwrap it,
-and make a change before       building it?, 6) I installed a Bundle and
-had a couple of fails. When I      retried, everything resolved nicely.
-Can this be fixed to work      on first try?, 7) In our intranet we have
-many modules for internal use. How      can I integrate these modules with
-CPAN.pm but without uploading      the modules to CPAN?
+1), 2), 3), 4), 5), 6), 7), 8), 9), 10)
 
 =item BUGS
 
@@ -7829,7 +7962,7 @@ CPAN.pm but without uploading         the modules to CPAN?
 
 =head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7840,7 +7973,7 @@ CPAN.pm but without uploading         the modules to CPAN?
 =head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS
 module
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7852,13 +7985,13 @@ module
 
 =head2 Carp, carp    - warn of errors (from perspective of caller)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Forcing a Stack Trace
 
@@ -7868,28 +8001,22 @@ module
 
 =back
 
-=head2 Carp::Heavy - Carp guts
-
-=over
-
-=item SYNOPIS
-
-=item DESCRIPTION
-
-=back
+=head2 Carp::Heavy, Carp heavy machinery - no user serviceable parts inside
 
 =head2 Class::Struct - declare struct-like datatypes as Perl classes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item The C<struct()> function
 
+=item Class Creation at Compile Time
+
 =item Element Types and Accessor Methods
 
 Scalar (C<'$'> or C<'*$'>), Array (C<'@'> or C<'*@'>), Hash (C<'%'> or
@@ -7909,7 +8036,7 @@ Example 1, Example 2, Example 3
 
 =head2 Config - access Perl configuration information
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -7923,7 +8050,7 @@ myconfig(), config_sh(), config_vars(@names)
 
 =item GLOSSARY
 
-=over
+=over 4
 
 =item _
 
@@ -7955,38 +8082,39 @@ C<cppstdin>, C<cppsymbols>, C<crosscompile>, C<cryptlib>, C<csh>
 
 =item d
 
-C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>, C<d_atolf>,
-C<d_atoll>, C<d_attribut>, C<d_bcmp>, C<d_bcopy>, C<d_bincompat5005>,
-C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>, C<d_casti32>,
-C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>, C<d_chsize>,
-C<d_closedir>, C<d_const>, C<d_crypt>, C<d_csh>, C<d_cuserid>,
+C<d__fwalk>, C<d_access>, C<d_accessx>, C<d_alarm>, C<d_archlib>,
+C<d_atolf>, C<d_atoll>, C<d_attribut>, C<d_bcmp>, C<d_bcopy>,
+C<d_bincompat5005>, C<d_bsd>, C<d_bsdgetpgrp>, C<d_bsdsetpgrp>, C<d_bzero>,
+C<d_casti32>, C<d_castneg>, C<d_charvspr>, C<d_chown>, C<d_chroot>,
+C<d_chsize>, C<d_closedir>, C<d_const>, C<d_crypt>, C<d_csh>, C<d_cuserid>,
 C<d_dbl_dig>, C<d_difftime>, C<d_dirnamlen>, C<d_dlerror>, C<d_dlopen>,
 C<d_dlsymun>, C<d_dosuid>, C<d_drand48proto>, C<d_dup2>, C<d_eaccess>,
 C<d_endgrent>, C<d_endhent>, C<d_endnent>, C<d_endpent>, C<d_endpwent>,
 C<d_endsent>, C<d_eofnblk>, C<d_eunice>, C<d_fchmod>, C<d_fchown>,
-C<d_fcntl>, C<d_fd_macros>, C<d_fd_set>, C<d_fds_bits>, C<d_fgetpos>,
-C<d_flexfnam>, C<d_flock>, C<d_fork>, C<d_fpathconf>, C<d_fpos64_t>,
-C<d_frexpl>, C<d_fs_data_s>, C<d_fseeko>, C<d_fsetpos>, C<d_fstatfs>,
-C<d_fstatvfs>, C<d_ftello>, C<d_ftime>, C<d_Gconvert>, C<d_getcwd>,
-C<d_getespwnam>, C<d_getfsstat>, C<d_getgrent>, C<d_getgrps>,
-C<d_gethbyaddr>, C<d_gethbyname>, C<d_gethent>, C<d_gethname>,
-C<d_gethostprotos>, C<d_getlogin>, C<d_getmnt>, C<d_getmntent>,
-C<d_getnbyaddr>, C<d_getnbyname>, C<d_getnent>, C<d_getnetprotos>,
-C<d_getpbyname>, C<d_getpbynumber>, C<d_getpent>, C<d_getpgid>,
-C<d_getpgrp2>, C<d_getpgrp>, C<d_getppid>, C<d_getprior>,
-C<d_getprotoprotos>, C<d_getprpwnam>, C<d_getpwent>, C<d_getsbyname>,
-C<d_getsbyport>, C<d_getsent>, C<d_getservprotos>, C<d_getspnam>,
-C<d_gettimeod>, C<d_gnulibc>, C<d_grpasswd>, C<d_hasmntopt>, C<d_htonl>,
-C<d_iconv>, C<d_index>, C<d_inetaton>, C<d_int64_t>, C<d_isascii>,
-C<d_isnan>, C<d_isnanl>, C<d_killpg>, C<d_lchown>, C<d_ldbl_dig>,
-C<d_link>, C<d_locconv>, C<d_lockf>, C<d_longdbl>, C<d_longlong>,
-C<d_lseekproto>, C<d_lstat>, C<d_madvise>, C<d_mblen>, C<d_mbstowcs>,
-C<d_mbtowc>, C<d_memchr>, C<d_memcmp>, C<d_memcpy>, C<d_memmove>,
-C<d_memset>, C<d_mkdir>, C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>,
-C<d_mkstemps>, C<d_mktime>, C<d_mmap>, C<d_modfl>, C<d_mprotect>, C<d_msg>,
-C<d_msg_ctrunc>, C<d_msg_dontroute>, C<d_msg_oob>, C<d_msg_peek>,
-C<d_msg_proxy>, C<d_msgctl>, C<d_msgget>, C<d_msgrcv>, C<d_msgsnd>,
-C<d_msync>, C<d_munmap>, C<d_mymalloc>, C<d_nice>, C<d_nv_preserves_uv>,
+C<d_fcntl>, C<d_fcntl_can_lock>, C<d_fd_macros>, C<d_fd_set>,
+C<d_fds_bits>, C<d_fgetpos>, C<d_flexfnam>, C<d_flock>, C<d_fork>,
+C<d_fpathconf>, C<d_fpos64_t>, C<d_frexpl>, C<d_fs_data_s>, C<d_fseeko>,
+C<d_fsetpos>, C<d_fstatfs>, C<d_fstatvfs>, C<d_fsync>, C<d_ftello>,
+C<d_ftime>, C<d_Gconvert>, C<d_getcwd>, C<d_getespwnam>, C<d_getfsstat>,
+C<d_getgrent>, C<d_getgrps>, C<d_gethbyaddr>, C<d_gethbyname>,
+C<d_gethent>, C<d_gethname>, C<d_gethostprotos>, C<d_getlogin>,
+C<d_getmnt>, C<d_getmntent>, C<d_getnbyaddr>, C<d_getnbyname>,
+C<d_getnent>, C<d_getnetprotos>, C<d_getpagsz>, C<d_getpbyname>,
+C<d_getpbynumber>, C<d_getpent>, C<d_getpgid>, C<d_getpgrp2>, C<d_getpgrp>,
+C<d_getppid>, C<d_getprior>, C<d_getprotoprotos>, C<d_getprpwnam>,
+C<d_getpwent>, C<d_getsbyname>, C<d_getsbyport>, C<d_getsent>,
+C<d_getservprotos>, C<d_getspnam>, C<d_gettimeod>, C<d_gnulibc>,
+C<d_grpasswd>, C<d_hasmntopt>, C<d_htonl>, C<d_iconv>, C<d_index>,
+C<d_inetaton>, C<d_int64_t>, C<d_isascii>, C<d_isnan>, C<d_isnanl>,
+C<d_killpg>, C<d_lchown>, C<d_ldbl_dig>, C<d_link>, C<d_locconv>,
+C<d_lockf>, C<d_longdbl>, C<d_longlong>, C<d_lseekproto>, C<d_lstat>,
+C<d_madvise>, C<d_mblen>, C<d_mbstowcs>, C<d_mbtowc>, C<d_memchr>,
+C<d_memcmp>, C<d_memcpy>, C<d_memmove>, C<d_memset>, C<d_mkdir>,
+C<d_mkdtemp>, C<d_mkfifo>, C<d_mkstemp>, C<d_mkstemps>, C<d_mktime>,
+C<d_mmap>, C<d_modfl>, C<d_mprotect>, C<d_msg>, C<d_msg_ctrunc>,
+C<d_msg_dontroute>, C<d_msg_oob>, C<d_msg_peek>, C<d_msg_proxy>,
+C<d_msgctl>, C<d_msgget>, C<d_msgrcv>, C<d_msgsnd>, C<d_msync>,
+C<d_munmap>, C<d_mymalloc>, C<d_nice>, C<d_nv_preserves_uv>,
 C<d_nv_preserves_uv_bits>, C<d_off64_t>, C<d_old_pthread_create_joinable>,
 C<d_oldpthreads>, C<d_oldsock>, C<d_open3>, C<d_pathconf>, C<d_pause>,
 C<d_perl_otherlibdirs>, C<d_phostname>, C<d_pipe>, C<d_poll>,
@@ -7996,31 +8124,33 @@ C<d_PRIu64>, C<d_PRIx64>, C<d_PRIXU64>, C<d_pthread_yield>, C<d_pwage>,
 C<d_pwchange>, C<d_pwclass>, C<d_pwcomment>, C<d_pwexpire>, C<d_pwgecos>,
 C<d_pwpasswd>, C<d_pwquota>, C<d_qgcvt>, C<d_quad>, C<d_readdir>,
 C<d_readlink>, C<d_rename>, C<d_rewinddir>, C<d_rmdir>, C<d_safebcpy>,
-C<d_safemcpy>, C<d_sanemcmp>, C<d_sched_yield>, C<d_scm_rights>,
-C<d_SCNfldbl>, C<d_seekdir>, C<d_select>, C<d_sem>, C<d_semctl>,
-C<d_semctl_semid_ds>, C<d_semctl_semun>, C<d_semget>, C<d_semop>,
-C<d_setegid>, C<d_seteuid>, C<d_setgrent>, C<d_setgrps>, C<d_sethent>,
-C<d_setlinebuf>, C<d_setlocale>, C<d_setnent>, C<d_setpent>, C<d_setpgid>,
-C<d_setpgrp2>, C<d_setpgrp>, C<d_setprior>, C<d_setproctitle>,
-C<d_setpwent>, C<d_setregid>, C<d_setresgid>, C<d_setresuid>,
-C<d_setreuid>, C<d_setrgid>, C<d_setruid>, C<d_setsent>, C<d_setsid>,
-C<d_setvbuf>, C<d_sfio>, C<d_shm>, C<d_shmat>, C<d_shmatprototype>,
-C<d_shmctl>, C<d_shmdt>, C<d_shmget>, C<d_sigaction>, C<d_sigsetjmp>,
-C<d_socket>, C<d_socklen_t>, C<d_sockpair>, C<d_socks5_init>, C<d_sqrtl>,
-C<d_statblks>, C<d_statfs_f_flags>, C<d_statfs_s>, C<d_statvfs>,
-C<d_stdio_cnt_lval>, C<d_stdio_ptr_lval>, C<d_stdio_stream_array>,
-C<d_stdiobase>, C<d_stdstdio>, C<d_strchr>, C<d_strcoll>, C<d_strctcpy>,
-C<d_strerrm>, C<d_strerror>, C<d_strtod>, C<d_strtol>, C<d_strtold>,
-C<d_strtoll>, C<d_strtoul>, C<d_strtoull>, C<d_strtouq>, C<d_strxfrm>,
-C<d_suidsafe>, C<d_symlink>, C<d_syscall>, C<d_sysconf>, C<d_sysernlst>,
-C<d_syserrlst>, C<d_system>, C<d_tcgetpgrp>, C<d_tcsetpgrp>, C<d_telldir>,
-C<d_telldirproto>, C<d_time>, C<d_times>, C<d_truncate>, C<d_tzname>,
-C<d_umask>, C<d_uname>, C<d_union_semun>, C<d_ustat>, C<d_vendorarch>,
-C<d_vendorbin>, C<d_vendorlib>, C<d_vfork>, C<d_void_closedir>,
-C<d_voidsig>, C<d_voidtty>, C<d_volatile>, C<d_vprintf>, C<d_wait4>,
-C<d_waitpid>, C<d_wcstombs>, C<d_wctomb>, C<d_xenix>, C<date>,
-C<db_hashtype>, C<db_prefixtype>, C<defvoidused>, C<direntrytype>,
-C<dlext>, C<dlsrc>, C<doublesize>, C<drand01>, C<dynamic_ext>
+C<d_safemcpy>, C<d_sanemcmp>, C<d_sbrkproto>, C<d_sched_yield>,
+C<d_scm_rights>, C<d_SCNfldbl>, C<d_seekdir>, C<d_select>, C<d_sem>,
+C<d_semctl>, C<d_semctl_semid_ds>, C<d_semctl_semun>, C<d_semget>,
+C<d_semop>, C<d_setegid>, C<d_seteuid>, C<d_setgrent>, C<d_setgrps>,
+C<d_sethent>, C<d_setlinebuf>, C<d_setlocale>, C<d_setnent>, C<d_setpent>,
+C<d_setpgid>, C<d_setpgrp2>, C<d_setpgrp>, C<d_setprior>,
+C<d_setproctitle>, C<d_setpwent>, C<d_setregid>, C<d_setresgid>,
+C<d_setresuid>, C<d_setreuid>, C<d_setrgid>, C<d_setruid>, C<d_setsent>,
+C<d_setsid>, C<d_setvbuf>, C<d_sfio>, C<d_shm>, C<d_shmat>,
+C<d_shmatprototype>, C<d_shmctl>, C<d_shmdt>, C<d_shmget>, C<d_sigaction>,
+C<d_sigsetjmp>, C<d_socket>, C<d_socklen_t>, C<d_sockpair>,
+C<d_socks5_init>, C<d_sqrtl>, C<d_statblks>, C<d_statfs_f_flags>,
+C<d_statfs_s>, C<d_statvfs>, C<d_stdio_cnt_lval>, C<d_stdio_ptr_lval>,
+C<d_stdio_ptr_lval_nochange_cnt>, C<d_stdio_ptr_lval_sets_cnt>,
+C<d_stdio_stream_array>, C<d_stdiobase>, C<d_stdstdio>, C<d_strchr>,
+C<d_strcoll>, C<d_strctcpy>, C<d_strerrm>, C<d_strerror>, C<d_strtod>,
+C<d_strtol>, C<d_strtold>, C<d_strtoll>, C<d_strtoq>, C<d_strtoul>,
+C<d_strtoull>, C<d_strtouq>, C<d_strxfrm>, C<d_suidsafe>, C<d_symlink>,
+C<d_syscall>, C<d_sysconf>, C<d_sysernlst>, C<d_syserrlst>, C<d_system>,
+C<d_tcgetpgrp>, C<d_tcsetpgrp>, C<d_telldir>, C<d_telldirproto>, C<d_time>,
+C<d_times>, C<d_truncate>, C<d_tzname>, C<d_umask>, C<d_uname>,
+C<d_union_semun>, C<d_ustat>, C<d_vendorarch>, C<d_vendorbin>,
+C<d_vendorlib>, C<d_vfork>, C<d_void_closedir>, C<d_voidsig>, C<d_voidtty>,
+C<d_volatile>, C<d_vprintf>, C<d_wait4>, C<d_waitpid>, C<d_wcstombs>,
+C<d_wctomb>, C<d_xenix>, C<date>, C<db_hashtype>, C<db_prefixtype>,
+C<defvoidused>, C<direntrytype>, C<dlext>, C<dlsrc>, C<doublesize>,
+C<drand01>, C<dynamic_ext>
 
 =item e
 
@@ -8065,7 +8195,8 @@ C<installarchlib>, C<installbin>, C<installman1dir>, C<installman3dir>,
 C<installprefix>, C<installprefixexp>, C<installprivlib>, C<installscript>,
 C<installsitearch>, C<installsitebin>, C<installsitelib>, C<installstyle>,
 C<installusrbinperl>, C<installvendorarch>, C<installvendorbin>,
-C<installvendorlib>, C<intsize>, C<ivdformat>, C<ivsize>, C<ivtype>
+C<installvendorlib>, C<intsize>, C<issymlink>, C<ivdformat>, C<ivsize>,
+C<ivtype>
 
 =item k
 
@@ -8093,10 +8224,10 @@ C<multiarch>, C<mv>, C<myarchname>, C<mydomain>, C<myhostname>, C<myuname>
 
 =item n
 
-C<n>, C<netdb_hlen_type>, C<netdb_host_type>, C<netdb_name_type>,
-C<netdb_net_type>, C<nm>, C<nm_opt>, C<nm_so_opt>, C<nonxs_ext>, C<nroff>,
-C<nveformat>, C<nvEUformat>, C<nvfformat>, C<nvFUformat>, C<nvgformat>,
-C<nvGUformat>, C<nvsize>, C<nvtype>
+C<n>, C<need_va_copy>, C<netdb_hlen_type>, C<netdb_host_type>,
+C<netdb_name_type>, C<netdb_net_type>, C<nm>, C<nm_opt>, C<nm_so_opt>,
+C<nonxs_ext>, C<nroff>, C<nveformat>, C<nvEUformat>, C<nvfformat>,
+C<nvFUformat>, C<nvgformat>, C<nvGUformat>, C<nvsize>, C<nvtype>
 
 =item o
 
@@ -8180,7 +8311,7 @@ C<zcat>, C<zip>
 
 =head2 Cwd, getcwd - get pathname of current working directory
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8192,13 +8323,13 @@ C<zcat>, C<zip>
 subject to
 change)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Global Variables
 
@@ -8227,7 +8358,7 @@ CLIENT->output(LIST)
 
 =head2 DB_File - Perl5 access to Berkeley DB version 1.x
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8235,7 +8366,7 @@ CLIENT->output(LIST)
 
 B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
 
-=over
+=over 4
 
 =item Using DB_File with Berkeley DB version 2 or 3
 
@@ -8251,7 +8382,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
 
 =item DB_HASH
 
-=over
+=over 4
 
 =item A Simple Example
 
@@ -8259,7 +8390,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
 
 =item DB_BTREE
 
-=over
+=over 4
 
 =item Changing the BTREE sort order
 
@@ -8277,7 +8408,7 @@ B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
 
 =item DB_RECNO
 
-=over
+=over 4
 
 =item The 'bval' Option
 
@@ -8304,7 +8435,7 @@ $value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;>
 B<filter_store_key>, B<filter_store_value>, B<filter_fetch_key>,
 B<filter_fetch_value>
 
-=over
+=over 4
 
 =item The Filter
 
@@ -8316,7 +8447,7 @@ B<filter_fetch_value>
 
 =item HINTS AND TIPS 
 
-=over
+=over 4
 
 =item Locking: The Trouble with fd
 
@@ -8332,7 +8463,7 @@ B<Tie::DB_Lock>, B<Tie::DB_LockFile>, B<DB_File::Lock>
 
 =item COMMON QUESTIONS
 
-=over
+=over 4
 
 =item Why is there Perl source in my database?
 
@@ -8363,13 +8494,13 @@ B<Tie::DB_Lock>, B<Tie::DB_LockFile>, B<DB_File::Lock>
 =head2 Data::Dumper - stringified perl data structures, suitable for both
 printing and C<eval>
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Methods
 
@@ -8417,7 +8548,7 @@ Dumper
 
 =head2 Devel::DProf - a Perl code profiler
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8437,13 +8568,13 @@ Dumper
 
 =head2 Devel::Peek - A data debugging tool for the XS programmer
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Memory footprint debugging
 
@@ -8451,7 +8582,7 @@ Dumper
 
 =item EXAMPLES
 
-=over
+=over 4
 
 =item A simple scalar string
 
@@ -8485,7 +8616,7 @@ Dumper
 
 =head2 Devel::SelfStubber - generate stubs for a SelfLoading module
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8495,7 +8626,7 @@ Dumper
 
 =head2 DirHandle - supply object methods for directory handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8505,13 +8636,13 @@ Dumper
 
 =head2 Dumpvalue - provides screen dump of Perl data.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Creation
 
@@ -8531,7 +8662,7 @@ veryCompact, set, get
 
 =head2 DynaLoader - Dynamically load C libraries into Perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8550,7 +8681,7 @@ bootstrap()
 =head2 DynaLoader::XSLoader, XSLoader - Dynamically load C libraries into
 Perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8562,7 +8693,7 @@ Perl code
 
 =head2 Encode - character encodings
 
-=over
+=over 4
 
 =item TERMINOLOGY
 
@@ -8582,10 +8713,39 @@ Perl code
 
 =back
 
+=head2 Encode::EncodeFormat, EncodeFormat - the format of encoding tables
+of the Encode extension
+
+=over 4
+
+=item DESCRIPTION
+
+[1]   B<S>, [2]   B<D>, [3]   B<M>, [4]   B<E>
+
+=item KEYWORDS
+
+=item COPYRIGHT
+
+=back
+
+=head2 EncodeFormat - the format of encoding tables of the Encode extension
+
+=over 4
+
+=item DESCRIPTION
+
+[1]   B<S>, [2]   B<D>, [3]   B<M>, [4]   B<E>
+
+=item KEYWORDS
+
+=item COPYRIGHT
+
+=back
+
 =head2 English - use nice English (or awk) names for ugly punctuation
 variables
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8598,7 +8758,7 @@ variables
 =head2 Env - perl module that imports environment variables as scalars or
 arrays
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8612,7 +8772,7 @@ arrays
 
 =head2 Errno - System errno constants
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8628,13 +8788,13 @@ arrays
 
 =head2 Exporter - Implements default import method for modules
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How to Export
 
@@ -8656,7 +8816,7 @@ arrays
 
 =head2 Exporter::Heavy - Exporter guts
 
-=over
+=over 4
 
 =item SYNOPIS
 
@@ -8667,7 +8827,7 @@ arrays
 =head2 ExtUtils::Command - utilities to replace common UNIX commands in
 Makefiles etc.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8695,7 +8855,7 @@ mkpath directory..
 
 test_f file
 
-=over
+=over 4
 
 =item BUGS
 
@@ -8707,7 +8867,7 @@ test_f file
 
 =head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8730,7 +8890,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules)
 
 =head2 ExtUtils::Install - install files from here to there
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8740,7 +8900,7 @@ ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules)
 
 =head2 ExtUtils::Installed - Inventory management of installed modules
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8761,7 +8921,7 @@ packlist(), version()
 
 =head2 ExtUtils::Liblist - determine libraries to use and how to use them
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8769,7 +8929,7 @@ packlist(), version()
 
 For static extensions, For dynamic extensions, For dynamic extensions
 
-=over
+=over 4
 
 =item EXTRALIBS
 
@@ -8781,7 +8941,7 @@ For static extensions, For dynamic extensions, For dynamic extensions
 
 =item PORTABILITY
 
-=over
+=over 4
 
 =item VMS implementation
 
@@ -8796,7 +8956,7 @@ For static extensions, For dynamic extensions, For dynamic extensions
 =head2 ExtUtils::MM_Cygwin - methods to override UN*X behaviour in
 ExtUtils::MakeMaker
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8809,7 +8969,7 @@ canonpath, cflags, manifypods, perl_archive
 =head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in
 ExtUtils::MakeMaker
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8819,7 +8979,7 @@ ExtUtils::MakeMaker
 
 =head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -8827,7 +8987,7 @@ ExtUtils::MakeMaker
 
 =item METHODS
 
-=over
+=over 4
 
 =item Preloaded methods
 
@@ -8847,7 +9007,7 @@ rootdir
 
 updir
 
-=over
+=over 4
 
 =item SelfLoaded methods
 
@@ -8899,7 +9059,7 @@ file_name_is_absolute
 
 find_perl
 
-=over
+=over 4
 
 =item Methods to actually produce chunks of text for the Makefile
 
@@ -9017,7 +9177,7 @@ perl_archive
 
 export_list
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -9026,13 +9186,13 @@ export_list
 =head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in
 ExtUtils::MakeMaker
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Methods always loaded
 
@@ -9044,7 +9204,7 @@ wraplist
 
 rootdir (override)
 
-=over
+=over 4
 
 =item SelfLoaded methods
 
@@ -9141,7 +9301,7 @@ nicetext (override)
 =head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in
 ExtUtils::MakeMaker
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9187,13 +9347,13 @@ pasthru (o)
 
 =head2 ExtUtils::MakeMaker - create an extension Makefile
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item How To Write A Makefile.PL
 
@@ -9217,21 +9377,21 @@ pasthru (o)
 
 =item Using Attributes and Parameters
 
-AUTHOR, ABSTRACT, ABSTRACT_FROM, BINARY_LOCATION, C, CAPI, CCFLAGS, CONFIG,
+ABSTRACT, ABSTRACT_FROM, AUTHOR, BINARY_LOCATION, C, CAPI, CCFLAGS, CONFIG,
 CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS, EXCLUDE_EXT,
 EXE_FILES, FIRST_MAKEFILE, FULLPERL, FUNCLIST, H, HTMLLIBPODS,
 HTMLSCRIPTPODS, IMPORTS, INC, INCLUDE_EXT, INSTALLARCHLIB, INSTALLBIN,
 INSTALLDIRS, INSTALLHTMLPRIVLIBDIR, INSTALLHTMLSCRIPTDIR,
 INSTALLHTMLSITELIBDIR, INSTALLMAN1DIR, INSTALLMAN3DIR, INSTALLPRIVLIB,
 INSTALLSCRIPT, INSTALLSITEARCH, INSTALLSITELIB, INST_ARCHLIB, INST_BIN,
-INST_EXE, INST_LIB, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_MAN1DIR,
-INST_MAN3DIR, INST_SCRIPT, PERL_MALLOC_OK, LDFROM, LIB, LIBPERL_A, LIBS,
-LINKTYPE, MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB,
-NAME, NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL,
-PERLMAINCC, PERL_ARCHLIB, PERL_LIB, PERL_SRC, PERM_RW, PERM_RWX, PL_FILES,
-PM, PMLIBDIRS, POLLUTE, PPM_INSTALL_EXEC, PPM_INSTALL_SCRIPT, PREFIX,
-PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT, XSPROTOARG,
-XS_VERSION
+INST_EXE, INST_HTMLLIBDIR, INST_HTMLSCRIPTDIR, INST_LIB, INST_MAN1DIR,
+INST_MAN3DIR, INST_SCRIPT, LDFROM, LIB, LIBPERL_A, LIBS, LINKTYPE,
+MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME,
+NEEDS_LINKING, NOECHO, NORECURS, NO_VC, OBJECT, OPTIMIZE, PERL, PERLMAINCC,
+PERL_ARCHLIB, PERL_LIB, PERL_MALLOC_OK, PERL_SRC, PERM_RW, PERM_RWX,
+PL_FILES, PM, PMLIBDIRS, POLLUTE, PPM_INSTALL_EXEC, PPM_INSTALL_SCRIPT,
+PREFIX, PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT,
+XSPROTOARG, XS_VERSION
 
 =item Additional lowercase attributes
 
@@ -9264,7 +9424,7 @@ PERL_MM_OPT
 
 =head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9281,6 +9441,10 @@ PERL_MM_OPT
 C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:> I<$!>,
 C<Added to MANIFEST:> I<file>
 
+=item ENVIRONMENT
+
+B<PERL_MM_MANIFEST_DEBUG>
+
 =item SEE ALSO
 
 =item AUTHOR
@@ -9289,7 +9453,7 @@ C<Added to MANIFEST:> I<file>
 
 =head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9301,7 +9465,7 @@ C<Added to MANIFEST:> I<file>
 
 =head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9312,7 +9476,7 @@ C<Added to MANIFEST:> I<file>
 =head2 ExtUtils::Mksymlists - write linker options files for dynamic
 extension
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9328,7 +9492,7 @@ DLBASE, DL_FUNCS, DL_VARS, FILE, FUNCLIST, IMPORTS, NAME
 
 =head2 ExtUtils::Packlist - manage .packlist files
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9348,7 +9512,7 @@ new(), read(), write(), validate(), packlist_file()
 
 =head2 ExtUtils::testlib - add blib/* directories to @INC
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9358,7 +9522,7 @@ new(), read(), write(), validate(), packlist_file()
 
 =head2 Fatal - replace functions with equivalents which succeed or die
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9370,7 +9534,7 @@ new(), read(), write(), validate(), packlist_file()
 
 =head2 Fcntl - load the C Fcntl.h defines
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9384,7 +9548,7 @@ new(), read(), write(), validate(), packlist_file()
 
 =head2 File::Basename, fileparse - split a pathname into pieces
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9400,7 +9564,7 @@ C<basename>, C<dirname>
 
 =head2 File::CheckTree, validate - run many filetest checks on a tree
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9410,7 +9574,7 @@ C<basename>, C<dirname>
 
 =head2 File::Compare - Compare files or filehandles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9424,13 +9588,13 @@ C<basename>, C<dirname>
 
 =head2 File::Copy - Copy files or filehandles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)
 
@@ -9446,7 +9610,7 @@ rmscopy($from,$to[,$date_flag])
 
 =head2 File::DosGlob - DOS like globbing and then some
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9466,7 +9630,7 @@ rmscopy($from,$to[,$date_flag])
 
 =head2 File::Find, find - traverse a file tree
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9482,7 +9646,7 @@ C<untaint_pattern>, C<untaint_skip>
 
 =head2 File::Glob - Perl extension for BSD glob routine
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9503,7 +9667,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND>
 
 =head2 File::Path - create or remove directory trees
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9515,7 +9679,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND>
 
 =head2 File::Spec - portably perform operations on file names
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9527,15 +9691,49 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND>
 
 =back
 
+=head2 File::Spec::Epoc - methods for Epoc file specs
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+devnull
+
+=back
+
+tmpdir
+
+path
+
+canonpath
+
+splitpath
+
+splitdir
+
+catpath
+
+abs2rel
+
+rel2abs
+
+=over 4
+
+=item SEE ALSO
+
+=back
+
 =head2 File::Spec::Functions - portably perform operations on file names
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Exports
 
@@ -9547,7 +9745,7 @@ C<GLOB_NOSPACE>, C<GLOB_ABEND>
 
 =head2 File::Spec::Mac - File::Spec for MacOS
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9587,7 +9785,7 @@ abs2rel
 
 rel2abs
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -9595,7 +9793,7 @@ rel2abs
 
 =head2 File::Spec::OS2 - methods for OS/2 file specs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9605,7 +9803,7 @@ rel2abs
 
 =head2 File::Spec::Unix - methods used by File::Spec
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9651,7 +9849,7 @@ abs2rel
 
 rel2abs
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -9659,7 +9857,7 @@ rel2abs
 
 =head2 File::Spec::VMS - methods for VMS file specs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9671,7 +9869,7 @@ eliminate_macros
 
 fixpath
 
-=over
+=over 4
 
 =item Methods always loaded
 
@@ -9709,7 +9907,7 @@ abs2rel (override)
 
 rel2abs (override)
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -9717,7 +9915,7 @@ rel2abs (override)
 
 =head2 File::Spec::Win32 - methods for Win32 file specs
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9739,7 +9937,7 @@ splitdir
 
 catpath
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -9747,7 +9945,7 @@ catpath
 
 =head2 File::Temp - return name and handle of a temporary file safely
 
-=over
+=over 4
 
 =item PORTABILITY
 
@@ -9757,7 +9955,7 @@ catpath
 
 =back
 
-=over
+=over 4
 
 =item FUNCTIONS
 
@@ -9767,7 +9965,7 @@ B<tempfile>
 
 B<tempdir>
 
-=over
+=over 4
 
 =item MKTEMP FUNCTIONS
 
@@ -9781,7 +9979,7 @@ B<mkdtemp>
 
 B<mktemp>
 
-=over
+=over 4
 
 =item POSIX FUNCTIONS
 
@@ -9791,7 +9989,7 @@ B<tmpnam>
 
 B<tmpfile>
 
-=over
+=over 4
 
 =item ADDITIONAL FUNCTIONS
 
@@ -9799,7 +9997,7 @@ B<tempnam>
 
 =back
 
-=over
+=over 4
 
 =item UTILITY FUNCTIONS
 
@@ -9807,7 +10005,7 @@ B<unlink0>
 
 =back
 
-=over
+=over 4
 
 =item PACKAGE VARIABLES
 
@@ -9817,10 +10015,16 @@ B<safe_level>, STANDARD, MEDIUM, HIGH
 
 TopSystemUID
 
-=over
+=over 4
 
 =item WARNING
 
+=over 4
+
+=item Temporary files and NFS
+
+=back
+
 =item HISTORY
 
 =item SEE ALSO
@@ -9831,7 +10035,7 @@ TopSystemUID
 
 =head2 File::stat - by-name interface to Perl's built-in stat() functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9845,7 +10049,7 @@ TopSystemUID
 
 =head2 FileCache - keep more files open than the system permits
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9857,7 +10061,7 @@ TopSystemUID
 
 =head2 FileHandle - supply object methods for filehandles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9869,9 +10073,75 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines
 
 =back
 
+=head2 Filter::Simple - Simplified source filtering
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over 4
+
+=item The Problem
+
+=item A Solution
+
+=item How it works
+
+=back
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=back
+
+=head2 Filter::Util::Call - Perl Source Filter Utility Module
+
+=over 4
+
+=item SYNOPSIS
+
+    use Filter::Util::Call ;
+
+=item DESCRIPTION
+
+=over 4
+
+=item B<use Filter::Util::Call>
+
+=item B<import()>
+
+=item B<filter() and anonymous sub>
+
+B<$_>, B<$status>, B<filter_read> and B<filter_read_exact>, B<filter_del>
+
+=back
+
+=item EXAMPLES
+
+=over 4
+
+=item Example 1: A simple filter.
+
+=item Example 2: Using the context
+
+=item Example 3: Using the context within the filter
+
+=item Example 4: Using filter_del
+
+=back
+
+=item AUTHOR
+
+=item DATE
+
+=back
+
 =head2 FindBin - Locate directory of original perl script
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9889,7 +10159,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines
 
 =head2 GDBM_File - Perl5 access to the gdbm library.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9905,7 +10175,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines
 
 =head2 Getopt::Long - Extended processing of command line options
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -9915,7 +10185,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines
 
 =item Getting Started with Getopt::Long
 
-=over
+=over 4
 
 =item Simple options
 
@@ -9943,7 +10213,7 @@ $fh->print, $fh->printf, $fh->getline, $fh->getlines
 
 =item Advanced Possibilities
 
-=over
+=over 4
 
 =item Object oriented interface
 
@@ -9971,7 +10241,7 @@ prefix_pattern, debug (default: disabled)
 
 =item Legacy
 
-=over
+=over 4
 
 =item Default destinations
 
@@ -9983,7 +10253,7 @@ prefix_pattern, debug (default: disabled)
 
 =item Trouble Shooting
 
-=over
+=over 4
 
 =item Warning: Ignoring '!' modifier for short option
 
@@ -10001,7 +10271,7 @@ supplied
 =head2 Getopt::Std, getopt - Process single-character switches with switch
 clustering
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10012,7 +10282,7 @@ clustering
 =head2 I18N::Collate - compare 8-bit scalar data according to the current
 locale
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10022,7 +10292,7 @@ locale
 
 =head2 IO - load various IO modules
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10032,7 +10302,7 @@ locale
 
 =head2 IO::Dir - supply object methods for directory handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10051,7 +10321,7 @@ rewind (), close (), tie %hash, IO::Dir, DIRNAME [, OPTIONS ]
 
 =head2 IO::File - supply object methods for filehandles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10073,7 +10343,7 @@ open( FILENAME [,MODE [,PERMS]] )
 
 =head2 IO::Handle - supply object methods for I/O handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10102,7 +10372,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint
 
 =head2 IO::Pipe - supply object methods for pipes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10126,7 +10396,7 @@ reader ([ARGS]), writer ([ARGS]), handles ()
 
 =head2 IO::Poll - Object interface to system poll call
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10147,13 +10417,15 @@ IO ), handles( [ EVENT_MASK ] )
 
 =head2 IO::Seekable - supply seek based methods for I/O objects
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=item SEE ALSO
+$io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
+WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ),
+$io->tell
 
 =item HISTORY
 
@@ -10161,7 +10433,7 @@ IO ), handles( [ EVENT_MASK ] )
 
 =head2 IO::Select - OO interface to the select system call
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10187,7 +10459,7 @@ count (), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] )
 
 =head2 IO::Socket - Object interface to socket communications
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10212,7 +10484,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected
 
 =head2 IO::Socket::INET - Object interface for AF_INET domain sockets
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10222,7 +10494,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected
 
 new ( [ARGS] )
 
-=over
+=over 4
 
 =item METHODS
 
@@ -10241,7 +10513,7 @@ sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost
 
 =head2 IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10266,7 +10538,7 @@ hostpath(), peerpath()
 =head2 IO::lib::IO::Dir, IO::Dir - supply object methods for directory
 handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10285,7 +10557,7 @@ rewind (), close (), tie %hash, IO::Dir, DIRNAME [, OPTIONS ]
 
 =head2 IO::lib::IO::File, IO::File - supply object methods for filehandles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10308,7 +10580,7 @@ open( FILENAME [,MODE [,PERMS]] )
 =head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O
 handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10337,7 +10609,7 @@ $io->blocking ( [ BOOL ] ), $io->untaint
 
 =head2 IO::lib::IO::Pipe, IO::Pipe - supply object methods for pipes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10361,7 +10633,7 @@ reader ([ARGS]), writer ([ARGS]), handles ()
 
 =head2 IO::lib::IO::Poll, IO::Poll - Object interface to system poll call
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10383,13 +10655,15 @@ IO ), handles( [ EVENT_MASK ] )
 =head2 IO::lib::IO::Seekable, IO::Seekable - supply seek based methods for
 I/O objects
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=item SEE ALSO
+$io->getpos, $io->setpos, $io->setpos ( POS, WHENCE ), WHENCE=0 (SEEK_SET),
+WHENCE=1 (SEEK_CUR), WHENCE=1 (SEEK_END), $io->sysseek( POS, WHENCE ),
+$io->tell
 
 =item HISTORY
 
@@ -10398,7 +10672,7 @@ I/O objects
 =head2 IO::lib::IO::Select, IO::Select - OO interface to the select system
 call
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10425,7 +10699,7 @@ count (), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] )
 =head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket
 communications
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10451,7 +10725,7 @@ sockopt(OPT [, VAL]), sockdomain, socktype, protocol, connected
 =head2 IO::lib::IO::Socket::INET, IO::Socket::INET - Object interface for
 AF_INET domain sockets
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10461,7 +10735,7 @@ AF_INET domain sockets
 
 new ( [ARGS] )
 
-=over
+=over 4
 
 =item METHODS
 
@@ -10481,7 +10755,7 @@ sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost
 =head2 IO::lib::IO::Socket::UNIX, IO::Socket::UNIX - Object interface for
 AF_UNIX domain sockets
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10505,7 +10779,7 @@ hostpath(), peerpath()
 
 =head2 IPC::Msg - SysV Msg IPC object class
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10527,7 +10801,7 @@ FLAGS ] ), stat
 
 =head2 IPC::Open2, open2 - open a process for both reading and writing
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10542,7 +10816,7 @@ FLAGS ] ), stat
 =head2 IPC::Open3, open3 - open a process for reading, writing, and error
 handling
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10554,7 +10828,7 @@ handling
 
 =head2 IPC::Semaphore - SysV Semaphore IPC object class
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10577,7 +10851,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N
 
 =head2 IPC::SysV - SysV IPC constants
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10595,7 +10869,7 @@ ftok( PATH, ID )
 
 =head2 IPC::SysV::Msg, IPC::Msg - SysV Msg IPC object class
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10618,7 +10892,7 @@ FLAGS ] ), stat
 =head2 IPC::SysV::Semaphore, IPC::Semaphore - SysV Semaphore IPC object
 class
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10641,7 +10915,7 @@ set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N
 
 =head2 Math::BigFloat - Arbitrary length float math package
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10658,7 +10932,7 @@ performed
 
 =head2 Math::BigInt - Arbitrary size integer math package
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10679,7 +10953,7 @@ Canonical notation, Input, Output
 =head2 Math::Complex - complex numbers and associated mathematical
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10691,7 +10965,7 @@ functions
 
 =item STRINGIFICATION
 
-=over
+=over 4
 
 =item CHANGED IN PERL 5.6
 
@@ -10711,7 +10985,7 @@ functions
 
 =head2 Math::Trig - trigonometric functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10721,7 +10995,7 @@ functions
 
 B<tan>
 
-=over
+=over 4
 
 =item ERRORS DUE TO DIVISION BY ZERO
 
@@ -10733,7 +11007,7 @@ B<tan>
 
 =item RADIAL COORDINATE CONVERSIONS
 
-=over
+=over 4
 
 =item COORDINATE SYSTEMS
 
@@ -10756,7 +11030,7 @@ cylindrical_to_spherical, spherical_to_cartesian, spherical_to_cylindrical
 
 =head2 NDBM_File - Tied access to ndbm files
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10764,7 +11038,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =item DIAGNOSTICS
 
-=over
+=over 4
 
 =item C<ndbm store returned -1, errno 22, key "..." at ...>
 
@@ -10776,13 +11050,13 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =head2 Net::Ping - check a remote host for reachability
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Functions
 
@@ -10800,7 +11074,7 @@ $timeout]);, $p->close();, pingecho($host [, $timeout]);
 =head2 Net::hostent - by-name interface to Perl's built-in gethost*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10817,7 +11091,7 @@ functions
 =head2 Net::netent - by-name interface to Perl's built-in getnet*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10834,7 +11108,7 @@ functions
 =head2 Net::protoent - by-name interface to Perl's built-in getproto*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10849,7 +11123,7 @@ functions
 =head2 Net::servent - by-name interface to Perl's built-in getserv*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10865,7 +11139,7 @@ functions
 
 =head2 O - Generic interface to Perl Compiler backends
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10881,7 +11155,7 @@ functions
 
 =head2 ODBM_File - Tied access to odbm files
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10889,7 +11163,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =item DIAGNOSTICS
 
-=over
+=over 4
 
 =item C<odbm store returned -1, errno 22, key "..." at ...>
 
@@ -10901,7 +11175,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =head2 Opcode - Disable named opcodes when compiling perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10929,7 +11203,7 @@ opdump (PAT)
 
 =back
 
-=over
+=over 4
 
 =item Predefined Opcode Tags
 
@@ -10947,7 +11221,7 @@ opdump (PAT)
 =head2 Opcode::Safe, Safe - Compile and execute code in restricted
 compartments
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -10957,7 +11231,7 @@ a new namespace, an operator mask
 
 =item WARNING
 
-=over
+=over 4
 
 =item RECENT CHANGES
 
@@ -10981,7 +11255,7 @@ Memory, CPU, Snooping, Signals, State Changes
 =head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when
 compiling
 
-=over
+=over 4
 
 =item SYNOPSIS 
 
@@ -10993,7 +11267,7 @@ compiling
 
 =head2 POSIX - Perl interface to IEEE Std 1003.1
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11034,7 +11308,7 @@ wctomb, write
 
 =item CLASSES
 
-=over
+=over 4
 
 =item POSIX::SigAction
 
@@ -11122,13 +11396,13 @@ Constants, Macros
 
 =head2 Pod::Checker, podchecker() - check pod documents for syntax errors
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item OPTIONS/ARGUMENTS
 
-=over
+=over 4
 
 =item podchecker()
 
@@ -11140,7 +11414,7 @@ B<-warnings> =E<gt> I<val>
 
 =item DIAGNOSTICS
 
-=over
+=over 4
 
 =item Errors
 
@@ -11195,7 +11469,7 @@ C<$checker-E<gt>idx()>
 
 C<$checker-E<gt>hyperlink()>
 
-=over
+=over 4
 
 =item AUTHOR
 
@@ -11203,7 +11477,7 @@ C<$checker-E<gt>hyperlink()>
 
 =head2 Pod::Find - find POD documents in directory trees
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11211,7 +11485,7 @@ C<$checker-E<gt>hyperlink()>
 
 =back
 
-=over
+=over 4
 
 =item C<pod_find( { %opts } , @directories )>
 
@@ -11220,13 +11494,13 @@ C<-verbose =E<gt> 1>, C<-perl =E<gt> 1>, C<-script =E<gt> 1>, C<-inc =E<gt>
 
 =back
 
-=over
+=over 4
 
 =item C<simplify_name( $str )>
 
 =back
 
-=over
+=over 4
 
 =item C<pod_where( { %opts }, $pod )>
 
@@ -11235,13 +11509,13 @@ C<-inc =E<gt> 1>, C<-dirs =E<gt> [ $dir1, $dir2, ... ]>, C<-verbose =E<gt>
 
 =back
 
-=over
+=over 4
 
 =item C<contains_pod( $file , $verbose )>
 
 =back
 
-=over
+=over 4
 
 =item AUTHOR
 
@@ -11251,7 +11525,7 @@ C<-inc =E<gt> 1>, C<-dirs =E<gt> [ $dir1, $dir2, ... ]>, C<-verbose =E<gt>
 
 =head2 Pod::Html - module to convert pod files to HTML
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11278,7 +11552,7 @@ verbose
 =head2 Pod::InputObjects - objects representing POD input paragraphs,
 commands, etc.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11293,211 +11567,211 @@ B<Pod::InteriorSequence>, package B<Pod::ParseTree>
 
 =back
 
-=over
+=over 4
 
 =item B<Pod::InputSource>
 
 =back
 
-=over
+=over 4
 
 =item B<new()>
 
 =back
 
-=over
+=over 4
 
 =item B<name()>
 
 =back
 
-=over
+=over 4
 
 =item B<handle()>
 
 =back
 
-=over
+=over 4
 
 =item B<was_cutting()>
 
 =back
 
-=over
+=over 4
 
 =item B<Pod::Paragraph>
 
 =back
 
-=over
+=over 4
 
 =item Pod::Paragraph-E<gt>B<new()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<cmd_name()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<text()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<raw_text()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<cmd_prefix()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<cmd_separator()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<parse_tree()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_para-E<gt>B<file_line()>
 
 =back
 
-=over
+=over 4
 
 =item B<Pod::InteriorSequence>
 
 =back
 
-=over
+=over 4
 
 =item Pod::InteriorSequence-E<gt>B<new()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<cmd_name()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<prepend()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<append()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<nested()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<raw_text()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<left_delimiter()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<right_delimiter()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<parse_tree()>
 
 =back
 
-=over
+=over 4
 
 =item $pod_seq-E<gt>B<file_line()>
 
 =back
 
-=over
+=over 4
 
 =item Pod::InteriorSequence::B<DESTROY()>
 
 =back
 
-=over
+=over 4
 
 =item B<Pod::ParseTree>
 
 =back
 
-=over
+=over 4
 
 =item Pod::ParseTree-E<gt>B<new()>
 
 =back
 
-=over
+=over 4
 
 =item $ptree-E<gt>B<top()>
 
 =back
 
-=over
+=over 4
 
 =item $ptree-E<gt>B<children()>
 
 =back
 
-=over
+=over 4
 
 =item $ptree-E<gt>B<prepend()>
 
 =back
 
-=over
+=over 4
 
 =item $ptree-E<gt>B<append()>
 
 =back
 
-=over
+=over 4
 
 =item $ptree-E<gt>B<raw_text()>
 
 =back
 
-=over
+=over 4
 
 =item Pod::ParseTree::B<DESTROY()>
 
 =back
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -11507,7 +11781,7 @@ B<Pod::InteriorSequence>, package B<Pod::ParseTree>
 
 =head2 Pod::LaTeX - Convert Pod data to formatted Latex
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11515,7 +11789,7 @@ B<Pod::InteriorSequence>, package B<Pod::ParseTree>
 
 =back
 
-=over
+=over 4
 
 =item OBJECT METHODS
 
@@ -11523,7 +11797,7 @@ C<initialize>
 
 =back
 
-=over
+=over 4
 
 =item Data Accessors
 
@@ -11555,7 +11829,7 @@ B<UserPostamble>
 
 B<Lists>
 
-=over
+=over 4
 
 =item Subclassed methods
 
@@ -11573,7 +11847,7 @@ B<textblock>
 
 B<interior_sequence>
 
-=over
+=over 4
 
 =item List Methods
 
@@ -11585,7 +11859,7 @@ B<end_list>
 
 B<add_item>
 
-=over
+=over 4
 
 =item Methods for headings
 
@@ -11593,7 +11867,7 @@ B<head>
 
 =back
 
-=over
+=over 4
 
 =item Internal methods
 
@@ -11609,7 +11883,7 @@ B<_create_index>
 
 B<_clean_latex_commands>
 
-=over
+=over 4
 
 =item NOTES
 
@@ -11625,7 +11899,7 @@ B<_clean_latex_commands>
 
 =head2 Pod::Man - Convert POD data to formatted *roff input
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11651,7 +11925,7 @@ line %d, Unmatched =back
 
 =head2 Pod::ParseUtils - helpers for POD parsing and conversion
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11659,7 +11933,7 @@ line %d, Unmatched =back
 
 =back
 
-=over
+=over 4
 
 =item Pod::List
 
@@ -11683,7 +11957,7 @@ $list-E<gt>parent()
 
 $list-E<gt>tag()
 
-=over
+=over 4
 
 =item Pod::Hyperlink
 
@@ -11711,7 +11985,7 @@ $link-E<gt>type()
 
 $link-E<gt>link()
 
-=over
+=over 4
 
 =item Pod::Cache
 
@@ -11723,7 +11997,7 @@ $cache-E<gt>item()
 
 $cache-E<gt>find_page($name)
 
-=over
+=over 4
 
 =item Pod::Cache::Item
 
@@ -11745,7 +12019,7 @@ $cacheitem-E<gt>find_node($name)
 
 $cacheitem-E<gt>idx()
 
-=over
+=over 4
 
 =item AUTHOR
 
@@ -11755,7 +12029,7 @@ $cacheitem-E<gt>idx()
 
 =head2 Pod::Parser - base class for creating POD filters and translators
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -11774,13 +12048,13 @@ B<-warnings> (default: unset)
 
 =back
 
-=over
+=over 4
 
 =item RECOMMENDED SUBROUTINE/METHOD OVERRIDES
 
 =back
 
-=over
+=over 4
 
 =item B<command()>
 
@@ -11788,7 +12062,7 @@ C<$cmd>, C<$text>, C<$line_num>, C<$pod_para>
 
 =back
 
-=over
+=over 4
 
 =item B<verbatim()>
 
@@ -11796,7 +12070,7 @@ C<$text>, C<$line_num>, C<$pod_para>
 
 =back
 
-=over
+=over 4
 
 =item B<textblock()>
 
@@ -11804,73 +12078,73 @@ C<$text>, C<$line_num>, C<$pod_para>
 
 =back
 
-=over
+=over 4
 
 =item B<interior_sequence()>
 
 =back
 
-=over
+=over 4
 
 =item OPTIONAL SUBROUTINE/METHOD OVERRIDES
 
 =back
 
-=over
+=over 4
 
 =item B<new()>
 
 =back
 
-=over
+=over 4
 
 =item B<initialize()>
 
 =back
 
-=over
+=over 4
 
 =item B<begin_pod()>
 
 =back
 
-=over
+=over 4
 
 =item B<begin_input()>
 
 =back
 
-=over
+=over 4
 
 =item B<end_input()>
 
 =back
 
-=over
+=over 4
 
 =item B<end_pod()>
 
 =back
 
-=over
+=over 4
 
 =item B<preprocess_line()>
 
 =back
 
-=over
+=over 4
 
 =item B<preprocess_paragraph()>
 
 =back
 
-=over
+=over 4
 
 =item METHODS FOR PARSING AND PROCESSING
 
 =back
 
-=over
+=over 4
 
 =item B<parse_text()>
 
@@ -11880,109 +12154,109 @@ I<code-ref>|I<method-name>
 
 =back
 
-=over
+=over 4
 
 =item B<interpolate()>
 
 =back
 
-=over
+=over 4
 
 =item B<parse_paragraph()>
 
 =back
 
-=over
+=over 4
 
 =item B<parse_from_filehandle()>
 
 =back
 
-=over
+=over 4
 
 =item B<parse_from_file()>
 
 =back
 
-=over
+=over 4
 
 =item ACCESSOR METHODS
 
 =back
 
-=over
+=over 4
 
 =item B<errorsub()>
 
 =back
 
-=over
+=over 4
 
 =item B<cutting()>
 
 =back
 
-=over
+=over 4
 
 =item B<parseopts()>
 
 =back
 
-=over
+=over 4
 
 =item B<output_file()>
 
 =back
 
-=over
+=over 4
 
 =item B<output_handle()>
 
 =back
 
-=over
+=over 4
 
 =item B<input_file()>
 
 =back
 
-=over
+=over 4
 
 =item B<input_handle()>
 
 =back
 
-=over
+=over 4
 
 =item B<input_streams()>
 
 =back
 
-=over
+=over 4
 
 =item B<top_stream()>
 
 =back
 
-=over
+=over 4
 
 =item PRIVATE METHODS AND DATA
 
 =back
 
-=over
+=over 4
 
 =item B<_push_input_stream()>
 
 =back
 
-=over
+=over 4
 
 =item B<_pop_input_stream()>
 
 =back
 
-=over
+=over 4
 
 =item TREE-BASED PARSING
 
@@ -11994,13 +12268,13 @@ I<code-ref>|I<method-name>
 
 =head2 Pod::Plainer - Perl extension for converting Pod to old style Pod.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item EXPORT
 
@@ -12015,7 +12289,7 @@ I<code-ref>|I<method-name>
 =head2 Pod::Select, podselect() - extract selected sections of POD from
 input
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12031,55 +12305,55 @@ input
 
 =back
 
-=over
+=over 4
 
 =item OBJECT METHODS
 
 =back
 
-=over
+=over 4
 
 =item B<curr_headings()>
 
 =back
 
-=over
+=over 4
 
 =item B<select()>
 
 =back
 
-=over
+=over 4
 
 =item B<add_selection()>
 
 =back
 
-=over
+=over 4
 
 =item B<clear_selections()>
 
 =back
 
-=over
+=over 4
 
 =item B<match_section()>
 
 =back
 
-=over
+=over 4
 
 =item B<is_selected()>
 
 =back
 
-=over
+=over 4
 
 =item EXPORTED FUNCTIONS
 
 =back
 
-=over
+=over 4
 
 =item B<podselect()>
 
@@ -12087,31 +12361,31 @@ B<-output>, B<-sections>, B<-ranges>
 
 =back
 
-=over
+=over 4
 
 =item PRIVATE METHODS AND DATA
 
 =back
 
-=over
+=over 4
 
 =item B<_compile_section_spec()>
 
 =back
 
-=over
+=over 4
 
 =item $self->{_SECTION_HEADINGS}
 
 =back
 
-=over
+=over 4
 
 =item $self->{_SELECTED_SECTIONS}
 
 =back
 
-=over
+=over 4
 
 =item SEE ALSO
 
@@ -12121,7 +12395,7 @@ B<-output>, B<-sections>, B<-ranges>
 
 =head2 Pod::Text - Convert POD data to formatted ASCII text
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12147,7 +12421,24 @@ specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape:
 
 =head2 Pod::Text::Color - Convert POD data to formatted color ASCII text
 
-=over
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=back
+
+=head2 Pod::Text::Overstrike - Convert POD data to formatted overstrike
+text
+
+=over 4
 
 =item SYNOPSIS
 
@@ -12164,7 +12455,7 @@ specification "%s", %s:%d: Unknown command paragraph "%s", Unknown escape:
 =head2 Pod::Text::Termcap, Pod::Text::Color - Convert POD data to ASCII
 text with format escapes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12179,7 +12470,7 @@ text with format escapes
 =head2 Pod::Usage, pod2usage() - print a usage message from embedded pod
 documentation
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12192,7 +12483,7 @@ C<-pathlist>
 
 =item EXAMPLES
 
-=over
+=over 4
 
 =item Recommended Use
 
@@ -12208,7 +12499,7 @@ C<-pathlist>
 
 =head2 SDBM_File - Tied access to sdbm files
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12218,7 +12509,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =item DIAGNOSTICS
 
-=over
+=over 4
 
 =item C<sdbm store returned -1, errno 22, key "..." at ...>
 
@@ -12230,7 +12521,7 @@ C<O_RDONLY>, C<O_WRONLY>, C<O_RDWR>
 
 =head2 Safe - Compile and execute code in restricted compartments
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12240,7 +12531,7 @@ a new namespace, an operator mask
 
 =item WARNING
 
-=over
+=over 4
 
 =item RECENT CHANGES
 
@@ -12263,7 +12554,7 @@ Memory, CPU, Snooping, Signals, State Changes
 
 =head2 Search::Dict, look - search for key in dictionary file
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12273,7 +12564,7 @@ Memory, CPU, Snooping, Signals, State Changes
 
 =head2 SelectSaver - save and restore selected file handle
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12283,13 +12574,13 @@ Memory, CPU, Snooping, Signals, State Changes
 
 =head2 SelfLoader - load functions only on demand
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item The __DATA__ token
 
@@ -12311,13 +12602,13 @@ Memory, CPU, Snooping, Signals, State Changes
 
 =head2 Shell - run shell commands transparently within perl
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item OBJECT ORIENTED SYNTAX
 
@@ -12330,7 +12621,7 @@ Memory, CPU, Snooping, Signals, State Changes
 =head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C
 socket.h defines and structure manipulators 
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12346,7 +12637,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN
 
 =head2 Storable - persistency for perl data structures
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12364,7 +12655,7 @@ pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN
 
 =item WIZARDS ONLY
 
-=over
+=over 4
 
 =item Hooks
 
@@ -12400,7 +12691,7 @@ C<Storable::is_retrieving>
 
 =head2 Symbol - manipulate Perl symbols and their names
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12410,7 +12701,7 @@ C<Storable::is_retrieving>
 
 =head2 Sys::Hostname - Try every conceivable way to get hostname
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12423,7 +12714,7 @@ C<Storable::is_retrieving>
 =head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl
 interface to the UNIX syslog(3) calls
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12444,7 +12735,7 @@ closelog
 =head2 Syslog::Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog -
 Perl interface to the UNIX syslog(3) calls
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12464,7 +12755,7 @@ closelog
 
 =head2 Term::ANSIColor - Color screen output using ANSI escape sequences
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12486,7 +12777,7 @@ subs" in use
 
 =head2 Term::Cap - Perl termcap interface
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12498,7 +12789,7 @@ subs" in use
 
 =head2 Term::Complete - Perl word completion module
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12517,7 +12808,7 @@ E<lt>tabE<gt>, ^D, ^U, E<lt>delE<gt>, E<lt>bsE<gt>
 =head2 Term::ReadLine - Perl interface to various C<readline> packages. If
 no real package is found, substitutes stubs instead of basic functions.
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12540,7 +12831,7 @@ C<tkRunning>, C<ornaments>, C<newTTY>
 
 =head2  Test - provides a simple framework for writing test scripts
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12562,13 +12853,13 @@ NORMAL TESTS, SKIPPED TESTS, TODO TESTS
 
 =head2 Test::Harness - run perl standard test scripts with statistics
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item The test script output
 
@@ -12581,7 +12872,7 @@ NORMAL TESTS, SKIPPED TESTS, TODO TESTS
 C<All tests successful.\nFiles=%d,  Tests=%d, %s>, C<FAILED tests
 %s\n\tFailed %d/%d tests, %.2f%% okay.>, C<Test returned status %d (wstat
 %d)>, C<Failed 1 test, %.2f%% okay. %s>, C<Failed %d/%d tests, %.2f%% okay.
-%s>
+%s>, C<FAILED--Further testing stopped%s>
 
 =item ENVIRONMENT
 
@@ -12595,7 +12886,7 @@ C<All tests successful.\nFiles=%d,  Tests=%d, %s>, C<FAILED tests
 
 =head2 Text::Abbrev, abbrev - create an abbreviation table from a list
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12608,7 +12899,7 @@ C<All tests successful.\nFiles=%d,  Tests=%d, %s>, C<FAILED tests
 =head2 Text::ParseWords - parse text into an array of tokens or array of
 arrays
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12616,12 +12907,6 @@ arrays
 
 =item EXAMPLES
 
-0 a simple word, 1 multiple spaces are skipped because of our $delim, 2 use
-of quotes to include a space in a word, 3 use of a backslash to include a
-space in a word, 4 use of a backslash to remove the special meaning of a
-double-quote, 5 another simple word (note the lack of effect of the
-backslashed double-quote)
-
 =item AUTHORS
 
 =back
@@ -12629,7 +12914,7 @@ backslashed double-quote)
 =head2 Text::Soundex - Implementation of the Soundex Algorithm as Described
 by Knuth
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12646,7 +12931,7 @@ by Knuth
 =head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and
 unexpand(1)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12660,7 +12945,7 @@ unexpand(1)
 
 =head2 Text::Wrap - line wrapping to form simple paragraphs
 
-=over
+=over 4
 
 =item SYNOPSIS 
 
@@ -12675,7 +12960,7 @@ unexpand(1)
 =head2 Thread - manipulate threads in Perl (EXPERIMENTAL, subject to
 change)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12689,7 +12974,7 @@ cond_broadcast VARIABLE, yield
 
 =item METHODS
 
-join, eval, detach, equal, tid
+join, eval, detach, equal, tid, flags, done
 
 =item LIMITATIONS
 
@@ -12699,7 +12984,7 @@ join, eval, detach, equal, tid
 
 =head2 Thread::Queue - thread-safe queues
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12715,7 +13000,7 @@ new, enqueue LIST, dequeue, dequeue_nb, pending
 
 =head2 Thread::Semaphore - thread-safe semaphores
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12729,7 +13014,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER
 
 =head2 Thread::Signal - Start a thread which runs signal handlers reliably
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12741,7 +13026,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER
 
 =head2 Thread::Specific - thread-specific keys
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12751,7 +13036,7 @@ new, new NUMBER, down, down NUMBER, up, up NUMBER
 
 =head2 Tie::Array - base class for tied arrays
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12771,7 +13056,7 @@ SHIFT this, UNSHIFT this, LIST, SPLICE this, offset, length, LIST
 =head2 Tie::Handle, Tie::StdHandle  - base class definitions for tied
 handles
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12790,7 +13075,7 @@ EOF this, TELL this, SEEK this, offset, whence, DESTROY this
 
 =head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12807,7 +13092,7 @@ this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this
 
 =head2 Tie::RefHash - use references as hash keys
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12826,7 +13111,7 @@ this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this
 =head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied
 scalars
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12840,7 +13125,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
 
 =head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12852,7 +13137,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
 
 =head2 Time::Local - efficiently compute time from local and GMT time
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12867,7 +13152,7 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
 =head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
 function
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12882,7 +13167,7 @@ function
 =head2 Time::localtime - by-name interface to Perl's built-in localtime()
 function
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12896,7 +13181,7 @@ function
 
 =head2 Time::tm - internal object used by Time::gmtime and Time::localtime
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12908,7 +13193,7 @@ function
 
 =head2 UNIVERSAL - base class for ALL classes (blessed references)
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12922,7 +13207,7 @@ VAL, TYPE ), UNIVERSAL::can ( VAL, METHOD )
 =head2 User::grent - by-name interface to Perl's built-in getgr*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -12937,13 +13222,13 @@ functions
 =head2 User::pwent - by-name interface to Perl's built-in getpw*()
 functions
 
-=over
+=over 4
 
 =item SYNOPSIS
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item System Specifics
 
@@ -12961,11 +13246,11 @@ March 18th, 2000
 
 =head2 Win32 - Interfaces to some Win32 API Functions
 
-=over
+=over 4
 
 =item DESCRIPTION
 
-=over
+=over 4
 
 =item Alphabetical Listing of Win32 Functions
 
@@ -12977,8 +13262,7 @@ Win32::GetChipName(), Win32::GetCwd(), Win32::GetFullPathName(FILENAME),
 Win32::GetLastError(), Win32::GetLongPathName(PATHNAME),
 Win32::GetNextAvailDrive(), Win32::GetOSVersion(),
 Win32::GetShortPathName(PATHNAME), Win32::GetProcAddress(INSTANCE,
-PROCNAME), Win32::GetTickCount(), Win32::InitiateSystemShutdown(MACHINE,
-MESSAGE, TIMEOUT, FORCECLOSE, REBOOT), Win32::IsWinNT(), Win32::IsWin95(),
+PROCNAME), Win32::GetTickCount(), Win32::IsWinNT(), Win32::IsWin95(),
 Win32::LoadLibrary(LIBNAME), Win32::LoginName(),
 Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE),
 Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE),
@@ -12993,7 +13277,7 @@ PID), Win32::UnregisterServer(LIBRARYNAME)
 
 =head2 XSLoader - Dynamically load C libraries into Perl code
 
-=over
+=over 4
 
 =item SYNOPSIS
 
@@ -13008,7 +13292,7 @@ PID), Win32::UnregisterServer(LIBRARYNAME)
 Here should be listed all the extra programs' documentation, but they
 don't all have manual pages yet:
 
-=over
+=over 4
 
 =item a2p
 
index f12b10f..f38ba88 100644 (file)
@@ -111,10 +111,6 @@ problem for free.
 
 =head1 Perl Language
 
-=head2 our ($var)
-
-Declare global variables (lexically or otherwise).
-
 =head2 64-bit Perl
 
 Verify complete 64 bit support so that the value of sysseek, or C<-s>, or
@@ -532,14 +528,6 @@ Kurt Starsinic is working on h2ph.  mjd has fixed bugs in a2p in the
 past.  a2p apparently doesn't work on nawk and gawk extensions.
 Graham Barr has an Include module that does h2ph work at runtime.
 
-=head2 POD Converters
-
-Brad's PodParser code needs to become part of the core, and the Pod::*
-and pod2* programs rewritten to use this standard parser.  Currently
-the converters take different options, some behave in different
-fashions, and some are more picky than others in terms of the POD
-files they accept.
-
 =head2 pod2html
 
 A short-term fix: pod2html generates absolute HTML links.  Make it
index 31a7c76..594cb99 100644 (file)
@@ -1700,7 +1700,7 @@ as with any other local().
 It would be nice to combine Alias with
 something like Class::Struct or Class::MethodMaker.
 
-=head2 NOTES
+=head1 NOTES
 
 =head2 Object Terminology
 
@@ -1727,7 +1727,7 @@ as a class or object method is by usage only.  You could accidentally
 call a class method (one expecting a string argument) on an
 object (one expecting a reference), or vice versa.
 
-Z<>From the C++ perspective, all methods in Perl are virtual.
+From the C++ perspective, all methods in Perl are virtual.
 This, by the way, is why they are never checked for function
 prototypes in the argument list as regular builtin and user-defined
 functions can be.
index 0bcb638..ee0bd02 100644 (file)
@@ -12,7 +12,7 @@ the class itself.
 
 Here are a few examples where class attributes might come in handy:
 
-=over
+=over 4
 
 =item *
 
index c9954d8..30a4482 100644 (file)
@@ -10,7 +10,7 @@ WARNING: The implementation of Unicode support in Perl is incomplete.
 
 The following areas need further work.
 
-=over
+=over 4
 
 =item Input and Output Disciplines
 
@@ -198,6 +198,18 @@ byte-oriented C<chr()> and C<ord()> under utf8.
 
 =item *
 
+The bit string operators C<& | ^ ~> can operate on character data.
+However, for backward compatibility reasons (bit string operations
+when the characters all are less than 256 in ordinal value) one cannot
+mix C<~> (the bit complement) and characters both less than 256 and
+equal or greater than 256.  Most importantly, the DeMorgan's laws
+(C<~($x|$y) eq ~$x&~$y>, C<~($x&$y) eq ~$x|~$y>) won't hold.
+Another way to look at this is that the complement cannot return
+B<both> the 8-bit (byte) wide bit complement, and the full character
+wide bit complement.
+
+=item *
+
 And finally, C<scalar reverse()> reverses by character rather than by byte.
 
 =back
index 83f4d9c..49cdcb2 100644 (file)
@@ -619,7 +619,8 @@ across fork() calls.  (Mnemonic: same as shells.)
 =item $<
 
 The real uid of this process.  (Mnemonic: it's the uid you came I<from>,
-if you're running setuid.)
+if you're running setuid.)  You can change both the real uid and
+the effective uid at the same time by using POSIX::setuid().
 
 =item $EFFECTIVE_USER_ID
 
@@ -632,6 +633,9 @@ The effective uid of this process.  Example:
     $< = $>;           # set real to effective uid
     ($<,$>) = ($>,$<); # swap real and effective uid
 
+You can change both the effective uid and the real uid at the same
+time by using POSIX::setuid().
+
 (Mnemonic: it's the uid you went I<to>, if you're running setuid.)
 C<< $< >> and C<< $> >> can be swapped only on machines
 supporting setreuid().
@@ -652,6 +656,9 @@ However, a value assigned to C<$(> must be a single number used to
 set the real gid.  So the value given by C<$(> should I<not> be assigned
 back to C<$(> without being forced numeric, such as by adding zero.
 
+You can change both the real gid and the effective gid at the same
+time by using POSIX::setgid().
+
 (Mnemonic: parentheses are used to I<group> things.  The real gid is the
 group you I<left>, if you're running setgid.)
 
@@ -674,6 +681,9 @@ empty list for setgroups(), just repeat the new effective gid; that is,
 to force an effective gid of 5 and an effectively empty setgroups()
 list, say C< $) = "5 5" >.
 
+You can change both the effective gid and the real gid at the same
+time by using POSIX::setgid() (use only a single numeric argument).
+
 (Mnemonic: parentheses are used to I<group> things.  The effective gid
 is the group that's I<right> for you, if you're running setgid.)
 
index 781afe6..a4db596 100644 (file)
@@ -66,7 +66,9 @@ for the library being linked.
 A file in XS format starts with a C language section which goes until the
 first C<MODULE =Z<>> directive.  Other XS directives and XSUB definitions
 may follow this line.  The "language" used in this part of the file
-is usually referred to as the XS language.
+is usually referred to as the XS language.  B<xsubpp> recognizes and
+skips POD (see L<perlpod>) in both the C and XS language sections, which
+allows the XS file to contain embedded documentation. 
 
 See L<perlxstut> for a tutorial on the whole extension creation process.
 
@@ -207,9 +209,9 @@ separate lines and should be flush left-adjusted.
     double x                       sin(x)
                                     double x
 
-The rest of the function description may be indented or left-adjusted.  The following example
-shows a function with its body left-adjusted.  Most examples in this
-document will indent the body for better readability.
+The rest of the function description may be indented or left-adjusted. The
+following example shows a function with its body left-adjusted.  Most
+examples in this document will indent the body for better readability.
 
   CORRECT
 
@@ -276,16 +278,14 @@ mercy of this heuristics unless you use C<SV *> as return value.)
 
 =head2 The MODULE Keyword
 
-The MODULE keyword is used to start the XS code and to
-specify the package of the functions which are being
-defined.  All text preceding the first MODULE keyword is
-considered C code and is passed through to the output
-untouched.  Every XS module will have a bootstrap function
-which is used to hook the XSUBs into Perl.  The package name
-of this bootstrap function will match the value of the last
-MODULE statement in the XS source files.  The value of
-MODULE should always remain constant within the same XS
-file, though this is not required.
+The MODULE keyword is used to start the XS code and to specify the package
+of the functions which are being defined.  All text preceding the first
+MODULE keyword is considered C code and is passed through to the output with
+POD stripped, but otherwise untouched.  Every XS module will have a
+bootstrap function which is used to hook the XSUBs into Perl.  The package
+name of this bootstrap function will match the value of the last MODULE
+statement in the XS source files.  The value of MODULE should always remain
+constant within the same XS file, though this is not required.
 
 The following example will start the XS code and will place
 all functions in a package named RPC.
@@ -754,29 +754,37 @@ thus C<host> is initialized on the declaration line, and our assignment
 C<h = host> is not performed too early.  Otherwise one would need to have the
 assignment C<h = host> in a CODE: or INIT: section.)
 
-=head2 The IN/OUTLIST/IN_OUTLIST Keywords
+=head2 The IN/OUTLIST/IN_OUTLIST/OUT/IN_OUT Keywords
 
 In the list of parameters for an XSUB, one can precede parameter names
-by the C<IN>/C<OUTLIST>/C<IN_OUTLIST> keywords.  C<IN> keyword is a default,
-the other two keywords indicate how the Perl interface should differ from
-the C interface.
-
-Parameters preceded by C<OUTLIST>/C<IN_OUTLIST> keywords are considered to
-be used by the C subroutine I<via pointers>.  C<OUTLIST> keyword indicates
-that the C subroutine does not inspect the memory pointed by this parameter,
-but will write through this pointer to provide additional return values.
-Such parameters do not appear in the usage signature of the generated Perl
-function.
-
-Parameters preceded by C<IN_OUTLIST> I<do> appear as parameters to the
-Perl function.  These parameters are converted to the corresponding C type,
-then pointers to these data are given as arguments to the C function.  It
-is expected that the C function will write through these pointers 
+by the C<IN>/C<OUTLIST>/C<IN_OUTLIST>/C<OUT>/C<IN_OUT> keywords.
+C<IN> keyword is the default, the other keywords indicate how the Perl
+interface should differ from the C interface.
+
+Parameters preceded by C<OUTLIST>/C<IN_OUTLIST>/C<OUT>/C<IN_OUT>
+keywords are considered to be used by the C subroutine I<via
+pointers>.  C<OUTLIST>/C<OUT> keywords indicate that the C subroutine
+does not inspect the memory pointed by this parameter, but will write
+through this pointer to provide additional return values.
+
+Parameters preceded by C<OUTLIST> keyword do not appear in the usage
+signature of the generated Perl function.
+
+Parameters preceded by C<IN_OUTLIST>/C<IN_OUT>/C<OUT> I<do> appear as
+parameters to the Perl function.  With the exception of
+C<OUT>-parameters, these parameters are converted to the corresponding
+C type, then pointers to these data are given as arguments to the C
+function.  It is expected that the C function will write through these
+pointers.
 
 The return list of the generated Perl function consists of the C return value
 from the function (unless the XSUB is of C<void> return type or
-C<The NO_INIT Keyword> was used) followed by all the C<OUTLIST>
-and C<IN_OUTLIST> parameters (in the order of appearence).  Say, an XSUB
+C<The NO_OUTPUT Keyword> was used) followed by all the C<OUTLIST>
+and C<IN_OUTLIST> parameters (in the order of appearance).  On the
+return from the XSUB the C<IN_OUT>/C<OUT> Perl parameter will be
+modified to have the values written by the C function.
+
+For example, an XSUB
 
   void
   day_month(OUTLIST day, IN unix_time, OUTLIST month)
@@ -792,17 +800,30 @@ The C signature of the corresponding function should be
 
   void day_month(int *day, int unix_time, int *month);
 
-The C<in>/C<OUTLIST>/C<IN_OUTLIST> keywords can be mixed with ANSI-style
-declarations, as in
+The C<IN>/C<OUTLIST>/C<IN_OUTLIST>/C<IN_OUT>/C<OUT> keywords can be
+mixed with ANSI-style declarations, as in
 
   void
   day_month(OUTLIST int day, int unix_time, OUTLIST int month)
 
 (here the optional C<IN> keyword is omitted).
 
-The C<IN_OUTLIST> parameters are somewhat similar to parameters introduced
-with L<The & Unary Operator> and put into the C<OUTPUT:> section (see
-L<The OUTPUT: Keyword>).  Say, the same C function can be interfaced with as
+The C<IN_OUT> parameters are identical with parameters introduced with
+L<The & Unary Operator> and put into the C<OUTPUT:> section (see L<The
+OUTPUT: Keyword>).  The C<IN_OUTLIST> parameters are very similar, the
+only difference being that the value C function writes through the
+pointer would not modify the Perl parameter, but is put in the output
+list.
+
+The C<OUTLIST>/C<OUT> parameter differ from C<IN_OUTLIST>/C<IN_OUT>
+parameters only by the the initial value of the Perl parameter not
+being read (and not being given to the C function - which gets some
+garbage instead).  For example, the same C function as above can be
+interfaced with as
+
+  void day_month(OUT int day, int unix_time, OUT int month);
+
+or
 
   void
   day_month(day, unix_time, month)
@@ -1347,13 +1368,19 @@ C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>.
         OUTPUT:
           timep
 
-=head2 Inserting Comments and C Preprocessor Directives
+=head2 Inserting POD, Comments and C Preprocessor Directives
 
-C preprocessor directives are allowed within BOOT:, PREINIT: INIT:,
-CODE:, PPCODE:, POST_CALL:, and CLEANUP: blocks, as well as outside the functions.
-Comments are allowed anywhere after the MODULE keyword.  The compiler
-will pass the preprocessor directives through untouched and will remove
-the commented lines.
+C preprocessor directives are allowed within BOOT:, PREINIT: INIT:, CODE:,
+PPCODE:, POST_CALL:, and CLEANUP: blocks, as well as outside the functions.
+Comments are allowed anywhere after the MODULE keyword.  The compiler will
+pass the preprocessor directives through untouched and will remove the
+commented lines. POD documentation is allowed at any point, both in the
+C and XS language sections. POD must be terminated with a C<=cut> command;
+C<xsubpp> will exit with an error if it does not. It is very unlikely that
+human generated C code will be mistaken for POD, as most indenting styles
+result in whitespace in front of any line starting with C<=>. Machine
+generated XS files may fall into this trap unless care is taken to
+ensure that a space breaks the sequence "\n=".
 
 Comments can be added to XSUBs by placing a C<#> as the first
 non-whitespace of a line.  Care should be taken to avoid making the
@@ -1613,7 +1640,7 @@ getnetconfigent() XSUB and an object created by a normal Perl subroutine.
 
 The typemap is a collection of code fragments which are used by the B<xsubpp>
 compiler to map C function parameters and values to Perl values.  The
-typemap file may consist of three sections labeled C<TYPEMAP>, C<INPUT>, and
+typemap file may consist of three sections labelled C<TYPEMAP>, C<INPUT>, and
 C<OUTPUT>.  An unlabelled initial section is assumed to be a C<TYPEMAP>
 section.  The INPUT section tells
 the compiler how to translate Perl values
index 347b46e..5b7ed6d 100644 (file)
@@ -682,7 +682,8 @@ the meaning of these elements, pay attention to the line which reads
 
 Anything before this line is plain C code which describes which headers
 to include, and defines some convenience functions.  No translations are
-performed on this part, it goes into the generated output C file as is.
+performed on this part, apart from having embedded POD documentation
+skipped over (see L<perlpod>) it goes into the generated output C file as is.
 
 Anything after this line is the description of XSUB functions.
 These descriptions are translated by B<xsubpp> into C code which
index 4c5831b..f320a3c 100644 (file)
@@ -36,7 +36,7 @@ $Config{startperl}
 print OUT <<'!NO!SUBS!';
 
 # pod2man -- Convert POD data to formatted *roff input.
-# $Id: pod2man.PL,v 1.3 2000/09/03 09:20:52 eagle Exp $
+# $Id: pod2man.PL,v 1.4 2000/11/19 05:47:46 eagle Exp $
 #
 # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
 #
@@ -72,10 +72,15 @@ if ($options{official} && !defined $options{center}) {
     $options{center} = 'Perl Programmers Reference Guide';
 }
 
-# Initialize and run the formatter.
+# Initialize and run the formatter, pulling a pair of input and output off
+# at a time.
 my $parser = Pod::Man->new (%options);
-$parser->parse_from_file (@ARGV);
-
+my @files;
+do {
+    @files = splice (@ARGV, 0, 2);
+    $parser->parse_from_file (@files);
+} while (@ARGV);
+  
 __END__
 
 =head1 NAME
@@ -88,7 +93,7 @@ pod2man [B<--section>=I<manext>] [B<--release>=I<version>]
 [B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>]
 [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
 [B<--fixedbolditalic>=I<font>] [B<--official>] [B<--lax>]
-[B<--quotes>=I<quotes>] [I<input> [I<output>]]
+[B<--quotes>=I<quotes>] [I<input> [I<output>] ...]
 
 pod2man B<--help>
 
@@ -101,7 +106,10 @@ terminal using nroff(1), normally via man(1), or printing using troff(1).
 I<input> is the file to read for POD source (the POD can be embedded in
 code).  If I<input> isn't given, it defaults to STDIN.  I<output>, if given,
 is the file to which to write the formatted output.  If I<output> isn't
-given, the formatted output is written to STDOUT.
+given, the formatted output is written to STDOUT.  Several POD files can be
+processed in the same B<pod2man> invocation (saving module load and compile
+times) by providing multiple pairs of I<input> and I<output> files on the
+command line.
 
 B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be
 used to set the headers and footers to use; if not given, Pod::Man will
index b4965cb..7b5727d 100644 (file)
@@ -75,8 +75,8 @@ my %options;
 $options{sentence} = 0;
 Getopt::Long::config ('bundling');
 GetOptions (\%options, 'alt|a', 'color|c', 'help|h', 'indent|i=i',
-            'loose|l', 'quotes|q=s', 'sentence|s', 'termcap|t',
-            'width|w=i') or exit 1;
+            'loose|l', 'overstrike|o', 'quotes|q=s', 'sentence|s',
+            'termcap|t', 'width|w=i') or exit 1;
 pod2usage (1) if $options{help};
 
 # Figure out what formatter we're going to use.  -c overrides -t.
@@ -89,8 +89,11 @@ if ($options{color}) {
 } elsif ($options{termcap}) {
     $formatter = 'Pod::Text::Termcap';
     require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+    $formatter = 'Pod::Text::Overstrike';
+    require Pod::Text::Overstrike;
 }
-delete @options{'color', 'termcap'};
+delete @options{'color', 'termcap', 'overstrike'};
 
 # Initialize and run the formatter.
 my $parser = $formatter->new (%options);
@@ -104,7 +107,7 @@ pod2text - Convert POD data to formatted ASCII text
 
 =head1 SYNOPSIS
 
-pod2text [B<-aclst>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>]
+pod2text [B<-aclost>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>]
 [I<input> [I<output>]]
 
 pod2text B<-h>
@@ -150,6 +153,13 @@ printed after C<=head1>, although one is still printed after C<=head2>,
 because this is the expected formatting for manual pages; if you're
 formatting arbitrary text documents, using this option is recommended.
 
+=item B<-o>, B<--overstrike>
+
+Format the output with overstruck printing.  Bold text is rendered as
+character, backspace, character.  Italics and file names are rendered as
+underscore, backspace, character.  Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
 =item B<-q> I<quotes>, B<--quotes>=I<quotes>
 
 Sets the quote marks used to surround CE<lt>> text to I<quotes>.  If
diff --git a/pp.c b/pp.c
index 9afa96d..6bb1618 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1,6 +1,6 @@
 /*    pp.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -82,10 +82,6 @@ static double UV_MAX_cxux = ((double)UV_MAX);
 
 /* variations on pp_null */
 
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
 /* XXX I can't imagine anyone who doesn't have this actually _needs_
    it, since pid_t is an integral type.
    --AD  2/20/1998
@@ -178,7 +174,7 @@ PP(pp_padany)
 
 PP(pp_rv2gv)
 {
-    djSP; dTOPss;  
+    djSP; dTOPss;
 
     if (SvROK(sv)) {
       wasref:
@@ -206,9 +202,9 @@ PP(pp_rv2gv)
                    goto wasref;
            }
            if (!SvOK(sv) && sv != &PL_sv_undef) {
-               /* If this is a 'my' scalar and flag is set then vivify 
+               /* If this is a 'my' scalar and flag is set then vivify
                 * NI-S 1999/05/07
-                */ 
+                */
                if (PL_op->op_private & OPpDEREF) {
                    char *name;
                    GV *gv;
@@ -223,7 +219,8 @@ PP(pp_rv2gv)
                        name = CopSTASHPV(PL_curcop);
                        gv = newGVgen(name);
                    }
-                   sv_upgrade(sv, SVt_RV);
+                   if (SvTYPE(sv) < SVt_RV)
+                       sv_upgrade(sv, SVt_RV);
                    SvRV(sv) = (SV*)gv;
                    SvROK_on(sv);
                    SvSETMAGIC(sv);
@@ -388,8 +385,12 @@ PP(pp_rv2cv)
     if (cv) {
        if (CvCLONE(cv))
            cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-       if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
-           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       if ((PL_op->op_private & OPpLVAL_INTRO)) {
+           if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
+               cv = GvCV(gv);
+           if (!CvLVALUE(cv))
+               DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       }
     }
     else
        cv = (CV*)&PL_sv_undef;
@@ -410,7 +411,7 @@ PP(pp_prototype)
        char *s = SvPVX(TOPs);
        if (strnEQ(s, "CORE::", 6)) {
            int code;
-           
+       
            code = keyword(s + 6, SvCUR(TOPs) - 6);
            if (code < 0) {     /* Overridable. */
 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
@@ -430,13 +431,13 @@ PP(pp_prototype)
              found:
                oa = PL_opargs[i] >> OASHIFT;
                while (oa) {
-                   if (oa & OA_OPTIONAL) {
+                   if (oa & OA_OPTIONAL && !seen_question) {
                        seen_question = 1;
                        str[n++] = ';';
                    }
-                   else if (n && str[0] == ';' && seen_question) 
+                   else if (n && str[0] == ';' && seen_question)
                        goto set;       /* XXXX system, exec */
-                   if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 
+                   if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
                        && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
                        str[n++] = '\\';
                    }
@@ -567,7 +568,7 @@ PP(pp_bless)
            Perl_croak(aTHX_ "Attempt to bless into a reference");
        ptr = SvPV(ssv,len);
        if (ckWARN(WARN_MISC) && len == 0)
-           Perl_warner(aTHX_ WARN_MISC, 
+           Perl_warner(aTHX_ WARN_MISC,
                   "Explicit blessing to '' (assuming package main)");
        stash = gv_stashpvn(ptr, len, TRUE);
     }
@@ -584,7 +585,7 @@ PP(pp_gelem)
     char *elem;
     djSP;
     STRLEN n_a;
+
     sv = POPs;
     elem = SvPV(sv, n_a);
     gv = (GV*)POPs;
@@ -928,6 +929,114 @@ PP(pp_pow)
 PP(pp_multiply)
 {
     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       /* Unless the left argument is integer in range we are going to have to
+          use NV maths. Hence only attempt to coerce the right argument if
+          we know the left is integer.  */
+       /* Left operand is defined, so is it IV? */
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+           const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
+           const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
+           UV alow;
+           UV ahigh;
+           UV blow;
+           UV bhigh;
+
+           if (auvok) {
+               alow = SvUVX(TOPm1s);
+           } else {
+               IV aiv = SvIVX(TOPm1s);
+               if (aiv >= 0) {
+                   alow = aiv;
+                   auvok = TRUE; /* effectively it's a UV now */
+               } else {
+                   alow = -aiv; /* abs, auvok == false records sign */
+               }
+           }
+           if (buvok) {
+               blow = SvUVX(TOPs);
+           } else {
+               IV biv = SvIVX(TOPs);
+               if (biv >= 0) {
+                   blow = biv;
+                   buvok = TRUE; /* effectively it's a UV now */
+               } else {
+                   blow = -biv; /* abs, buvok == false records sign */
+               }
+           }
+
+           /* If this does sign extension on unsigned it's time for plan B  */
+           ahigh = alow >> (4 * sizeof (UV));
+           alow &= botmask;
+           bhigh = blow >> (4 * sizeof (UV));
+           blow &= botmask;
+           if (ahigh && bhigh) {
+               /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
+                  which is overflow. Drop to NVs below.  */
+           } else if (!ahigh && !bhigh) {
+               /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
+                  so the unsigned multiply cannot overflow.  */
+               UV product = alow * blow;
+               if (auvok == buvok) {
+                   /* -ve * -ve or +ve * +ve gives a +ve result.  */
+                   SP--;
+                   SETu( product );
+                   RETURN;
+               } else if (product <= (UV)IV_MIN) {
+                   /* 2s complement assumption that (UV)-IV_MIN is correct.  */
+                   /* -ve result, which could overflow an IV  */
+                   SP--;
+                   SETi( -product );
+                   RETURN;
+               } /* else drop to NVs below. */
+           } else {
+               /* One operand is large, 1 small */
+               UV product_middle;
+               if (bhigh) {
+                   /* swap the operands */
+                   ahigh = bhigh;
+                   bhigh = blow; /* bhigh now the temp var for the swap */
+                   blow = alow;
+                   alow = bhigh;
+               }
+               /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
+                  multiplies can't overflow. shift can, add can, -ve can.  */
+               product_middle = ahigh * blow;
+               if (!(product_middle & topmask)) {
+                   /* OK, (ahigh * blow) won't lose bits when we shift it.  */
+                   UV product_low;
+                   product_middle <<= (4 * sizeof (UV));
+                   product_low = alow * blow;
+
+                   /* as for pp_add, UV + something mustn't get smaller.
+                      IIRC ANSI mandates this wrapping *behaviour* for
+                      unsigned whatever the actual representation*/
+                   product_low += product_middle;
+                   if (product_low >= product_middle) {
+                       /* didn't overflow */
+                       if (auvok == buvok) {
+                           /* -ve * -ve or +ve * +ve gives a +ve result.  */
+                           SP--;
+                           SETu( product_low );
+                           RETURN;
+                       } else if (product_low <= (UV)IV_MIN) {
+                           /* 2s complement assumption again  */
+                           /* -ve result, which could overflow an IV  */
+                           SP--;
+                           SETi( -product_low );
+                           RETURN;
+                       } /* else drop to NVs below. */
+                   }
+               } /* product_middle too large */
+           } /* ahigh && bhigh */
+       } /* SvIOK(TOPm1s) */
+    } /* SvIOK(TOPs) */
+#endif
     {
       dPOPTOPnnrl;
       SETn( left * right );
@@ -1119,11 +1228,146 @@ PP(pp_repeat)
 
 PP(pp_subtract)
 {
-    djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+    djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
+    useleft = USE_LEFT(TOPm1s);
+#ifdef PERL_PRESERVE_IVUV
+    /* We must see if we can perform the addition with integers if possible,
+       as the integer code detects overflow while the NV code doesn't.
+       If either argument hasn't had a numeric conversion yet attempt to get
+       the IV. It's important to do this now, rather than just assuming that
+       it's not IOK as a PV of "9223372036854775806" may not take well to NV
+       addition, and an SV which is NOK, NV=6.0 ought to be coerced to
+       integer in case the second argument is IV=9223372036854775806
+       We can (now) rely on sv_2iv to do the right thing, only setting the
+       public IOK flag if the value in the NV (or PV) slot is truly integer.
+
+       A side effect is that this also aggressively prefers integer maths over
+       fp maths for integer values.  */
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       /* Unless the left argument is integer in range we are going to have to
+          use NV maths. Hence only attempt to coerce the right argument if
+          we know the left is integer.  */
+       if (!useleft) {
+           /* left operand is undef, treat as zero. + 0 is identity. */
+           if (SvUOK(TOPs)) {
+               dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
+               if (value <= (UV)IV_MIN) {
+                   /* 2s complement assumption.  */
+                   SETi(-(IV)value);
+                   RETURN;
+               } /* else drop through into NVs below */
+           } else {
+               dPOPiv;
+               SETu((UV)-value);
+               RETURN;
+           }
+       } else {
+           /* Left operand is defined, so is it IV? */
+           SvIV_please(TOPm1s);
+           if (SvIOK(TOPm1s)) {
+               bool auvok = SvUOK(TOPm1s);
+               bool buvok = SvUOK(TOPs);
+       
+               if (!auvok && !buvok) { /* ## IV - IV ## */
+                   IV aiv = SvIVX(TOPm1s);
+                   IV biv = SvIVX(TOPs);
+                   IV result = aiv - biv;
+               
+                   if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
+                       SP--;
+                       SETi( result );
+                       RETURN;
+                   }
+                   /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
+                   /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
+                   /* -ve - +ve can only overflow too negative. */
+                   /* leaving +ve - -ve, which will go UV */
+                   if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
+                       /* 2s complement assumption for IV_MIN */
+                       UV result = (UV)aiv + (UV)-biv;
+                       /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
+                          overflow UV (2s complement assumption */
+                       assert (result >= (UV) aiv);
+                       SP--;
+                       SETu( result );
+                       RETURN;
+                   }
+                   /* Overflow, drop through to NVs */
+               } else if (auvok && buvok) {    /* ## UV - UV ## */
+                   UV auv = SvUVX(TOPm1s);
+                   UV buv = SvUVX(TOPs);
+                   IV result;
+               
+                   if (auv >= buv) {
+                       SP--;
+                       SETu( auv - buv );
+                       RETURN;
+                   }
+                   /* Blatant 2s complement assumption.  */
+                   result = (IV)(auv - buv);
+                   if (result < 0) {
+                       SP--;
+                       SETi( result );
+                       RETURN;
+                   }
+                   /* Overflow on IV - IV, drop through to NVs */
+               } else if (auvok) {     /* ## Mixed UV - IV ## */
+                   UV auv = SvUVX(TOPm1s);
+                   IV biv = SvIVX(TOPs);
+
+                   if (biv < 0) {
+                       /* 2s complement assumptions for IV_MIN */
+                       UV result = auv + ((UV)-biv);
+                       /* UV + UV can only get bigger... */
+                       if (result >= auv) {
+                           SP--;
+                           SETu( result );
+                           RETURN;
+                       }
+                       /* and if it gets too big for UV then it's NV time.  */
+                   } else if (auv > (UV)IV_MAX) {
+                       /* I think I'm making an implicit 2s complement
+                          assumption that IV_MIN == -IV_MAX - 1 */
+                       /* biv is >= 0 */
+                       UV result = auv - (UV)biv;
+                       assert (result <= auv);
+                       SP--;
+                       SETu( result );
+                       RETURN;
+                   } else {
+                       /* biv is >= 0 */
+                       IV result = (IV)auv - biv;
+                       assert (result <= (IV)auv);
+                       SP--;
+                       SETi( result );
+                       RETURN;
+                   }
+               } else {                /* ## Mixed IV - UV ## */
+                   IV aiv = SvIVX(TOPm1s);
+                   UV buv = SvUVX(TOPs);
+                   IV result = aiv - (IV)buv; /* 2s complement assumption. */
+               
+                   /* result must not get larger. */
+                   if (result <= aiv) {
+                       SP--;
+                       SETi( result );
+                       RETURN;
+                   } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
+               }
+           }
+       }
+    }
+#endif
     {
-      dPOPTOPnnrl_ul;
-      SETn( left - right );
-      RETURN;
+       dPOPnv;
+       if (!useleft) {
+           /* left operand is undef, treat as zero - value */
+           SETn(-value);
+           RETURN;
+       }
+       SETn( TOPn - value );
+       RETURN;
     }
 }
 
@@ -1164,6 +1408,74 @@ PP(pp_right_shift)
 PP(pp_lt)
 {
     djSP; tryAMAGICbinSET(lt,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV < IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv < biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV < UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv < buv));
+               RETURN;
+           }
+           if (auvok) { /* ## UV < IV ## */
+               UV auv;
+               IV biv;
+               
+               biv = SvIVX(TOPs);
+               SP--;
+               if (biv < 0) {
+                   /* As (a) is a UV, it's >=0, so it cannot be < */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               auv = SvUVX(TOPs);
+               if (auv >= (UV) IV_MAX) {
+                   /* As (b) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               SETs(boolSV(auv < (UV)biv));
+               RETURN;
+           }
+           { /* ## IV < UV ## */
+               IV aiv;
+               UV buv;
+               
+               aiv = SvIVX(TOPm1s);
+               if (aiv < 0) {
+                   /* As (b) is a UV, it's >=0, so it must be < */
+                   SP--;
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               buv = SvUVX(TOPs);
+               SP--;
+               if (buv > (UV) IV_MAX) {
+                   /* As (a) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               SETs(boolSV((UV)aiv < buv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn < value));
@@ -1174,6 +1486,74 @@ PP(pp_lt)
 PP(pp_gt)
 {
     djSP; tryAMAGICbinSET(gt,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV > IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv > biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV > UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv > buv));
+               RETURN;
+           }
+           if (auvok) { /* ## UV > IV ## */
+               UV auv;
+               IV biv;
+               
+               biv = SvIVX(TOPs);
+               SP--;
+               if (biv < 0) {
+                   /* As (a) is a UV, it's >=0, so it must be > */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               auv = SvUVX(TOPs);
+               if (auv > (UV) IV_MAX) {
+                   /* As (b) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               SETs(boolSV(auv > (UV)biv));
+               RETURN;
+           }
+           { /* ## IV > UV ## */
+               IV aiv;
+               UV buv;
+               
+               aiv = SvIVX(TOPm1s);
+               if (aiv < 0) {
+                   /* As (b) is a UV, it's >=0, so it cannot be > */
+                   SP--;
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               buv = SvUVX(TOPs);
+               SP--;
+               if (buv >= (UV) IV_MAX) {
+                   /* As (a) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               SETs(boolSV((UV)aiv > buv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn > value));
@@ -1184,6 +1564,74 @@ PP(pp_gt)
 PP(pp_le)
 {
     djSP; tryAMAGICbinSET(le,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV <= IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv <= biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV <= UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv <= buv));
+               RETURN;
+           }
+           if (auvok) { /* ## UV <= IV ## */
+               UV auv;
+               IV biv;
+               
+               biv = SvIVX(TOPs);
+               SP--;
+               if (biv < 0) {
+                   /* As (a) is a UV, it's >=0, so a cannot be <= */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               auv = SvUVX(TOPs);
+               if (auv > (UV) IV_MAX) {
+                   /* As (b) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               SETs(boolSV(auv <= (UV)biv));
+               RETURN;
+           }
+           { /* ## IV <= UV ## */
+               IV aiv;
+               UV buv;
+               
+               aiv = SvIVX(TOPm1s);
+               if (aiv < 0) {
+                   /* As (b) is a UV, it's >=0, so a must be <= */
+                   SP--;
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               buv = SvUVX(TOPs);
+               SP--;
+               if (buv >= (UV) IV_MAX) {
+                   /* As (a) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               SETs(boolSV((UV)aiv <= buv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn <= value));
@@ -1194,6 +1642,74 @@ PP(pp_le)
 PP(pp_ge)
 {
     djSP; tryAMAGICbinSET(ge,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV >= IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv >= biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV >= UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv >= buv));
+               RETURN;
+           }
+           if (auvok) { /* ## UV >= IV ## */
+               UV auv;
+               IV biv;
+               
+               biv = SvIVX(TOPs);
+               SP--;
+               if (biv < 0) {
+                   /* As (a) is a UV, it's >=0, so it must be >= */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               auv = SvUVX(TOPs);
+               if (auv >= (UV) IV_MAX) {
+                   /* As (b) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               SETs(boolSV(auv >= (UV)biv));
+               RETURN;
+           }
+           { /* ## IV >= UV ## */
+               IV aiv;
+               UV buv;
+               
+               aiv = SvIVX(TOPm1s);
+               if (aiv < 0) {
+                   /* As (b) is a UV, it's >=0, so a cannot be >= */
+                   SP--;
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               buv = SvUVX(TOPs);
+               SP--;
+               if (buv > (UV) IV_MAX) {
+                   /* As (a) is an IV, it cannot be > IV_MAX */
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               SETs(boolSV((UV)aiv >= buv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn >= value));
@@ -1204,6 +1720,66 @@ PP(pp_ge)
 PP(pp_ne)
 {
     djSP; tryAMAGICbinSET(ne,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV <=> IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv != biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV != UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv != buv));
+               RETURN;
+           }
+           {                   /* ## Mixed IV,UV ## */
+               IV iv;
+               UV uv;
+               
+               /* != is commutative so swap if needed (save code) */
+               if (auvok) {
+                   /* swap. top of stack (b) is the iv */
+                   iv = SvIVX(TOPs);
+                   SP--;
+                   if (iv < 0) {
+                       /* As (a) is a UV, it's >0, so it cannot be == */
+                       SETs(&PL_sv_yes);
+                       RETURN;
+                   }
+                   uv = SvUVX(TOPs);
+               } else {
+                   iv = SvIVX(TOPm1s);
+                   SP--;
+                   if (iv < 0) {
+                       /* As (b) is a UV, it's >0, so it cannot be == */
+                       SETs(&PL_sv_yes);
+                       RETURN;
+                   }
+                   uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
+               }
+               /* we know iv is >= 0 */
+               if (uv > (UV) IV_MAX) {
+                   SETs(&PL_sv_yes);
+                   RETURN;
+               }
+               SETs(boolSV((UV)iv != uv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn != value));
@@ -1214,6 +1790,84 @@ PP(pp_ne)
 PP(pp_ncmp)
 {
     djSP; dTARGET; tryAMAGICbin(ncmp,0);
+#ifdef PERL_PRESERVE_IVUV
+    /* Fortunately it seems NaN isn't IOK */
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool leftuvok = SvUOK(TOPm1s);
+           bool rightuvok = SvUOK(TOPs);
+           I32 value;
+           if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
+               IV leftiv = SvIVX(TOPm1s);
+               IV rightiv = SvIVX(TOPs);
+               
+               if (leftiv > rightiv)
+                   value = 1;
+               else if (leftiv < rightiv)
+                   value = -1;
+               else
+                   value = 0;
+           } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
+               UV leftuv = SvUVX(TOPm1s);
+               UV rightuv = SvUVX(TOPs);
+               
+               if (leftuv > rightuv)
+                   value = 1;
+               else if (leftuv < rightuv)
+                   value = -1;
+               else
+                   value = 0;
+           } else if (leftuvok) { /* ## UV <=> IV ## */
+               UV leftuv;
+               IV rightiv;
+               
+               rightiv = SvIVX(TOPs);
+               if (rightiv < 0) {
+                   /* As (a) is a UV, it's >=0, so it cannot be < */
+                   value = 1;
+               } else {
+                   leftuv = SvUVX(TOPm1s);
+                   if (leftuv > (UV) IV_MAX) {
+                       /* As (b) is an IV, it cannot be > IV_MAX */
+                       value = 1;
+                   } else if (leftuv > (UV)rightiv) {
+                       value = 1;
+                   } else if (leftuv < (UV)rightiv) {
+                       value = -1;
+                   } else {
+                       value = 0;
+                   }
+               }
+           } else { /* ## IV <=> UV ## */
+               IV leftiv;
+               UV rightuv;
+               
+               leftiv = SvIVX(TOPm1s);
+               if (leftiv < 0) {
+                   /* As (b) is a UV, it's >=0, so it must be < */
+                   value = -1;
+               } else {
+                   rightuv = SvUVX(TOPs);
+                   if (rightuv > (UV) IV_MAX) {
+                       /* As (a) is an IV, it cannot be > IV_MAX */
+                       value = -1;
+                   } else if (leftiv > (UV)rightuv) {
+                       value = 1;
+                   } else if (leftiv < (UV)rightuv) {
+                       value = -1;
+                   } else {
+                       value = 0;
+                   }
+               }
+           }
+           SP--;
+           SETi(value);
+           RETURN;
+       }
+    }
+#endif
     {
       dPOPTOPnnrl;
       I32 value;
@@ -1400,11 +2054,15 @@ PP(pp_negate)
     djSP; dTARGET; tryAMAGICun(neg);
     {
        dTOPss;
+       int flags = SvFLAGS(sv);
        if (SvGMAGICAL(sv))
            mg_get(sv);
-       if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
+       if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+           /* It's publicly an integer, or privately an integer-not-float */
+       oops_its_an_int:
            if (SvIsUV(sv)) {
                if (SvIVX(sv) == IV_MIN) {
+                   /* 2s complement assumption. */
                    SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
                    RETURN;
                }
@@ -1417,6 +2075,12 @@ PP(pp_negate)
                SETi(-SvIVX(sv));
                RETURN;
            }
+#ifdef PERL_PRESERVE_IVUV
+           else {
+               SETu((UV)IV_MIN);
+               RETURN;
+           }
+#endif
        }
        if (SvNIOKp(sv))
            SETn(-SvNV(sv));
@@ -1431,12 +2095,16 @@ PP(pp_negate)
                sv_setsv(TARG, sv);
                *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
            }
-           else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
+           else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
                sv_setpvn(TARG, "-", 1);
                sv_catsv(TARG, sv);
            }
-           else
-               sv_setnv(TARG, -SvNV(sv));
+           else {
+             SvIV_please(sv);
+             if (SvIOK(sv))
+               goto oops_its_an_int;
+             sv_setnv(TARG, -SvNV(sv));
+           }
            SETTARG;
        }
        else
@@ -1476,31 +2144,50 @@ PP(pp_complement)
        tmps = (U8*)SvPV_force(TARG, len);
        anum = len;
        if (SvUTF8(TARG)) {
-         /* Calculate exact length, let's not estimate */
+         /* Calculate exact length, let's not estimate. */
          STRLEN targlen = 0;
          U8 *result;
          U8 *send;
-         I32 l;
+         STRLEN l;
+         UV nchar = 0;
+         UV nwide = 0;
 
          send = tmps + len;
          while (tmps < send) {
-           UV c = utf8_to_uv(tmps, &l);
+           UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
            tmps += UTF8SKIP(tmps);
-           targlen += UTF8LEN(~c);
+           targlen += UNISKIP(~c);
+           nchar++;
+           if (c > 0xff)
+               nwide++;
          }
 
          /* Now rewind strings and write them. */
          tmps -= len;
-         Newz(0, result, targlen + 1, U8);
-         while (tmps < send) {
-           UV c = utf8_to_uv(tmps, &l);
-           tmps += UTF8SKIP(tmps);
-           result = uv_to_utf8(result,(UV)~c);
+
+         if (nwide) {
+             Newz(0, result, targlen + 1, U8);
+             while (tmps < send) {
+                 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
+                 tmps += UTF8SKIP(tmps);
+                 result = uv_to_utf8(result, ~c);
+             }
+             *result = '\0';
+             result -= targlen;
+             sv_setpvn(TARG, (char*)result, targlen);
+             SvUTF8_on(TARG);
+         }
+         else {
+             Newz(0, result, nchar + 1, U8);
+             while (tmps < send) {
+                 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
+                 tmps += UTF8SKIP(tmps);
+                 *result++ = ~c;
+             }
+             *result = '\0';
+             result -= nchar;
+             sv_setpvn(TARG, (char*)result, nchar);
          }
-         *result = '\0';
-         result -= targlen;
-         sv_setpvn(TARG, (char*)result, targlen);
-         SvUTF8_on(TARG);
          Safefree(result);
          SETs(TARG);
          RETURN;
@@ -1552,7 +2239,7 @@ PP(pp_i_divide)
 
 PP(pp_i_modulo)
 {
-    djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 
+    djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
     {
       dPOPTOPiirl;
       if (!right)
@@ -1566,7 +2253,7 @@ PP(pp_i_add)
 {
     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_ul;
       SETi( left + right );
       RETURN;
     }
@@ -1576,7 +2263,7 @@ PP(pp_i_subtract)
 {
     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
     {
-      dPOPTOPiirl;
+      dPOPTOPiirl_ul;
       SETi( left - right );
       RETURN;
     }
@@ -1776,7 +2463,6 @@ S_seed(pTHX)
 #define   SEED_C3      269
 #define   SEED_C5      26107
 
-    dTHR;
 #ifndef PERL_NO_DEV_RANDOM
     int fd;
 #endif
@@ -1881,25 +2567,49 @@ PP(pp_int)
 {
     djSP; dTARGET;
     {
-      NV value = TOPn;
-      IV iv;
-
-      if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
-       iv = SvIVX(TOPs);
-       SETi(iv);
-      }
-      else {
-       if (value >= 0.0)
-         (void)Perl_modf(value, &value);
-       else {
-         (void)Perl_modf(-value, &value);
-         value = -value;
-       }
-       iv = I_V(value);
-       if (iv == value)
-         SETi(iv);
-       else
-         SETn(value);
+      NV value;
+      IV iv = TOPi; /* attempt to convert to IV if possible. */
+      /* XXX it's arguable that compiler casting to IV might be subtly
+        different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
+        else preferring IV has introduced a subtle behaviour change bug. OTOH
+        relying on floating point to be accurate is a bug.  */
+
+      if (SvIOK(TOPs)) {
+       if (SvIsUV(TOPs)) {
+           UV uv = TOPu;
+           SETu(uv);
+       } else
+           SETi(iv);
+      } else {
+         value = TOPn;
+         if (value >= 0.0) {
+             if (value < (NV)UV_MAX + 0.5) {
+                 SETu(U_V(value));
+             } else {
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+                 (void)Perl_modf(value, &value);
+#else
+                 double tmp = (double)value;
+                 (void)Perl_modf(tmp, &tmp);
+                 value = (NV)tmp;
+#endif
+             }
+         }
+         else {
+             if (value > (NV)IV_MIN - 0.5) {
+                 SETi(I_V(value));
+             } else {
+#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+                 (void)Perl_modf(-value, &value);
+                 value = -value;
+#else
+                 double tmp = (double)value;
+                 (void)Perl_modf(-tmp, &tmp);
+                 value = -(NV)tmp;
+#endif
+                 SETn(value);
+             }
+         }
       }
     }
     RETURN;
@@ -1909,18 +2619,30 @@ PP(pp_abs)
 {
     djSP; dTARGET; tryAMAGICun(abs);
     {
-      NV value = TOPn;
-      IV iv;
-
-      if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
-         (iv = SvIVX(TOPs)) != IV_MIN) {
-       if (iv < 0)
-         iv = -iv;
-       SETi(iv);
-      }
-      else {
+      /* This will cache the NV value if string isn't actually integer  */
+      IV iv = TOPi;
+
+      if (SvIOK(TOPs)) {
+       /* IVX is precise  */
+       if (SvIsUV(TOPs)) {
+         SETu(TOPu);   /* force it to be numeric only */
+       } else {
+         if (iv >= 0) {
+           SETi(iv);
+         } else {
+           if (iv != IV_MIN) {
+             SETi(-iv);
+           } else {
+             /* 2s complement assumption. Also, not really needed as
+                IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
+             SETu(IV_MIN);
+           }
+         }
+       }
+      } else{
+       NV value = TOPn;
        if (value < 0.0)
-           value = -value;
+         value = -value;
        SETn(value);
       }
     }
@@ -1931,7 +2653,7 @@ PP(pp_hex)
 {
     djSP; dTARGET;
     char *tmps;
-    I32 argtype;
+    STRLEN argtype;
     STRLEN n_a;
 
     tmps = POPpx;
@@ -1944,7 +2666,7 @@ PP(pp_oct)
 {
     djSP; dTARGET;
     NV value;
-    I32 argtype;
+    STRLEN argtype;
     char *tmps;
     STRLEN n_a;
 
@@ -2220,17 +2942,11 @@ PP(pp_sprintf)
 PP(pp_ord)
 {
     djSP; dTARGET;
-    UV value;
-    STRLEN n_a;
-    SV *tmpsv = POPs;
-    U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
-    I32 retlen;
+    SV *argsv = POPs;
+    STRLEN len;
+    U8 *s = (U8*)SvPVx(argsv, len);
 
-    if ((*tmps & 0x80) && DO_UTF8(tmpsv))
-       value = utf8_to_uv_chk(tmps, &retlen, 0);
-    else
-       value = (UV)(*tmps & 255);
-    XPUSHu(value);
+    XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
     RETURN;
 }
 
@@ -2242,7 +2958,8 @@ PP(pp_chr)
 
     (void)SvUPGRADE(TARG,SVt_PV);
 
-    if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
+    if ((value > 255 && !IN_BYTE) ||
+       (UTF8_IS_CONTINUED(value) && (PL_hints & HINT_UTF8)) ) {
        SvGROW(TARG, UTF8_MAXLEN+1);
        tmps = SvPVX(TARG);
        tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
@@ -2253,6 +2970,9 @@ PP(pp_chr)
        XPUSHs(TARG);
        RETURN;
     }
+    else {
+       SvUTF8_off(TARG);
+    }
 
     SvGROW(TARG,2);
     SvCUR_set(TARG, 1);
@@ -2276,7 +2996,7 @@ PP(pp_crypt)
     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
 #endif
 #else
-    DIE(aTHX_ 
+    DIE(aTHX_
       "The crypt() function is unimplemented due to excessive paranoia.");
 #endif
     SETs(TARG);
@@ -2290,11 +3010,11 @@ PP(pp_ucfirst)
     register U8 *s;
     STRLEN slen;
 
-    if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
-       I32 ulen;
-       U8 tmpbuf[UTF8_MAXLEN];
+    if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
+       STRLEN ulen;
+       U8 tmpbuf[UTF8_MAXLEN+1];
        U8 *tend;
-       UV uv = utf8_to_uv_chk(s, &ulen, 0);
+       UV uv = utf8_to_uv(s, slen, &ulen, 0);
 
        if (PL_op->op_private & OPpLOCALE) {
            TAINT;
@@ -2349,11 +3069,11 @@ PP(pp_lcfirst)
     register U8 *s;
     STRLEN slen;
 
-    if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
-       I32 ulen;
-       U8 tmpbuf[UTF8_MAXLEN];
+    if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
+       STRLEN ulen;
+       U8 tmpbuf[UTF8_MAXLEN+1];
        U8 *tend;
-       UV uv = utf8_to_uv_chk(s, &ulen, 0);
+       UV uv = utf8_to_uv(s, slen, &ulen, 0);
 
        if (PL_op->op_private & OPpLOCALE) {
            TAINT;
@@ -2410,7 +3130,7 @@ PP(pp_uc)
 
     if (DO_UTF8(sv)) {
        dTARGET;
-       I32 ulen;
+       STRLEN ulen;
        register U8 *d;
        U8 *send;
 
@@ -2430,7 +3150,7 @@ PP(pp_uc)
                TAINT;
                SvTAINTED_on(TARG);
                while (s < send) {
-                   d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv_chk(s, &ulen, 0)));
+                   d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
                    s += ulen;
                }
            }
@@ -2484,7 +3204,7 @@ PP(pp_lc)
 
     if (DO_UTF8(sv)) {
        dTARGET;
-       I32 ulen;
+       STRLEN ulen;
        register U8 *d;
        U8 *send;
 
@@ -2504,7 +3224,7 @@ PP(pp_lc)
                TAINT;
                SvTAINTED_on(TARG);
                while (s < send) {
-                   d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv_chk(s, &ulen, 0)));
+                   d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
                    s += ulen;
                }
            }
@@ -2565,7 +3285,7 @@ PP(pp_quotemeta)
        d = SvPVX(TARG);
        if (DO_UTF8(sv)) {
            while (len) {
-               if (*s & 0x80) {
+               if (UTF8_IS_CONTINUED(*s)) {
                    STRLEN ulen = UTF8SKIP(s);
                    if (ulen > len)
                        ulen = len;
@@ -2805,6 +3525,7 @@ PP(pp_hslice)
        while (++MARK <= SP) {
            SV *keysv = *MARK;
            SV **svp;
+           I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
            if (realhv) {
                HE *he = hv_fetch_ent(hv, keysv, lval, 0);
                svp = he ? &HeVAL(he) : 0;
@@ -2817,8 +3538,15 @@ PP(pp_hslice)
                    STRLEN n_a;
                    DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
                }
-               if (PL_op->op_private & OPpLVAL_INTRO)
-                   save_helem(hv, keysv, svp);
+               if (PL_op->op_private & OPpLVAL_INTRO) {
+                   if (preeminent)
+                       save_helem(hv, keysv, svp);
+                   else {
+                       STRLEN keylen;
+                       char *key = SvPV(keysv, keylen);
+                       save_delete(hv, key, keylen);
+                   }
+                }
            }
            *MARK = svp ? *svp : &PL_sv_undef;
        }
@@ -2884,7 +3612,7 @@ PP(pp_lslice)
        ix = SvIVx(*lelem);
        if (ix < 0)
            ix += max;
-       else 
+       else
            ix -= arybase;
        if (ix < 0 || ix >= max)
            *lelem = &PL_sv_undef;
@@ -3251,20 +3979,17 @@ PP(pp_reverse)
                U8* s = (U8*)SvPVX(TARG);
                U8* send = (U8*)(s + len);
                while (s < send) {
-                   if (*s < 0x80) {
+                   if (UTF8_IS_ASCII(*s)) {
                        s++;
                        continue;
                    }
                    else {
+                       if (!utf8_to_uv_simple(s, 0))
+                           break;
                        up = (char*)s;
                        s += UTF8SKIP(s);
                        down = (char*)(s - 1);
-                       if (s > send || !((*down & 0xc0) == 0x80)) {
-                           if (ckWARN_d(WARN_UTF8))
-                               Perl_warner(aTHX_ WARN_UTF8,
-                                           "Malformed UTF-8 character");
-                           break;
-                       }
+                       /* reverse this character */
                        while (down > up) {
                            tmp = *up;
                            *up++ = *down;
@@ -3348,9 +4073,9 @@ PP(pp_unpack)
     register char *str;
 
     /* These must not be in registers: */
-    I16 ashort;
+    short ashort;
     int aint;
-    I32 along;
+    long along;
 #ifdef HAS_QUAD
     Quad_t aquad;
 #endif
@@ -3646,7 +4371,9 @@ PP(pp_unpack)
                len = strend - s;
            if (checksum) {
                while (len-- > 0 && s < strend) {
-                   auint = utf8_to_uv_chk((U8*)s, &along, 0);
+                   STRLEN alen;
+                   auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
+                   along = alen;
                    s += along;
                    if (checksum > 32)
                        cdouble += (NV)auint;
@@ -3658,7 +4385,9 @@ PP(pp_unpack)
                EXTEND(SP, len);
                EXTEND_MORTAL(len);
                while (len-- > 0 && s < strend) {
-                   auint = utf8_to_uv_chk((U8*)s, &along, 0);
+                   STRLEN alen;
+                   auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
+                   along = alen;
                    s += along;
                    sv = NEWSV(37, 0);
                    sv_setuv(sv, (UV)auint);
@@ -3899,7 +4628,6 @@ PP(pp_unpack)
            if (checksum) {
 #if LONGSIZE != SIZE32
                if (natint) {
-                   long along;
                    while (len-- > 0) {
                        COPYNN(s, &along, sizeof(long));
                        s += sizeof(long);
@@ -3913,6 +4641,9 @@ PP(pp_unpack)
 #endif
                 {
                    while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+                       I32 along;
+#endif
                        COPY32(s, &along);
 #if LONGSIZE > SIZE32
                        if (along > 2147483647)
@@ -3931,7 +4662,6 @@ PP(pp_unpack)
                EXTEND_MORTAL(len);
 #if LONGSIZE != SIZE32
                if (natint) {
-                   long along;
                    while (len-- > 0) {
                        COPYNN(s, &along, sizeof(long));
                        s += sizeof(long);
@@ -3944,6 +4674,9 @@ PP(pp_unpack)
 #endif
                 {
                    while (len-- > 0) {
+#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
+                       I32 along;
+#endif
                        COPY32(s, &along);
 #if LONGSIZE > SIZE32
                        if (along > 2147483647)
@@ -4065,7 +4798,7 @@ PP(pp_unpack)
                
                while ((len > 0) && (s < strend)) {
                    auv = (auv << 7) | (*s & 0x7f);
-                   if (!(*s++ & 0x80)) {
+                   if (UTF8_IS_ASCII(*s++)) {
                        bytes = 0;
                        sv = NEWSV(40, 0);
                        sv_setuv(sv, auv);
@@ -4212,7 +4945,7 @@ PP(pp_unpack)
              */
             if (PL_uudmap['M'] == 0) {
                 int i;
+
                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
                     PL_uudmap[(U8)PL_uuemap[i]] = i;
                 /*
@@ -4457,7 +5190,7 @@ PP(pp_pack)
            patcopy++;
            continue;
         }
-       if (datumtype == 'U' && pat == patcopy+1) 
+       if (datumtype == 'U' && pat == patcopy+1)
            SvUTF8_on(cat);
        if (datumtype == '#') {
            while (pat < patend && *pat != '\n')
@@ -4690,7 +5423,7 @@ PP(pp_pack)
            while (len-- > 0) {
                fromstr = NEXTFROM;
                auint = SvUV(fromstr);
-               SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
+               SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
                SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
                               - SvPVX(cat));
            }
@@ -5007,16 +5740,17 @@ PP(pp_split)
     AV *ary;
     register IV limit = POPi;                  /* note, negative is forever */
     SV *sv = POPs;
-    bool doutf8 = DO_UTF8(sv);
     STRLEN len;
     register char *s = SvPV(sv, len);
+    bool do_utf8 = DO_UTF8(sv);
     char *strend = s + len;
     register PMOP *pm;
     register REGEXP *rx;
     register SV *dstr;
     register char *m;
     I32 iters = 0;
-    I32 maxiters = (strend - s) + 10;
+    STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
+    I32 maxiters = slen + 10;
     I32 i;
     char *orig;
     I32 origlimit = limit;
@@ -5034,7 +5768,7 @@ PP(pp_split)
     pm = (PMOP*)POPs;
 #endif
     if (!pm || !s)
-       DIE(aTHX_ "panic: do_split");
+       DIE(aTHX_ "panic: pp_split");
     rx = pm->op_pmregexp;
 
     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
@@ -5110,7 +5844,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (doutf8)
+           if (do_utf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
 
@@ -5132,7 +5866,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (doutf8)
+           if (do_utf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
            s = m;
@@ -5145,7 +5879,7 @@ PP(pp_split)
        SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
 
        len = rx->minlen;
-       if (len == 1 && !tail) {
+       if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
            STRLEN n_a;
            char c = *SvPV(csv, n_a);
            while (--limit) {
@@ -5157,12 +5891,15 @@ PP(pp_split)
                sv_setpvn(dstr, s, m-s);
                if (make_mortal)
                    sv_2mortal(dstr);
-               if (doutf8)
+               if (do_utf8)
                    (void)SvUTF8_on(dstr);
                XPUSHs(dstr);
                /* The rx->minlen is in characters but we want to step
                 * s ahead by bytes. */
-               s = m + (doutf8 ? SvCUR(csv) : len);
+               if (do_utf8)
+                   s = (char*)utf8_hop((U8*)m, len);
+               else
+                   s = m + len; /* Fake \n at the end */
            }
        }
        else {
@@ -5176,19 +5913,22 @@ PP(pp_split)
                sv_setpvn(dstr, s, m-s);
                if (make_mortal)
                    sv_2mortal(dstr);
-               if (doutf8)
+               if (do_utf8)
                    (void)SvUTF8_on(dstr);
                XPUSHs(dstr);
                /* The rx->minlen is in characters but we want to step
                 * s ahead by bytes. */
-               s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
+               if (do_utf8)
+                   s = (char*)utf8_hop((U8*)m, len);
+               else
+                   s = m + len; /* Fake \n at the end */
            }
        }
     }
     else {
-       maxiters += (strend - s) * rx->nparens;
+       maxiters += slen * rx->nparens;
        while (s < strend && --limit
-/*            && (!rx->check_substr 
+/*            && (!rx->check_substr
                   || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
                                                 0, NULL))))
 */            && CALLREGEXEC(aTHX_ rx, s, strend, orig,
@@ -5207,7 +5947,7 @@ PP(pp_split)
            sv_setpvn(dstr, s, m-s);
            if (make_mortal)
                sv_2mortal(dstr);
-           if (doutf8)
+           if (do_utf8)
                (void)SvUTF8_on(dstr);
            XPUSHs(dstr);
            if (rx->nparens) {
@@ -5222,7 +5962,7 @@ PP(pp_split)
                        dstr = NEWSV(33, 0);
                    if (make_mortal)
                        sv_2mortal(dstr);
-                   if (doutf8)
+                   if (do_utf8)
                        (void)SvUTF8_on(dstr);
                    XPUSHs(dstr);
                }
@@ -5243,7 +5983,7 @@ PP(pp_split)
        sv_setpvn(dstr, s, l);
        if (make_mortal)
            sv_2mortal(dstr);
-       if (doutf8)
+       if (do_utf8)
            (void)SvUTF8_on(dstr);
        XPUSHs(dstr);
        iters++;
@@ -5301,7 +6041,6 @@ PP(pp_split)
 void
 Perl_unlock_condpair(pTHX_ void *svv)
 {
-    dTHR;
     MAGIC *mg = mg_find((SV*)svv, 'm');
 
     if (!mg)
diff --git a/pp.h b/pp.h
index 029583a..2905e17 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -1,6 +1,6 @@
 /*    pp.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -33,6 +33,13 @@ L<perlcall>.
 Declares a local copy of perl's stack pointer for the XSUB, available via
 the C<SP> macro.  See C<SP>.
 
+=for apidoc ms||djSP
+
+Declare Just C<SP>. This is actually identical to C<dSP>, and declares
+a local copy of perl's stack pointer, available via the C<SP> macro.
+See C<SP>.  (Available for backward source code compatibility with the
+old (Perl 5.005) thread model.)
+
 =for apidoc Ams||dMARK
 Declare a stack marker variable, C<mark>, for the XSUB.  See C<MARK> and
 C<dORIGMARK>.
@@ -46,8 +53,7 @@ The original stack mark for the XSUB.  See C<dORIGMARK>.
 =for apidoc Ams||SPAGAIN
 Refetch the stack pointer.  Used after a callback.  See L<perlcall>.
 
-=cut
-*/
+=cut */
 
 #define SP sp
 #define MARK mark
@@ -61,7 +67,7 @@ Refetch the stack pointer.  Used after a callback.  See L<perlcall>.
 #define POPMARK                (*PL_markstack_ptr--)
 
 #define djSP           register SV **sp = PL_stack_sp
-#define dSP            dTHR; djSP
+#define dSP            djSP
 #define dMARK          register SV **mark = PL_stack_base + POPMARK
 #define dORIGMARK      I32 origmark = mark - PL_stack_base
 #define SETORIGMARK    origmark = mark - PL_stack_base
@@ -126,6 +132,7 @@ Pops a long off the stack.
 #endif
 
 #define TOPs           (*sp)
+#define TOPm1s         (*(sp-1))
 #define TOPp           (SvPV(TOPs, PL_na))             /* deprecated */
 #define TOPpx          (SvPV(TOPs, n_a))
 #define TOPn           (SvNV(TOPs))
index cf2000e..70c3ea3 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1,6 +1,6 @@
 /*    pp_ctl.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -115,7 +115,9 @@ PP(pp_regcomp)
 
            pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
            if (DO_UTF8(tmpstr))
-               pm->op_pmdynflags |= PMdf_UTF8;
+               pm->op_pmdynflags |= PMdf_DYN_UTF8;
+           else
+               pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
            pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
            PL_reginterp_cnt = 0;               /* XXXX Be extra paranoid - needed
                                           inside tie/overload accessors.  */
@@ -157,7 +159,7 @@ PP(pp_substcont)
     register char *m = cx->sb_m;
     char *orig = cx->sb_orig;
     register REGEXP *rx = cx->sb_rx;
-
+    
     rxres_restore(&cx->sb_rxres, rx);
 
     if (cx->sb_iters++) {
@@ -176,8 +178,8 @@ PP(pp_substcont)
                                      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
        {
            SV *targ = cx->sb_targ;
-           sv_catpvn(dstr, s, cx->sb_strend - s);
 
+           sv_catpvn(dstr, s, cx->sb_strend - s);
            cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 
            (void)SvOOK_off(targ);
@@ -185,13 +187,15 @@ PP(pp_substcont)
            SvPVX(targ) = SvPVX(dstr);
            SvCUR_set(targ, SvCUR(dstr));
            SvLEN_set(targ, SvLEN(dstr));
+           if (DO_UTF8(dstr))
+               SvUTF8_on(targ);
            SvPVX(dstr) = 0;
            sv_free(dstr);
 
            TAINT_IF(cx->sb_rxtainted & 1);
            PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 
-           (void)SvPOK_only(targ);
+           (void)SvPOK_only_UTF8(targ);
            TAINT_IF(cx->sb_rxtainted);
            SvSETMAGIC(targ);
            SvTAINT(targ);
@@ -209,8 +213,24 @@ PP(pp_substcont)
        cx->sb_strend = s + (cx->sb_strend - m);
     }
     cx->sb_m = m = rx->startp[0] + orig;
-    sv_catpvn(dstr, s, m-s);
+    if (m > s)
+       sv_catpvn(dstr, s, m-s);
     cx->sb_s = rx->endp[0] + orig;
+    { /* Update the pos() information. */
+       SV *sv = cx->sb_targ;
+       MAGIC *mg;
+       I32 i;
+       if (SvTYPE(sv) < SVt_PVMG)
+           SvUPGRADE(sv, SVt_PVMG);
+       if (!(mg = mg_find(sv, 'g'))) {
+           sv_magic(sv, Nullsv, 'g', Nullch, 0);
+           mg = mg_find(sv, 'g');
+       }
+       i = m - orig;
+       if (DO_UTF8(sv))
+           sv_pos_b2u(sv, &i);
+       mg->mg_len = i;
+    }
     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
     rxres_save(&cx->sb_rxres, rx);
     RETURNOP(pm->op_pmreplstart);
@@ -342,6 +362,7 @@ PP(pp_formline)
            case FF_MORE:       name = "MORE";          break;
            case FF_LINEMARK:   name = "LINEMARK";      break;
            case FF_END:        name = "END";           break;
+            case FF_0DECIMAL:  name = "0DECIMAL";      break;
            }
            if (arg >= 0)
                PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
@@ -524,7 +545,7 @@ PP(pp_formline)
            s = item;
            if (item_is_utf) {
                while (arg--) {
-                   if (*s & 0x80) {
+                   if (UTF8_IS_CONTINUED(*s)) {
                        switch (UTF8SKIP(s)) {
                        case 7: *t++ = *s++;
                        case 6: *t++ = *s++;
@@ -620,6 +641,43 @@ PP(pp_formline)
            t += fieldsize;
            break;
 
+       case FF_0DECIMAL:
+           /* If the field is marked with ^ and the value is undefined,
+              blank it out. */
+           arg = *fpc++;
+           if ((arg & 512) && !SvOK(sv)) {
+               arg = fieldsize;
+               while (arg--)
+                   *t++ = ' ';
+               break;
+           }
+           gotsome = TRUE;
+           value = SvNV(sv);
+           /* Formats aren't yet marked for locales, so assume "yes". */
+           {
+               STORE_NUMERIC_STANDARD_SET_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*" PERL_PRIfldbl,
+                           (int) fieldsize, (int) arg & 255, value);
+/* is this legal? I don't have long doubles */
+               } else {
+                   sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
+               }
+#else
+               if (arg & 256) {
+                   sprintf(t, "%#0*.*f",
+                           (int) fieldsize, (int) arg & 255, value);
+               } else {
+                   sprintf(t, "%0*.0f",
+                           (int) fieldsize, value);
+               }
+#endif
+               RESTORE_NUMERIC_STANDARD();
+           }
+           t += fieldsize;
+           break;
+       
        case FF_NEWLINE:
            f++;
            while (t-- > linemark && *t == ' ') ;
@@ -729,7 +787,7 @@ PP(pp_mapwhile)
     I32 count;
     I32 shift;
     SV** src;
-    SV** dst; 
+    SV** dst;
 
     /* first, move source pointer to the next item in the source list */
     ++PL_markstack_ptr[-1];
@@ -761,7 +819,7 @@ PP(pp_mapwhile)
             * irrelevant.  --jhi */
             if (shift < count)
                 shift = count; /* Avoid shifting too often --Ben Tilly */
-           
+       
            EXTEND(SP,shift);
            src = SP;
            dst = (SP += shift);
@@ -771,9 +829,9 @@ PP(pp_mapwhile)
                *dst-- = *src--;
        }
        /* copy the new items down to the destination list */
-       dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 
+       dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
        while (items--)
-           *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 
+           *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
     }
     LEAVE;                                     /* exit inner scope */
 
@@ -1107,7 +1165,6 @@ PP(pp_flop)
 STATIC I32
 S_dopoptolabel(pTHX_ char *label)
 {
-    dTHR;
     register I32 i;
     register PERL_CONTEXT *cx;
 
@@ -1116,27 +1173,27 @@ S_dopoptolabel(pTHX_ char *label)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1163,7 +1220,6 @@ Perl_dowantarray(pTHX)
 I32
 Perl_block_gimme(pTHX)
 {
-    dTHR;
     I32 cxix;
 
     cxix = dopoptosub(cxstack_ix);
@@ -1187,14 +1243,12 @@ Perl_block_gimme(pTHX)
 STATIC I32
 S_dopoptosub(pTHX_ I32 startingblock)
 {
-    dTHR;
     return dopoptosub_at(cxstack, startingblock);
 }
 
 STATIC I32
 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1215,7 +1269,6 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
 STATIC I32
 S_dopoptoeval(pTHX_ I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1234,7 +1287,6 @@ S_dopoptoeval(pTHX_ I32 startingblock)
 STATIC I32
 S_dopoptoloop(pTHX_ I32 startingblock)
 {
-    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
@@ -1242,27 +1294,27 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
-               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1276,7 +1328,6 @@ S_dopoptoloop(pTHX_ I32 startingblock)
 void
 Perl_dounwind(pTHX_ I32 cxix)
 {
-    dTHR;
     register PERL_CONTEXT *cx;
     I32 optype;
 
@@ -1322,7 +1373,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 STATIC void
 S_free_closures(pTHX)
 {
-    dTHR;
     SV **svp = AvARRAY(PL_comppad_name);
     I32 ix;
     for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
@@ -1391,8 +1441,13 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                    }
                }
            }
-           else
+           else {
                sv_setpvn(ERRSV, message, msglen);
+               if (PL_hints & HINT_UTF8)
+                   SvUTF8_on(ERRSV);
+               else
+                   SvUTF8_off(ERRSV);
+           }
        }
        else
            message = SvPVx(ERRSV, msglen);
@@ -1615,10 +1670,10 @@ PP(pp_caller)
        SV * mask ;
        SV * old_warnings = cx->blk_oldcop->cop_warnings ;
 
-       if  (old_warnings == pWARN_NONE || 
+       if  (old_warnings == pWARN_NONE ||
                (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
-        else if (old_warnings == pWARN_ALL || 
+        else if (old_warnings == pWARN_ALL ||
                  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
         else
@@ -1715,7 +1770,6 @@ PP(pp_enteriter)
 
 #ifdef USE_THREADS
     if (PL_op->op_flags & OPf_SPECIAL) {
-       dTHR;
        svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
        SAVEGENERICSV(*svp);
        *svp = NEWSV(0,0);
@@ -1723,9 +1777,11 @@ PP(pp_enteriter)
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
+#ifndef USE_ITHREADS
        svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
        SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+       SAVEPADSV(PL_op->op_targ);
        iterdata = (void*)PL_op->op_targ;
        cxtype |= CXp_PADVAR;
 #endif
@@ -2103,7 +2159,6 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
     }
     *ops = 0;
     if (o->op_flags & OPf_KIDS) {
-       dTHR;
        /* First try all the kids at this level, since that's likeliest. */
        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
            if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
@@ -2185,7 +2240,7 @@ PP(pp_goto)
            if (cxix < cxstack_ix)
                dounwind(cxix);
            TOPBLOCK(cx);
-           if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+           if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
                DIE(aTHX_ "Can't goto subroutine from an eval-string");
            mark = PL_stack_sp;
            if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
@@ -2253,7 +2308,7 @@ PP(pp_goto)
 
                    PL_stack_sp--;              /* There is no cv arg. */
                    /* Push a mark for the start of arglist */
-                   PUSHMARK(mark); 
+                   PUSHMARK(mark);
                    (void)(*CvXSUB(cv))(aTHXo_ cv);
                    /* Pop the current context like a decent sub should */
                    POPBLOCK(cx, PL_curpm);
@@ -2327,14 +2382,14 @@ PP(pp_goto)
 #ifdef USE_THREADS
                if (!cx->blk_sub.hasargs) {
                    AV* av = (AV*)PL_curpad[0];
-                   
+               
                    items = AvFILLp(av) + 1;
                    if (items) {
                        /* Mark is at the end of the stack. */
                        EXTEND(SP, items);
                        Copy(AvARRAY(av), SP + 1, items, SV*);
                        SP += items;
-                       PUTBACK ;                   
+                       PUTBACK ;               
                    }
                }
 #endif /* USE_THREADS */               
@@ -2384,7 +2439,7 @@ PP(pp_goto)
                     */
                    SV *sv = GvSV(PL_DBsub);
                    CV *gotocv;
-                   
+               
                    if (PERLDB_SUB_NN) {
                        SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
                    } else {
@@ -2614,7 +2669,6 @@ S_docatch_body(pTHX)
 STATIC OP *
 S_docatch(pTHX_ OP *o)
 {
-    dTHR;
     int ret;
     OP *oldop = PL_op;
     volatile PERL_SI *cursi = PL_curstackinfo;
@@ -2707,12 +2761,12 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
 #else
     SAVEVPTR(PL_op);
 #endif
-    PL_hints = 0;
+    PL_hints &= HINT_UTF8;
 
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;                       /* Avoid uninit warning. */
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
     rop = doeval(G_SCALAR, startop);
     POPBLOCK(cx,PL_curpm);
@@ -2971,17 +3025,17 @@ PP(pp_require)
     if (SvNIOKp(sv)) {
        if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
            UV rev = 0, ver = 0, sver = 0;
-           I32 len;
+           STRLEN len;
            U8 *s = (U8*)SvPVX(sv);
            U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
            if (s < end) {
-               rev = utf8_to_uv_chk(s, &len, 0);
+               rev = utf8_to_uv(s, end - s, &len, 0);
                s += len;
                if (s < end) {
-                   ver = utf8_to_uv_chk(s, &len, 0);
+                   ver = utf8_to_uv(s, end - s, &len, 0);
                    s += len;
                    if (s < end)
-                       sver = utf8_to_uv_chk(s, &len, 0);
+                       sver = utf8_to_uv(s, end - s, &len, 0);
                }
            }
            if (PERL_REVISION < rev
@@ -3050,7 +3104,7 @@ PP(pp_require)
        if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
            goto trylocal;
     }
-    else 
+    else
 trylocal: {
 #else
     }
@@ -3259,8 +3313,10 @@ trylocal: {
         PL_compiling.cop_warnings = pWARN_ALL ;
     else if (PL_dowarn & G_WARN_ALL_OFF)
         PL_compiling.cop_warnings = pWARN_NONE ;
-    else 
+    else
         PL_compiling.cop_warnings = pWARN_STD ;
+    SAVESPTR(PL_compiling.cop_io);
+    PL_compiling.cop_io = Nullsv;
 
     if (filter_sub || filter_child_proc) {
        SV *datasv = filter_add(run_user_filter, Nullsv);
@@ -3314,7 +3370,7 @@ PP(pp_entereval)
     ENTER;
     lex_start(sv);
     SAVETMPS;
+
     /* switch to eval mode */
 
     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
@@ -3346,6 +3402,13 @@ PP(pp_entereval)
         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
         SAVEFREESV(PL_compiling.cop_warnings);
     }
+    SAVESPTR(PL_compiling.cop_io);
+    if (specialCopIO(PL_curcop->cop_io))
+        PL_compiling.cop_io = PL_curcop->cop_io;
+    else {
+        PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
+        SAVEFREESV(PL_compiling.cop_io);
+    }
 
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
@@ -3529,7 +3592,7 @@ S_doparseform(pTHX_ SV *sv)
 
     if (len == 0)
        Perl_croak(aTHX_ "Null picture in formline");
-    
+
     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
     fpc = fops;
 
@@ -3557,7 +3620,7 @@ S_doparseform(pTHX_ SV *sv)
        case ' ': case '\t':
            skipspaces++;
            continue;
-           
+       
        case '\n': case 0:
            arg = s - base;
            skipspaces++;
@@ -3632,6 +3695,24 @@ S_doparseform(pTHX_ SV *sv)
                }
                *fpc++ = s - base;              /* fieldsize for FETCH */
                *fpc++ = FF_DECIMAL;
+                *fpc++ = arg;
+            }
+            else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
+                arg = ischop ? 512 : 0;
+               base = s - 1;
+                s++;                                /* skip the '0' first */
+                while (*s == '#')
+                    s++;
+                if (*s == '.') {
+                    char *f;
+                    s++;
+                    f = s;
+                    while (*s == '#')
+                        s++;
+                    arg |= 256 + (s - f);
+                }
+                *fpc++ = s - base;                /* fieldsize for FETCH */
+                *fpc++ = FF_0DECIMAL;
                *fpc++ = arg;
            }
            else {
@@ -3695,7 +3776,7 @@ S_doparseform(pTHX_ SV *sv)
  * Research Group at University of California, Berkeley.
  *
  * See also: "Optimistic Merge Sort" (SODA '92)
- *      
+ *
  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
  *
  * The code can be distributed under the same terms as Perl itself.
@@ -4065,7 +4146,6 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
 static I32
 sortcv(pTHXo_ SV *a, SV *b)
 {
-    dTHR;
     I32 oldsaveix = PL_savestack_ix;
     I32 oldscopeix = PL_scopestack_ix;
     I32 result;
@@ -4089,7 +4169,6 @@ sortcv(pTHXo_ SV *a, SV *b)
 static I32
 sortcv_stacked(pTHXo_ SV *a, SV *b)
 {
-    dTHR;
     I32 oldsaveix = PL_savestack_ix;
     I32 oldscopeix = PL_scopestack_ix;
     I32 result;
index 9b0573b..30cc61d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,6 @@
 /*    pp_hot.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #define PERL_IN_PP_HOT_C
 #include "perl.h"
 
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
 /* Hot code. */
 
 #ifdef USE_THREADS
@@ -82,6 +78,8 @@ PP(pp_stringify)
     sv_setpvn(TARG,s,len);
     if (SvUTF8(TOPs) && !IN_BYTE)
        SvUTF8_on(TARG);
+    else
+       SvUTF8_off(TARG);
     SETTARG;
     RETURN;
 }
@@ -144,99 +142,52 @@ PP(pp_concat)
   djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
   {
     dPOPTOPssrl;
-    STRLEN len;
-    U8 *s;
-    bool left_utf;
-    bool right_utf;
+    SV* rcopy = Nullsv;
 
-    if (TARG == right && SvGMAGICAL(right))
-        mg_get(right);
     if (SvGMAGICAL(left))
         mg_get(left);
+    if (TARG == right && SvGMAGICAL(right))
+        mg_get(right);
 
-    left_utf  = DO_UTF8(left);
-    right_utf = DO_UTF8(right);
-    if (left_utf != right_utf) {
-        if (TARG == right && !right_utf) {
-            sv_utf8_upgrade(TARG); /* Now straight binary copy */
-            SvUTF8_on(TARG);
-        }
-        else {
-            /* Set TARG to PV(left), then add right */
-            U8 *l, *c, *olds = NULL;
-            STRLEN targlen;
-           s = (U8*)SvPV(right,len);
-           right_utf |= DO_UTF8(right);
-            if (TARG == right) {
-               /* Take a copy since we're about to overwrite TARG */
-               olds = s = (U8*)savepvn((char*)s, len);
-           }
-           if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG)
-               sv_setpv(left, "");     /* Suppress warning. */
-            l = (U8*)SvPV(left, targlen);
-           left_utf |= DO_UTF8(left);
-            if (TARG != left)
-                sv_setpvn(TARG, (char*)l, targlen);
-            if (!left_utf)
-                sv_utf8_upgrade(TARG);
-            /* Extend TARG to length of right (s) */
-            targlen = SvCUR(TARG) + len;
-            if (!right_utf) {
-                /* plus one for each hi-byte char if we have to upgrade */
-                for (c = s; c < s + len; c++)  {
-                    if (*c & 0x80)
-                        targlen++;
-                }
-            }
-            SvGROW(TARG, targlen+1);
-            /* And now copy, maybe upgrading right to UTF8 on the fly */
-            for (c = (U8*)SvEND(TARG); len--; s++) {
-                 if (*s & 0x80 && !right_utf)
-                     c = uv_to_utf8(c, *s);
-                 else
-                     *c++ = *s;
-            }
-            SvCUR_set(TARG, targlen);
-            *SvEND(TARG) = '\0';
-            SvUTF8_on(TARG);
-            SETs(TARG);
-           Safefree(olds);
-            RETURN;
-        }
-    }
-
-    if (TARG != left) {
-       s = (U8*)SvPV(left,len);
-       if (TARG == right) {
-           sv_insert(TARG, 0, 0, (char*)s, len);
-           SETs(TARG);
-           RETURN;
+    if (TARG == right && left != right)
+       /* Clone since otherwise we cannot prepend. */
+       rcopy = sv_2mortal(newSVsv(right));
+
+    if (TARG != left)
+       sv_setsv(TARG, left);
+
+    if (TARG == right) {
+       if (left == right) {
+           /*  $right = $right . $right; */
+           STRLEN rlen;
+           char *rpv = SvPV(right, rlen);
+
+           sv_catpvn(TARG, rpv, rlen);
        }
-       sv_setpvn(TARG, (char *)s, len);
+       else /* $right = $left  . $right; */
+           sv_catsv(TARG, rcopy);
     }
-    else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
-       sv_setpv(TARG, "");     /* Suppress warning. */
-    s = (U8*)SvPV(right,len);
-    if (SvOK(TARG)) {
+    else {
+       if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
+           sv_setpv(TARG, "");
+       /* $other = $left . $right; */
+       /* $left  = $left . $right; */
+       sv_catsv(TARG, right);
+    }
+
 #if defined(PERL_Y2KWARN)
-       if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
-           STRLEN n;
-           char *s = SvPV(TARG,n);
-           if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
-               && (n == 2 || !isDIGIT(s[n-3])))
-           {
-               Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
-                           "about to append an integer to '19'");
-           }
+    if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
+       STRLEN n;
+       char *s = SvPV(TARG,n);
+       if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+           && (n == 2 || !isDIGIT(s[n-3])))
+       {
+           Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+                       "about to append an integer to '19'");
        }
-#endif
-       sv_catpvn(TARG, (char *)s, len);
     }
-    else
-       sv_setpvn(TARG, (char *)s, len);        /* suppress warning */
-    if (left_utf)
-       SvUTF8_on(TARG);
+#endif
+
     SETTARG;
     RETURN;
   }
@@ -279,6 +230,69 @@ PP(pp_readline)
 PP(pp_eq)
 {
     djSP; tryAMAGICbinSET(eq,0);
+#ifdef PERL_PRESERVE_IVUV
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       /* Unless the left argument is integer in range we are going to have to
+          use NV maths. Hence only attempt to coerce the right argument if
+          we know the left is integer.  */
+      SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV == IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(aiv == biv));
+               RETURN;
+           }
+           if (auvok && buvok) { /* ## UV == UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               
+               SP--;
+               SETs(boolSV(auv == buv));
+               RETURN;
+           }
+           {                   /* ## Mixed IV,UV ## */
+               IV iv;
+               UV uv;
+               
+               /* == is commutative so swap if needed (save code) */
+               if (auvok) {
+                   /* swap. top of stack (b) is the iv */
+                   iv = SvIVX(TOPs);
+                   SP--;
+                   if (iv < 0) {
+                       /* As (a) is a UV, it's >0, so it cannot be == */
+                       SETs(&PL_sv_no);
+                       RETURN;
+                   }
+                   uv = SvUVX(TOPs);
+               } else {
+                   iv = SvIVX(TOPm1s);
+                   SP--;
+                   if (iv < 0) {
+                       /* As (b) is a UV, it's >0, so it cannot be == */
+                       SETs(&PL_sv_no);
+                       RETURN;
+                   }
+                   uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
+               }
+               /* we know iv is >= 0 */
+               if (uv > (UV) IV_MAX) {
+                   SETs(&PL_sv_no);
+                   RETURN;
+               }
+               SETs(boolSV((UV)iv == uv));
+               RETURN;
+           }
+       }
+    }
+#endif
     {
       dPOPnv;
       SETs(boolSV(TOPn == value));
@@ -297,7 +311,7 @@ PP(pp_preinc)
        ++SvIVX(TOPs);
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
     }
-    else
+    else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
        sv_inc(TOPs);
     SvSETMAGIC(TOPs);
     return NORMAL;
@@ -316,11 +330,125 @@ PP(pp_or)
 
 PP(pp_add)
 {
-    djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+    djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
+    useleft = USE_LEFT(TOPm1s);
+#ifdef PERL_PRESERVE_IVUV
+    /* We must see if we can perform the addition with integers if possible,
+       as the integer code detects overflow while the NV code doesn't.
+       If either argument hasn't had a numeric conversion yet attempt to get
+       the IV. It's important to do this now, rather than just assuming that
+       it's not IOK as a PV of "9223372036854775806" may not take well to NV
+       addition, and an SV which is NOK, NV=6.0 ought to be coerced to
+       integer in case the second argument is IV=9223372036854775806
+       We can (now) rely on sv_2iv to do the right thing, only setting the
+       public IOK flag if the value in the NV (or PV) slot is truly integer.
+
+       A side effect is that this also aggressively prefers integer maths over
+       fp maths for integer values.  */
+    SvIV_please(TOPs);
+    if (SvIOK(TOPs)) {
+       /* Unless the left argument is integer in range we are going to have to
+          use NV maths. Hence only attempt to coerce the right argument if
+          we know the left is integer.  */
+       if (!useleft) {
+           /* left operand is undef, treat as zero. + 0 is identity. */
+           if (SvUOK(TOPs)) {
+               dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
+               SETu(value);
+               RETURN;
+           } else {
+               dPOPiv;
+               SETi(value);
+               RETURN;
+           }
+       }
+       /* Left operand is defined, so is it IV? */
+       SvIV_please(TOPm1s);
+       if (SvIOK(TOPm1s)) {
+           bool auvok = SvUOK(TOPm1s);
+           bool buvok = SvUOK(TOPs);
+       
+           if (!auvok && !buvok) { /* ## IV + IV ## */
+               IV aiv = SvIVX(TOPm1s);
+               IV biv = SvIVX(TOPs);
+               IV result = aiv + biv;
+               
+               if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
+                   SP--;
+                   SETi( result );
+                   RETURN;
+               }
+               if (biv >=0 && aiv >= 0) {
+                   UV result = (UV)aiv + (UV)biv;
+                   /* UV + UV can only get bigger... */
+                   if (result >= (UV) aiv) {
+                       SP--;
+                       SETu( result );
+                       RETURN;
+                   }
+               }
+               /* Overflow, drop through to NVs (beyond next if () else ) */
+           } else if (auvok && buvok) {        /* ## UV + UV ## */
+               UV auv = SvUVX(TOPm1s);
+               UV buv = SvUVX(TOPs);
+               UV result = auv + buv;
+               if (result >= auv) {
+                   SP--;
+                   SETu( result );
+                   RETURN;
+               }
+               /* Overflow, drop through to NVs (beyond next if () else ) */
+           } else {                    /* ## Mixed IV,UV ## */
+               IV aiv;
+               UV buv;
+               
+               /* addition is commutative so swap if needed (save code) */
+               if (buvok) {
+                   aiv = SvIVX(TOPm1s);
+                   buv = SvUVX(TOPs);
+               } else {
+                   aiv = SvIVX(TOPs);
+                   buv = SvUVX(TOPm1s);
+               }
+       
+               if (aiv >= 0) {
+                   UV result = (UV)aiv + buv;
+                   if (result >= buv) {
+                       SP--;
+                       SETu( result );
+                       RETURN;
+                   }
+               } else if (buv > (UV) IV_MAX) {
+                   /* assuming 2s complement means that IV_MIN == -IV_MIN,
+                      and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
+                      as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
+                      as the value we can be subtracting from it only lies in
+                      the range (-IV_MIN to -1) it can't overflow a UV */
+                   SP--;
+                   SETu( buv - (UV)-aiv );
+                   RETURN;
+               } else {
+                   IV result = (IV) buv + aiv;
+                   /* aiv < 0 so it must get smaller.  */
+                   if (result < (IV) buv) {
+                       SP--;
+                       SETi( result );
+                       RETURN;
+                   }
+               }
+           } /* end of IV+IV / UV+UV / mixed */
+       }
+    }
+#endif
     {
-      dPOPTOPnnrl_ul;
-      SETn( left + right );
-      RETURN;
+       dPOPnv;
+       if (!useleft) {
+           /* left operand is undef, treat as zero. + 0.0 is identity. */
+           SETn(value);
+           RETURN;
+       }
+       SETn( value + TOPn );
+       RETURN;
     }
 }
 
@@ -406,7 +534,6 @@ PP(pp_print)
        RETURN;
     }
     if (!(io = GvIO(gv))) {
-        dTHR;
         if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
             goto had_magic;
        if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
@@ -416,21 +543,8 @@ PP(pp_print)
     }
     else if (!(fp = IoOFP(io))) {
        if (ckWARN2(WARN_CLOSED, WARN_IO))  {
-           if (IoIFP(io)) {
-               /* integrate with report_evil_fh()? */
-               char *name = NULL;
-               if (isGV(gv)) {
-                   SV* sv = sv_newmortal();
-                   gv_efullname4(sv, gv, Nullch, FALSE);
-                   name = SvPV_nolen(sv);
-               }
-               if (name && *name)
-                 Perl_warner(aTHX_ WARN_IO,
-                             "Filehandle %s opened only for input", name);
-               else
-                   Perl_warner(aTHX_ WARN_IO,
-                               "Filehandle opened only for input");
-           }
+           if (IoIFP(io))
+               report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
            else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
                report_evil_fh(gv, io, PL_op->op_type);
        }
@@ -439,13 +553,13 @@ PP(pp_print)
     }
     else {
        MARK++;
-       if (PL_ofslen) {
+       if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
            while (MARK <= SP) {
                if (!do_print(*MARK, fp))
                    break;
                MARK++;
                if (MARK <= SP) {
-                   if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
+                   if (!do_print(PL_ofs_sv, fp)) { /* $, */
                        MARK--;
                        break;
                    }
@@ -462,8 +576,8 @@ PP(pp_print)
        if (MARK <= SP)
            goto just_say_no;
        else {
-           if (PL_orslen)
-               if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
+           if (PL_ors_sv && SvOK(PL_ors_sv))
+               if (!do_print(PL_ors_sv, fp)) /* $\ */
                    goto just_say_no;
 
            if (IoFLAGS(io) & IOf_FLUSH)
@@ -1016,11 +1130,12 @@ PP(pp_match)
        TARG = DEFSV;
        EXTEND(SP,1);
     }
+    PL_reg_sv = TARG;
     PUTBACK;                           /* EVAL blocks need stack_sp. */
     s = SvPV(TARG, len);
     strend = s + len;
     if (!s)
-       DIE(aTHX_ "panic: do_match");
+       DIE(aTHX_ "panic: pp_match");
     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
                 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
@@ -1076,7 +1191,8 @@ play_it_again:
        if (update_minmatch++)
            minmatch = had_zerolen;
     }
-    if (rx->reganch & RE_USE_INTUIT) {
+    if (rx->reganch & RE_USE_INTUIT &&
+       DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
        s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
 
        if (!s)
@@ -1105,27 +1221,25 @@ play_it_again:
        RX_MATCH_TAINTED_on(rx);
     TAINT_IF(RX_MATCH_TAINTED(rx));
     if (gimme == G_ARRAY) {
-       I32 iters, i, len;
+       I32 nparens, i, len;
 
-       iters = rx->nparens;
-       if (global && !iters)
+       nparens = rx->nparens;
+       if (global && !nparens)
            i = 1;
        else
            i = 0;
        SPAGAIN;                        /* EVAL blocks could move the stack. */
-       EXTEND(SP, iters + i);
-       EXTEND_MORTAL(iters + i);
-       for (i = !i; i <= iters; i++) {
+       EXTEND(SP, nparens + i);
+       EXTEND_MORTAL(nparens + i);
+       for (i = !i; i <= nparens; i++) {
            PUSHs(sv_newmortal());
            /*SUPPRESS 560*/
            if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
                len = rx->endp[i] - rx->startp[i];
                s = rx->startp[i] + truebase;
                sv_setpvn(*SP, s, len);
-               if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
+               if (DO_UTF8(TARG))
                    SvUTF8_on(*SP);
-                   sv_utf8_downgrade(*SP, TRUE);
-               }
            }
        }
        if (global) {
@@ -1135,7 +1249,7 @@ play_it_again:
            r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
            goto play_it_again;
        }
-       else if (!iters)
+       else if (!nparens)
            XPUSHs(&PL_sv_yes);
        LEAVE_SCOPE(oldsave);
        RETURN;
@@ -1175,7 +1289,13 @@ yup:                                     /* Confirmed by INTUIT */
     if (global) {
        rx->subbeg = truebase;
        rx->startp[0] = s - truebase;
-       rx->endp[0] = s - truebase + rx->minlen;
+       if (DO_UTF8(PL_reg_sv)) {
+           char *t = (char*)utf8_hop((U8*)s, rx->minlen);
+           rx->endp[0] = t - truebase;
+       }
+       else {
+           rx->endp[0] = s - truebase + rx->minlen;
+       }
        rx->sublen = strend - truebase;
        goto gotcha;
     }
@@ -1257,159 +1377,15 @@ Perl_do_readline(pTHX)
                    (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
                }
            }
-           else if (type == OP_GLOB) {
-               SV *tmpcmd = NEWSV(55, 0);
-               SV *tmpglob = POPs;
-               ENTER;
-               SAVEFREESV(tmpcmd);
-#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
-           /* since spawning off a process is a real performance hit */
-               {
-#include <descrip.h>
-#include <lib$routines.h>
-#include <nam.h>
-#include <rmsdef.h>
-                   char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
-                   char vmsspec[NAM$C_MAXRSS+1];
-                   char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
-                   char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
-                   $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
-                   PerlIO *tmpfp;
-                   STRLEN i;
-                   struct dsc$descriptor_s wilddsc
-                      = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-                   struct dsc$descriptor_vs rsdsc
-                      = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
-                   unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
-
-                   /* We could find out if there's an explicit dev/dir or version
-                      by peeking into lib$find_file's internal context at
-                      ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
-                      but that's unsupported, so I don't want to do it now and
-                      have it bite someone in the future. */
-                   strcat(tmpfnam,PerlLIO_tmpnam(NULL));
-                   cp = SvPV(tmpglob,i);
-                   for (; i; i--) {
-                      if (cp[i] == ';') hasver = 1;
-                      if (cp[i] == '.') {
-                          if (sts) hasver = 1;
-                          else sts = 1;
-                      }
-                      if (cp[i] == '/') {
-                         hasdir = isunix = 1;
-                         break;
-                      }
-                      if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
-                          hasdir = 1;
-                          break;
-                      }
-                   }
-                   if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
-                       Stat_t st;
-                       if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
-                         ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
-                       else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
-                       if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
-                       while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
-                                                   &dfltdsc,NULL,NULL,NULL))&1)) {
-                           end = rstr + (unsigned long int) *rslt;
-                           if (!hasver) while (*end != ';') end--;
-                           *(end++) = '\n';  *end = '\0';
-                           for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
-                           if (hasdir) {
-                             if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
-                             begin = rstr;
-                           }
-                           else {
-                               begin = end;
-                               while (*(--begin) != ']' && *begin != '>') ;
-                               ++begin;
-                           }
-                           ok = (PerlIO_puts(tmpfp,begin) != EOF);
-                       }
-                       if (cxt) (void)lib$find_file_end(&cxt);
-                       if (ok && sts != RMS$_NMF &&
-                           sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
-                       if (!ok) {
-                           if (!(sts & 1)) {
-                             SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
-                           }
-                           PerlIO_close(tmpfp);
-                           fp = NULL;
-                       }
-                       else {
-                          PerlIO_rewind(tmpfp);
-                          IoTYPE(io) = IoTYPE_RDONLY;
-                          IoIFP(io) = fp = tmpfp;
-                          IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
-                       }
-                   }
-               }
-#else /* !VMS */
-#ifdef MACOS_TRADITIONAL
-               sv_setpv(tmpcmd, "glob ");
-               sv_catsv(tmpcmd, tmpglob);
-               sv_catpv(tmpcmd, " |");
-#else
-#ifdef DOSISH
-#ifdef OS2
-               sv_setpv(tmpcmd, "for a in ");
-               sv_catsv(tmpcmd, tmpglob);
-               sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
-#else
-#ifdef DJGPP
-               sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
-               sv_catsv(tmpcmd, tmpglob);
-#else
-               sv_setpv(tmpcmd, "perlglob ");
-               sv_catsv(tmpcmd, tmpglob);
-               sv_catpv(tmpcmd, " |");
-#endif /* !DJGPP */
-#endif /* !OS2 */
-#else /* !DOSISH */
-#if defined(CSH)
-               sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
-               sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
-               sv_catsv(tmpcmd, tmpglob);
-               sv_catpv(tmpcmd, "' 2>/dev/null |");
-#else
-               sv_setpv(tmpcmd, "echo ");
-               sv_catsv(tmpcmd, tmpglob);
-#if 'z' - 'a' == 25
-               sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#else
-               sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
-#endif
-#endif /* !CSH */
-#endif /* !DOSISH */
-#endif /* MACOS_TRADITIONAL */
-               (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
-                             FALSE, O_RDONLY, 0, Nullfp);
-               fp = IoIFP(io);
-#endif /* !VMS */
-               LEAVE;
-           }
+           else if (type == OP_GLOB)
+               fp = Perl_start_glob(aTHX_ POPs, io);
        }
        else if (type == OP_GLOB)
            SP--;
        else if (ckWARN(WARN_IO)        /* stdout/stderr or other write fh */
                 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
                     || fp == PerlIO_stderr()))
-       {
-           /* integrate with report_evil_fh()? */
-           char *name = NULL;
-           if (isGV(PL_last_in_gv)) { /* can this ever fail? */
-               SV* sv = sv_newmortal();
-               gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE);
-               name = SvPV_nolen(sv);
-           }
-           if (name && *name)
-               Perl_warner(aTHX_ WARN_IO,
-                           "Filehandle %s opened only for output", name);
-           else
-               Perl_warner(aTHX_ WARN_IO,
-                           "Filehandle opened only for output");
-       }
+           report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
     }
     if (!fp) {
        if (ckWARN2(WARN_GLOB, WARN_CLOSED)
@@ -1446,6 +1422,13 @@ Perl_do_readline(pTHX)
        offset = 0;
     }
 
+    /* This should not be marked tainted if the fp is marked clean */
+#define MAYBE_TAINT_LINE(io, sv) \
+    if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
+       TAINT;                          \
+       SvTAINTED_on(sv);               \
+    }
+
 /* delay EOF state for a snarfed empty file */
 #define SNARF_EOF(gimme,rs,io,sv) \
     (gimme != G_SCALAR || SvCUR(sv)                                    \
@@ -1474,13 +1457,10 @@ Perl_do_readline(pTHX)
                (void)SvOK_off(TARG);
                PUSHTARG;
            }
+           MAYBE_TAINT_LINE(io, sv);
            RETURN;
        }
-       /* This should not be marked tainted if the fp is marked clean */
-       if (!(IoFLAGS(io) & IOf_UNTAINT)) {
-           TAINT;
-           SvTAINTED_on(sv);
-       }
+       MAYBE_TAINT_LINE(io, sv);
        IoLINES(io)++;
        IoFLAGS(io) |= IOf_NOLINE;
        SvSETMAGIC(sv);
@@ -1556,8 +1536,11 @@ PP(pp_helem)
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+    I32 preeminent;
 
     if (SvTYPE(hv) == SVt_PVHV) {
+       if (PL_op->op_private & OPpLVAL_INTRO)
+           preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
        he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
        svp = he ? &HeVAL(he) : 0;
     }
@@ -1590,8 +1573,14 @@ PP(pp_helem)
        if (PL_op->op_private & OPpLVAL_INTRO) {
            if (HvNAME(hv) && isGV(*svp))
                save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
-           else
-               save_helem(hv, keysv, svp);
+           else {
+               if (!preeminent) {
+                   STRLEN keylen;
+                   char *key = SvPV(keysv, keylen);
+                   save_delete(hv, key, keylen);
+               } else
+                   save_helem(hv, keysv, svp);
+            }
        }
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
@@ -1790,6 +1779,8 @@ PP(pp_subst)
     STRLEN len;
     int force_on_match = 0;
     I32 oldsave = PL_savestack_ix;
+    bool do_utf8;
+    STRLEN slen;
 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
@@ -1799,6 +1790,8 @@ PP(pp_subst)
        TARG = DEFSV;
        EXTEND(SP,1);
     }
+    PL_reg_sv = TARG;
+    do_utf8 = DO_UTF8(PL_reg_sv);
     if (SvFAKE(TARG) && SvREADONLY(TARG))
        sv_force_normal(TARG);
     if (SvREADONLY(TARG)
@@ -1818,12 +1811,13 @@ PP(pp_subst)
 
   force_it:
     if (!pm || !s)
-       DIE(aTHX_ "panic: do_subst");
+       DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;
-    maxiters = 2*(strend - s) + 10;    /* We can match twice at each
-                                          position, once with zero-length,
-                                          second time with non-zero. */
+    slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+    maxiters = 2 * slen + 10;  /* We can match twice at each
+                                  position, once with zero-length,
+                                  second time with non-zero. */
 
     if (!rx->prelen && PL_curpm) {
        pm = PL_curpm;
@@ -1964,6 +1958,8 @@ PP(pp_subst)
     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
                    r_flags | REXEC_CHECKED))
     {
+       bool isutf8;
+
        if (force_on_match) {
            force_on_match = 0;
            s = SvPV_force(TARG, len);
@@ -1972,6 +1968,8 @@ PP(pp_subst)
        rxtainted |= RX_MATCH_TAINTED(rx);
        dstr = NEWSV(25, len);
        sv_setpvn(dstr, m, s-m);
+       if (DO_UTF8(TARG))
+           SvUTF8_on(dstr);
        PL_curpm = pm;
        if (!c) {
            register PERL_CONTEXT *cx;
@@ -1998,7 +1996,8 @@ PP(pp_subst)
                sv_catpvn(dstr, c, clen);
            if (once)
                break;
-       } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
+       } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
+                            TARG, NULL, r_flags));
        sv_catpvn(dstr, s, strend - s);
 
        (void)SvOOK_off(TARG);
@@ -2006,6 +2005,7 @@ PP(pp_subst)
        SvPVX(TARG) = SvPVX(dstr);
        SvCUR_set(TARG, SvCUR(dstr));
        SvLEN_set(TARG, SvLEN(dstr));
+       isutf8 = DO_UTF8(dstr);
        SvPVX(dstr) = 0;
        sv_free(dstr);
 
@@ -2014,6 +2014,8 @@ PP(pp_subst)
        PUSHs(sv_2mortal(newSViv((I32)iters)));
 
        (void)SvPOK_only(TARG);
+       if (isutf8)
+           SvUTF8_on(TARG);
        TAINT_IF(rxtainted);
        SvSETMAGIC(TARG);
        SvTAINT(TARG);
@@ -2284,7 +2286,6 @@ PP(pp_leavesublv)
 STATIC CV *
 S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
-    dTHR;
     SV *dbsv = GvSV(PL_DBsub);
 
     if (!PERLDB_SUB_NN) {
@@ -2781,12 +2782,15 @@ PP(pp_aelem)
 {
     djSP;
     SV** svp;
-    IV elem = POPi;
+    SV* elemsv = POPs;
+    IV elem = SvIV(elemsv);
     AV* av = (AV*)POPs;
     U32 lval = PL_op->op_flags & OPf_MOD;
     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
     SV *sv;
 
+    if (SvROK(elemsv) && ckWARN(WARN_MISC))
+       Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
     if (elem > 0)
        elem -= PL_curcop->cop_arybase;
     if (SvTYPE(av) != SVt_PVAV)
@@ -2909,7 +2913,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
            !(ob=(SV*)GvIO(iogv)))
        {
            if (!packname ||
-               ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
+               ((UTF8_IS_START(*packname) && DO_UTF8(sv))
                    ? !isIDFIRST_utf8((U8*)packname)
                    : !isIDFIRST(*packname)
                ))
@@ -2988,9 +2992,6 @@ static void
 unset_cvowner(pTHXo_ void *cvarg)
 {
     register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
-    dTHR;
-#endif /* DEBUGGING */
 
     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
                           thr, cv, SvPEEK((SV*)cv))));
index 9329ffd..ca4d1bd 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1,6 +1,6 @@
 /*    pp_sys.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #   include <shadow.h>
 #endif
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-# include <unistd.h>
-#endif
-
 #ifdef HAS_SYSCALL
 #ifdef __cplusplus
 extern "C" int syscall(unsigned long,...);
@@ -54,25 +49,10 @@ extern "C" int syscall(unsigned long,...);
 # include <sys/resource.h>
 #endif
 
-#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
-# include <sys/socket.h>
-# if defined(USE_SOCKS) && defined(I_SOCKS)
-#   include <socks.h>
-# endif
-# ifdef I_NETDB
-#  include <netdb.h>
-# endif
-# ifndef ENOTSOCK
-#  ifdef I_NET_ERRNO
-#   include <net/errno.h>
-#  endif
-# endif
-#endif
-
 #ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#include <sys/select.h>
-#endif
+# ifdef I_SYS_SELECT
+#  include <sys/select.h>
+# endif
 #endif
 
 /* XXX Configure test needed.
@@ -142,7 +122,7 @@ extern int h_errno;
 #    include <fcntl.h>
 #  endif
 
-#  if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
+#  if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
 #    define FLOCK fcntl_emulate_flock
 #    define FCNTL_EMULATE_FLOCK
 #  else /* no flock() or fcntl(F_SETLK,...) */
@@ -317,6 +297,13 @@ PP(pp_backtick)
        mode = "rt";
     fp = PerlProc_popen(tmps, mode);
     if (fp) {
+       char *type = NULL;
+       if (PL_curcop->cop_io) {
+           type = SvPV_nolen(PL_curcop->cop_io);
+       }
+       if (type && *type)
+           PerlIO_apply_layers(aTHX_ fp,mode,type);
+
        if (gimme == G_VOID) {
            char tmpbuf[256];
            while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
@@ -461,7 +448,7 @@ PP(pp_die)
     }
     else {
        tmpsv = TOPs;
-       tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
+        tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
     }
     if (!tmps || !len) {
        SV *error = ERRSV;
@@ -658,8 +645,15 @@ PP(pp_fileno)
        RETURN;
     }
 
-    if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
+    if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+       /* Can't do this because people seem to do things like
+          defined(fileno($foo)) to check whether $foo is a valid fh.
+         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+             report_evil_fh(gv, io, PL_op->op_type);
+           */
        RETPUSHUNDEF;
+    }
+
     PUSHi(PerlIO_fileno(fp));
     RETURN;
 }
@@ -697,11 +691,14 @@ PP(pp_binmode)
     PerlIO *fp;
     MAGIC *mg;
     SV *discp = Nullsv;
+    STRLEN len  = 0;
+    char *names = NULL;
 
     if (MAXARG < 1)
        RETPUSHUNDEF;
-    if (MAXARG > 1)
+    if (MAXARG > 1) {
        discp = POPs;
+    }
 
     gv = (GV*)POPs;
 
@@ -719,10 +716,18 @@ PP(pp_binmode)
     }
 
     EXTEND(SP, 1);
-    if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
-       RETPUSHUNDEF;
+    if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
+        RETPUSHUNDEF;
+    }
 
-    if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
+    if (discp) {
+       names = SvPV(discp,len);
+    }
+
+    if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
+                       (discp) ? SvPV_nolen(discp) : Nullch))
        RETPUSHYES;
     else
        RETPUSHUNDEF;
@@ -794,9 +799,12 @@ PP(pp_tie)
     POPSTACK;
     if (sv_isobject(sv)) {
        sv_unmagic(varsv, how);
-       /* Croak if a self-tie is attempted */
-       if (varsv == SvRV(sv))
-           Perl_croak(aTHX_ "Self-ties are not supported");
+       /* Croak if a self-tie on an aggregate is attempted. */
+       if (varsv == SvRV(sv) &&
+           (SvTYPE(sv) == SVt_PVAV ||
+            SvTYPE(sv) == SVt_PVHV))
+           Perl_croak(aTHX_
+                      "Self-ties of arrays and hashes are not supported");
        sv_magic(varsv, sv, how, Nullch, 0);
     }
     LEAVE;
@@ -1061,7 +1069,6 @@ PP(pp_sselect)
 void
 Perl_setdefout(pTHX_ GV *gv)
 {
-    dTHR;
     if (gv)
        (void)SvREFCNT_inc(gv);
     if (PL_defoutgv)
@@ -1132,6 +1139,16 @@ PP(pp_getc)
     TAINT;
     sv_setpv(TARG, " ");
     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
+    if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
+       /* Find out how many bytes the char needs */
+       Size_t len = UTF8SKIP(SvPVX(TARG));
+       if (len > 1) {
+           SvGROW(TARG,len+1);
+           len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
+           SvCUR_set(TARG,1+len);
+       }
+       SvUTF8_on(TARG);
+    }
     PUSHTARG;
     RETURN;
 }
@@ -1144,7 +1161,6 @@ PP(pp_read)
 STATIC OP *
 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
 {
-    dTHR;
     register PERL_CONTEXT *cx;
     I32 gimme = GIMME_V;
     AV* padlist = CvPADLIST(cv);
@@ -1220,6 +1236,8 @@ PP(pp_leavewrite)
 
     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
          (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
+    if (!io || !ofp)
+       goto forget_top;
     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
        PL_formtarget != PL_toptarget)
     {
@@ -1259,13 +1277,16 @@ PP(pp_leavewrite)
                s++;
            }
            if (s) {
-               PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
+               STRLEN save = SvCUR(PL_formtarget);
+               SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
+               do_print(PL_formtarget, ofp);
+               SvCUR_set(PL_formtarget, save);
                sv_chop(PL_formtarget, s);
                FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
            }
        }
        if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
-           PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
+           do_print(PL_formfeed, ofp);
        IoLINES_LEFT(io) = IoPAGE_LEN(io);
        IoPAGE(io)++;
        PL_formtarget = PL_toptarget;
@@ -1326,8 +1347,7 @@ PP(pp_leavewrite)
            if (ckWARN(WARN_IO))
                Perl_warner(aTHX_ WARN_IO, "page overflow");
        }
-       if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
-               PerlIO_error(fp))
+       if (!do_print(PL_formtarget, fp))
            PUSHs(&PL_sv_no);
        else {
            FmLINES(PL_formtarget) = 0;
@@ -1338,6 +1358,7 @@ PP(pp_leavewrite)
            PUSHs(&PL_sv_yes);
        }
     }
+bad_ofp:
     PL_formtarget = PL_bodytarget;
     PUTBACK;
     return pop_return();
@@ -1380,7 +1401,6 @@ PP(pp_prtf)
 
     sv = NEWSV(0,0);
     if (!(io = GvIO(gv))) {
-        dTHR;
        if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
            report_evil_fh(gv, io, PL_op->op_type);
        SETERRNO(EBADF,RMS$_IFI);
@@ -1467,10 +1487,14 @@ PP(pp_sysread)
     IO *io;
     char *buffer;
     SSize_t length;
+    SSize_t count;
     Sock_size_t bufsize;
     SV *bufsv;
     STRLEN blen;
     MAGIC *mg;
+    int fp_utf8;
+    Size_t got = 0;
+    Size_t wanted;
 
     gv = (GV*)*++MARK;
     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
@@ -1495,10 +1519,7 @@ PP(pp_sysread)
     bufsv = *++MARK;
     if (! SvOK(bufsv))
        sv_setpvn(bufsv, "", 0);
-    buffer = SvPV_force(bufsv, blen);
     length = SvIVx(*++MARK);
-    if (length < 0)
-       DIE(aTHX_ "Negative length");
     SETERRNO(0,0);
     if (MARK < SP)
        offset = SvIVx(*++MARK);
@@ -1507,6 +1528,18 @@ PP(pp_sysread)
     io = GvIO(gv);
     if (!io || !IoIFP(io))
        goto say_undef;
+    if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) {
+       buffer = SvPVutf8_force(bufsv, blen);
+       /* UTF8 may not have been set if they are all low bytes */
+       SvUTF8_on(bufsv);
+    }
+    else {
+       buffer = SvPV_force(bufsv, blen);
+    }
+    if (length < 0)
+       DIE(aTHX_ "Negative length");
+    wanted = length;
+
 #ifdef HAS_SOCKET
     if (PL_op->op_type == OP_RECV) {
        char namebuf[MAXPATHLEN];
@@ -1519,19 +1552,17 @@ PP(pp_sysread)
        if (bufsize >= 256)
            bufsize = 255;
 #endif
-#ifdef OS2     /* At least Warp3+IAK: only the first byte of bufsize set */
-       if (bufsize >= 256)
-           bufsize = 255;
-#endif
        buffer = SvGROW(bufsv, length+1);
        /* 'offset' means 'flags' here */
-       length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+       count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
                          (struct sockaddr *)namebuf, &bufsize);
-       if (length < 0)
+       if (count < 0)
            RETPUSHUNDEF;
-       SvCUR_set(bufsv, length);
+       SvCUR_set(bufsv, count);
        *SvEND(bufsv) = '\0';
        (void)SvPOK_only(bufsv);
+       if (fp_utf8)
+           SvUTF8_on(bufsv);
        SvSETMAGIC(bufsv);
        /* This should not be marked tainted if the fp is marked clean */
        if (!(IoFLAGS(io) & IOf_UNTAINT))
@@ -1545,27 +1576,38 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV)
        DIE(aTHX_ PL_no_sock_func, "recv");
 #endif
+    if (DO_UTF8(bufsv)) {
+       /* offset adjust in characters not bytes */
+       blen = sv_len_utf8(bufsv);
+    }
     if (offset < 0) {
        if (-offset > blen)
            DIE(aTHX_ "Offset outside string");
        offset += blen;
     }
+    if (DO_UTF8(bufsv)) {
+       /* convert offset-as-chars to offset-as-bytes */
+       offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
+    }
+ more_bytes:
     bufsize = SvCUR(bufsv);
-    buffer = SvGROW(bufsv, length+offset+1);
+    buffer  = SvGROW(bufsv, length+offset+1);
     if (offset > bufsize) { /* Zero any newly allocated space */
        Zero(buffer+bufsize, offset-bufsize, char);
     }
+    buffer = buffer + offset;
+
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
        if (IoTYPE(io) == IoTYPE_SOCKET) {
-           length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
-                                  buffer+offset, length, 0);
+           count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
+                                  buffer, length, 0);
        }
        else
 #endif
        {
-           length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-                                 buffer+offset, length);
+           count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
+                                 buffer, length);
        }
     }
     else
@@ -1577,18 +1619,18 @@ PP(pp_sysread)
 #else
        bufsize = sizeof namebuf;
 #endif
-       length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
+       count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
                          (struct sockaddr *)namebuf, &bufsize);
     }
     else
 #endif
     {
-       length = PerlIO_read(IoIFP(io), buffer+offset, length);
-       /* fread() returns 0 on both error and EOF */
-       if (length == 0 && PerlIO_error(IoIFP(io)))
-           length = -1;
+       count = PerlIO_read(IoIFP(io), buffer, length);
+       /* PerlIO_read() - like fread() returns 0 on both error and EOF */
+       if (count == 0 && PerlIO_error(IoIFP(io)))
+           count = -1;
     }
-    if (length < 0) {
+    if (count < 0) {
        if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
            || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
        {
@@ -1608,15 +1650,43 @@ PP(pp_sysread)
        }
        goto say_undef;
     }
-    SvCUR_set(bufsv, length+offset);
+    SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
     *SvEND(bufsv) = '\0';
     (void)SvPOK_only(bufsv);
+    if (fp_utf8 && !IN_BYTE) {
+       /* Look at utf8 we got back and count the characters */
+       char *bend = buffer + count;
+       while (buffer < bend) {
+           STRLEN skip = UTF8SKIP(buffer);
+           if (buffer+skip > bend) {
+               /* partial character - try for rest of it */
+               length = skip - (bend-buffer);
+               offset = bend - SvPVX(bufsv);
+               goto more_bytes;
+           }
+           else {
+               got++;
+               buffer += skip;
+           }
+        }
+       /* If we have not 'got' the number of _characters_ we 'wanted' get some more
+          provided amount read (count) was what was requested (length)
+        */
+       if (got < wanted && count == length) {
+           length = (wanted-got);
+           offset = bend - SvPVX(bufsv);
+           goto more_bytes;
+       }
+       /* return value is character count */
+       count = got;
+       SvUTF8_on(bufsv);
+    }
     SvSETMAGIC(bufsv);
     /* This should not be marked tainted if the fp is marked clean */
     if (!(IoFLAGS(io) & IOf_UNTAINT))
        SvTAINTED_on(bufsv);
     SP = ORIGMARK;
-    PUSHi(length);
+    PUSHi(count);
     RETURN;
 
   say_undef:
@@ -1647,7 +1717,6 @@ PP(pp_send)
     char *buffer;
     Size_t length;
     SSize_t retval;
-    IV offset;
     STRLEN blen;
     MAGIC *mg;
 
@@ -1669,7 +1738,6 @@ PP(pp_send)
     if (!gv)
        goto say_undef;
     bufsv = *++MARK;
-    buffer = SvPV(bufsv, blen);
 #if Size_t_size > IVSIZE
     length = (Size_t)SvNVx(*++MARK);
 #else
@@ -1683,8 +1751,24 @@ PP(pp_send)
        retval = -1;
        if (ckWARN(WARN_CLOSED))
            report_evil_fh(gv, io, PL_op->op_type);
+       goto say_undef;
     }
-    else if (PL_op->op_type == OP_SYSWRITE) {
+
+    if (PerlIO_isutf8(IoIFP(io))) {
+       buffer = SvPVutf8(bufsv, blen);
+    }
+    else {
+       if (DO_UTF8(bufsv))
+           sv_utf8_downgrade(bufsv, FALSE);
+       buffer = SvPV(bufsv, blen);
+    }
+
+    if (PL_op->op_type == OP_SYSWRITE) {
+       IV offset;
+       if (DO_UTF8(bufsv)) {
+           /* length and offset are in chars */
+           blen   = sv_len_utf8(bufsv);
+       }
        if (MARK < SP) {
            offset = SvIVx(*++MARK);
            if (offset < 0) {
@@ -1697,17 +1781,24 @@ PP(pp_send)
            offset = 0;
        if (length > blen - offset)
            length = blen - offset;
+       if (DO_UTF8(bufsv)) {
+           buffer = (char*)utf8_hop((U8 *)buffer, offset);
+           length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+       }
+       else {
+           buffer = buffer+offset;
+       }
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
        if (IoTYPE(io) == IoTYPE_SOCKET) {
            retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-                                  buffer+offset, length, 0);
+                                  buffer, length, 0);
        }
        else
 #endif
        {
            /* See the note at doio.c:do_print about filesize limits. --jhi */
            retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-                                  buffer+offset, length);
+                                  buffer, length);
        }
     }
 #ifdef HAS_SOCKET
@@ -1715,12 +1806,13 @@ PP(pp_send)
        char *sockbuf;
        STRLEN mlen;
        sockbuf = SvPVx(*++MARK, mlen);
+       /* length is really flags */
        retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
                                 length, (struct sockaddr *)sockbuf, mlen);
     }
     else
+       /* length is really flags */
        retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
-
 #else
     else
        DIE(aTHX_ PL_no_sock_func, "send");
@@ -1971,9 +2063,11 @@ PP(pp_ioctl)
     char *s;
     IV retval;
     GV *gv = (GV*)POPs;
-    IO *io = GvIOn(gv);
+    IO *io = gv ? GvIOn(gv) : 0;
 
     if (!io || !argsv || !IoIFP(io)) {
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
        SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
        RETPUSHUNDEF;
     }
@@ -2085,16 +2179,17 @@ PP(pp_socket)
     int fd;
 
     gv = (GV*)POPs;
+    io = gv ? GvIOn(gv) : NULL;
 
-    if (!gv) {
+    if (!gv || !io) {
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+           report_evil_fh(gv, io, PL_op->op_type);
+       if (IoIFP(io))
+           do_close(gv, FALSE);
        SETERRNO(EBADF,LIB$_INVARG);
        RETPUSHUNDEF;
     }
 
-    io = GvIOn(gv);
-    if (IoIFP(io))
-       do_close(gv, FALSE);
-
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
     if (fd < 0)
@@ -2133,15 +2228,21 @@ PP(pp_sockpair)
 
     gv2 = (GV*)POPs;
     gv1 = (GV*)POPs;
-    if (!gv1 || !gv2)
+    io1 = gv1 ? GvIOn(gv1) : NULL;
+    io2 = gv2 ? GvIOn(gv2) : NULL;
+    if (!gv1 || !gv2 || !io1 || !io2) {
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+           if (!gv1 || !io1)
+               report_evil_fh(gv1, io1, PL_op->op_type);
+           if (!gv2 || !io2)
+               report_evil_fh(gv1, io2, PL_op->op_type);
+       }
+       if (IoIFP(io1))
+           do_close(gv1, FALSE);
+       if (IoIFP(io2))
+           do_close(gv2, FALSE);
        RETPUSHUNDEF;
-
-    io1 = GvIOn(gv1);
-    io2 = GvIOn(gv2);
-    if (IoIFP(io1))
-       do_close(gv1, FALSE);
-    if (IoIFP(io2))
-       do_close(gv2, FALSE);
+    }
 
     TAINT_PROPER("socketpair");
     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
@@ -2267,9 +2368,9 @@ PP(pp_listen)
 #ifdef HAS_SOCKET
     int backlog = POPi;
     GV *gv = (GV*)POPs;
-    register IO *io = GvIOn(gv);
+    register IO *io = gv ? GvIOn(gv) : NULL;
 
-    if (!io || !IoIFP(io))
+    if (!gv || !io || !IoIFP(io))
        goto nuts;
 
     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
@@ -2546,9 +2647,15 @@ PP(pp_stat)
 
     if (PL_op->op_flags & OPf_REF) {
        gv = cGVOP_gv;
-       if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
-           Perl_warner(aTHX_ WARN_IO,
+       if (PL_op->op_type == OP_LSTAT) {
+           if (PL_laststype != OP_LSTAT)
+               Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
+           if (ckWARN(WARN_IO) && gv != PL_defgv)
+               Perl_warner(aTHX_ WARN_IO,
                        "lstat() on filehandle %s", GvENAME(gv));
+               /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
+       }
+
       do_fstat:
        if (gv != PL_defgv) {
            PL_laststype = OP_STAT;
@@ -2558,7 +2665,6 @@ PP(pp_stat)
                ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
        }
        if (PL_laststatval < 0) {
-           dTHR;
            if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
                report_evil_fh(gv, GvIO(gv), PL_op->op_type);
            max = 0;
@@ -3113,7 +3219,6 @@ PP(pp_fttext)
                len = 512;
        }
        else {
-           dTHR;
            if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
                gv = cGVOP_gv;
                report_evil_fh(gv, GvIO(gv), PL_op->op_type);
@@ -3138,7 +3243,7 @@ PP(pp_fttext)
            (void)PerlIO_close(fp);
            RETPUSHUNDEF;
        }
-       do_binmode(fp, '<', O_BINARY);
+       PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
        len = PerlIO_read(fp, tbuf, sizeof(tbuf));
        (void)PerlIO_close(fp);
        if (len <= 0) {
@@ -3173,12 +3278,12 @@ PP(pp_fttext)
                continue;
 #endif
            /* utf8 characters don't count as odd */
-           if (*s & 0x40) {
+           if (UTF8_IS_START(*s)) {
                int ulen = UTF8SKIP(s);
                if (ulen < len - i) {
                    int j;
                    for (j = 1; j < ulen; j++) {
-                       if ((s[j] & 0xc0) != 0x80)
+                       if (!UTF8_IS_CONTINUATION(s[j]))
                            goto not_utf8;
                    }
                    --ulen;     /* loop does extra increment */
diff --git a/proto.h b/proto.h
index 1b3c280..4c5499e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -58,6 +58,7 @@ START_EXTERN_C
 #  include "pp_proto.h"
 PERL_CALLCONV SV*      Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir);
 PERL_CALLCONV bool     Perl_Gv_AMupdate(pTHX_ HV* stash);
+PERL_CALLCONV CV*      Perl_gv_handler(pTHX_ HV* stash, I32 id);
 PERL_CALLCONV OP*      Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail);
 PERL_CALLCONV OP*      Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
 PERL_CALLCONV I32      Perl_apply(pTHX_ I32 type, SV** mark, SV** sp);
@@ -303,11 +304,11 @@ PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 crea
 PERL_CALLCONV HV*      Perl_gv_stashsv(pTHX_ SV* sv, I32 create);
 PERL_CALLCONV void     Perl_hv_clear(pTHX_ HV* tb);
 PERL_CALLCONV void     Perl_hv_delayfree_ent(pTHX_ HV* hv, HE* entry);
-PERL_CALLCONV SV*      Perl_hv_delete(pTHX_ HV* tb, const char* key, U32 klen, I32 flags);
+PERL_CALLCONV SV*      Perl_hv_delete(pTHX_ HV* tb, const char* key, I32 klen, I32 flags);
 PERL_CALLCONV SV*      Perl_hv_delete_ent(pTHX_ HV* tb, SV* key, I32 flags, U32 hash);
-PERL_CALLCONV bool     Perl_hv_exists(pTHX_ HV* tb, const char* key, U32 klen);
+PERL_CALLCONV bool     Perl_hv_exists(pTHX_ HV* tb, const char* key, I32 klen);
 PERL_CALLCONV bool     Perl_hv_exists_ent(pTHX_ HV* tb, SV* key, U32 hash);
-PERL_CALLCONV SV**     Perl_hv_fetch(pTHX_ HV* tb, const char* key, U32 klen, I32 lval);
+PERL_CALLCONV SV**     Perl_hv_fetch(pTHX_ HV* tb, const char* key, I32 klen, I32 lval);
 PERL_CALLCONV HE*      Perl_hv_fetch_ent(pTHX_ HV* tb, SV* key, I32 lval, U32 hash);
 PERL_CALLCONV void     Perl_hv_free_ent(pTHX_ HV* hv, HE* entry);
 PERL_CALLCONV I32      Perl_hv_iterinit(pTHX_ HV* tb);
@@ -318,7 +319,7 @@ PERL_CALLCONV SV*   Perl_hv_iternextsv(pTHX_ HV* hv, char** key, I32* retlen);
 PERL_CALLCONV SV*      Perl_hv_iterval(pTHX_ HV* tb, HE* entry);
 PERL_CALLCONV void     Perl_hv_ksplit(pTHX_ HV* hv, IV newmax);
 PERL_CALLCONV void     Perl_hv_magic(pTHX_ HV* hv, GV* gv, int how);
-PERL_CALLCONV SV**     Perl_hv_store(pTHX_ HV* tb, const char* key, U32 klen, SV* val, U32 hash);
+PERL_CALLCONV SV**     Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash);
 PERL_CALLCONV HE*      Perl_hv_store_ent(pTHX_ HV* tb, SV* key, SV* val, U32 hash);
 PERL_CALLCONV void     Perl_hv_undef(pTHX_ HV* tb);
 PERL_CALLCONV I32      Perl_ibcmp(pTHX_ const char* a, const char* b, I32 len);
@@ -365,7 +366,7 @@ PERL_CALLCONV bool  Perl_is_uni_xdigit_lc(pTHX_ U32 c);
 PERL_CALLCONV U32      Perl_to_uni_upper_lc(pTHX_ U32 c);
 PERL_CALLCONV U32      Perl_to_uni_title_lc(pTHX_ U32 c);
 PERL_CALLCONV U32      Perl_to_uni_lower_lc(pTHX_ U32 c);
-PERL_CALLCONV int      Perl_is_utf8_char(pTHX_ U8 *p);
+PERL_CALLCONV STRLEN   Perl_is_utf8_char(pTHX_ U8 *p);
 PERL_CALLCONV bool     Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len);
 PERL_CALLCONV bool     Perl_is_utf8_alnum(pTHX_ U8 *p);
 PERL_CALLCONV bool     Perl_is_utf8_alnumc(pTHX_ U8 *p);
@@ -504,7 +505,7 @@ PERL_CALLCONV OP*   Perl_newANONHASH(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_newANONSUB(pTHX_ I32 floor, OP* proto, OP* block);
 PERL_CALLCONV OP*      Perl_newASSIGNOP(pTHX_ I32 flags, OP* left, I32 optype, OP* right);
 PERL_CALLCONV OP*      Perl_newCONDOP(pTHX_ I32 flags, OP* expr, OP* trueop, OP* falseop);
-PERL_CALLCONV void     Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv);
+PERL_CALLCONV CV*      Perl_newCONSTSUB(pTHX_ HV* stash, char* name, SV* sv);
 PERL_CALLCONV void     Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
 PERL_CALLCONV OP*      Perl_newFOROP(pTHX_ I32 flags, char* label, line_t forline, OP* sclr, OP* expr, OP*block, OP*cont);
 PERL_CALLCONV OP*      Perl_newLOGOP(pTHX_ I32 optype, I32 flags, OP* left, OP* right);
@@ -543,7 +544,7 @@ PERL_CALLCONV SV*   Perl_newSVuv(pTHX_ UV u);
 PERL_CALLCONV SV*      Perl_newSVnv(pTHX_ NV n);
 PERL_CALLCONV SV*      Perl_newSVpv(pTHX_ const char* s, STRLEN len);
 PERL_CALLCONV SV*      Perl_newSVpvn(pTHX_ const char* s, STRLEN len);
-PERL_CALLCONV SV*      Perl_newSVpvn_share(pTHX_ const char* s, STRLEN len, U32 hash);
+PERL_CALLCONV SV*      Perl_newSVpvn_share(pTHX_ const char* s, I32 len, U32 hash);
 PERL_CALLCONV SV*      Perl_newSVpvf(pTHX_ const char* pat, ...)
 #ifdef CHECK_FORMAT
  __attribute__((format(printf,pTHX_1,pTHX_2)))
@@ -572,6 +573,7 @@ PERL_CALLCONV void  Perl_pad_free(pTHX_ PADOFFSET po);
 PERL_CALLCONV void     Perl_pad_reset(pTHX);
 PERL_CALLCONV void     Perl_pad_swipe(pTHX_ PADOFFSET po);
 PERL_CALLCONV void     Perl_peep(pTHX_ OP* o);
+PERL_CALLCONV PerlIO*  Perl_start_glob(pTHX_ SV* pattern, IO *io);
 #if defined(PERL_OBJECT)
 PERL_CALLCONV void     Perl_construct(pTHX);
 PERL_CALLCONV void     Perl_destruct(pTHX);
@@ -595,9 +597,9 @@ PERL_CALLCONV HV*   Perl_get_hv(pTHX_ const char* name, I32 create);
 PERL_CALLCONV CV*      Perl_get_cv(pTHX_ const char* name, I32 create);
 PERL_CALLCONV int      Perl_init_i18nl10n(pTHX_ int printwarn);
 PERL_CALLCONV int      Perl_init_i18nl14n(pTHX_ int printwarn);
-PERL_CALLCONV void     Perl_new_collate(pTHX_ const char* newcoll);
-PERL_CALLCONV void     Perl_new_ctype(pTHX_ const char* newctype);
-PERL_CALLCONV void     Perl_new_numeric(pTHX_ const char* newcoll);
+PERL_CALLCONV void     Perl_new_collate(pTHX_ char* newcoll);
+PERL_CALLCONV void     Perl_new_ctype(pTHX_ char* newctype);
+PERL_CALLCONV void     Perl_new_numeric(pTHX_ char* newcoll);
 PERL_CALLCONV void     Perl_set_numeric_local(pTHX);
 PERL_CALLCONV void     Perl_set_numeric_radix(pTHX);
 PERL_CALLCONV void     Perl_set_numeric_standard(pTHX);
@@ -614,6 +616,7 @@ PERL_CALLCONV void  Perl_push_scope(pTHX);
 PERL_CALLCONV OP*      Perl_ref(pTHX_ OP* o, I32 type);
 PERL_CALLCONV OP*      Perl_refkids(pTHX_ OP* o, I32 type);
 PERL_CALLCONV void     Perl_regdump(pTHX_ regexp* r);
+PERL_CALLCONV SV*      Perl_regclass_swash(pTHX_ struct regnode *n, bool doinit, SV **initsvp);
 PERL_CALLCONV I32      Perl_pregexec(pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave);
 PERL_CALLCONV void     Perl_pregfree(pTHX_ struct regexp* r);
 PERL_CALLCONV regexp*  Perl_pregcomp(pTHX_ char* exp, char* xend, PMOP* pm);
@@ -669,6 +672,7 @@ PERL_CALLCONV SV*   Perl_save_scalar(pTHX_ GV* gv);
 PERL_CALLCONV void     Perl_save_pptr(pTHX_ char** pptr);
 PERL_CALLCONV void     Perl_save_vptr(pTHX_ void* pptr);
 PERL_CALLCONV void     Perl_save_re_context(pTHX);
+PERL_CALLCONV void     Perl_save_padsv(pTHX_ PADOFFSET off);
 PERL_CALLCONV void     Perl_save_sptr(pTHX_ SV** sptr);
 PERL_CALLCONV SV*      Perl_save_svref(pTHX_ SV** sptr);
 PERL_CALLCONV SV**     Perl_save_threadsv(pTHX_ PADOFFSET i);
@@ -677,10 +681,10 @@ PERL_CALLCONV OP* Perl_scalar(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_scalarkids(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_scalarseq(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_scalarvoid(pTHX_ OP* o);
-PERL_CALLCONV NV       Perl_scan_bin(pTHX_ char* start, I32 len, I32* retlen);
-PERL_CALLCONV NV       Perl_scan_hex(pTHX_ char* start, I32 len, I32* retlen);
-PERL_CALLCONV char*    Perl_scan_num(pTHX_ char* s);
-PERL_CALLCONV NV       Perl_scan_oct(pTHX_ char* start, I32 len, I32* retlen);
+PERL_CALLCONV NV       Perl_scan_bin(pTHX_ char* start, STRLEN len, STRLEN* retlen);
+PERL_CALLCONV NV       Perl_scan_hex(pTHX_ char* start, STRLEN len, STRLEN* retlen);
+PERL_CALLCONV char*    Perl_scan_num(pTHX_ char* s, YYSTYPE *lvalp);
+PERL_CALLCONV NV       Perl_scan_oct(pTHX_ char* start, STRLEN len, STRLEN* retlen);
 PERL_CALLCONV OP*      Perl_scope(pTHX_ OP* o);
 PERL_CALLCONV char*    Perl_screaminstr(pTHX_ SV* bigsv, SV* littlesv, I32 start_shift, I32 end_shift, I32 *state, I32 last);
 #if !defined(VMS)
@@ -781,6 +785,7 @@ PERL_CALLCONV void  Perl_sv_taint(pTHX_ SV* sv);
 PERL_CALLCONV bool     Perl_sv_tainted(pTHX_ SV* sv);
 PERL_CALLCONV int      Perl_sv_unmagic(pTHX_ SV* sv, int type);
 PERL_CALLCONV void     Perl_sv_unref(pTHX_ SV* sv);
+PERL_CALLCONV void     Perl_sv_unref_flags(pTHX_ SV* sv, U32 flags);
 PERL_CALLCONV void     Perl_sv_untaint(pTHX_ SV* sv);
 PERL_CALLCONV bool     Perl_sv_upgrade(pTHX_ SV* sv, U32 mt);
 PERL_CALLCONV void     Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len);
@@ -805,12 +810,13 @@ PERL_CALLCONV void        Perl_unshare_hek(pTHX_ HEK* hek);
 PERL_CALLCONV void     Perl_utilize(pTHX_ int aver, I32 floor, OP* version, OP* id, OP* arg);
 PERL_CALLCONV U8*      Perl_utf16_to_utf8(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
 PERL_CALLCONV U8*      Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8 *d, I32 bytelen, I32 *newlen);
-PERL_CALLCONV I32      Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
+PERL_CALLCONV STRLEN   Perl_utf8_length(pTHX_ U8* s, U8 *e);
+PERL_CALLCONV IV       Perl_utf8_distance(pTHX_ U8 *a, U8 *b);
 PERL_CALLCONV U8*      Perl_utf8_hop(pTHX_ U8 *s, I32 off);
 PERL_CALLCONV U8*      Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len);
 PERL_CALLCONV U8*      Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len);
-PERL_CALLCONV UV       Perl_utf8_to_uv(pTHX_ U8 *s, I32* retlen);
-PERL_CALLCONV UV       Perl_utf8_to_uv_chk(pTHX_ U8 *s, I32* retlen, bool checking);
+PERL_CALLCONV UV       Perl_utf8_to_uv_simple(pTHX_ U8 *s, STRLEN* retlen);
+PERL_CALLCONV UV       Perl_utf8_to_uv(pTHX_ U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags);
 PERL_CALLCONV U8*      Perl_uv_to_utf8(pTHX_ U8 *d, UV uv);
 PERL_CALLCONV void     Perl_vivify_defelem(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_vivify_ref(pTHX_ SV* sv, U32 to_what);
@@ -832,7 +838,8 @@ PERL_CALLCONV void  Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args);
 PERL_CALLCONV void     Perl_watch(pTHX_ char** addr);
 PERL_CALLCONV I32      Perl_whichsig(pTHX_ char* sig);
 PERL_CALLCONV int      Perl_yyerror(pTHX_ char* s);
-#if defined(USE_PURE_BISON)
+#ifdef USE_PURE_BISON
+PERL_CALLCONV int      Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp);
 PERL_CALLCONV int      Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp);
 #else
 PERL_CALLCONV int      Perl_yylex(pTHX);
@@ -916,6 +923,7 @@ PERL_CALLCONV bool  Perl_sv_utf8_downgrade(pTHX_ SV *sv, bool fail_ok);
 PERL_CALLCONV void     Perl_sv_utf8_encode(pTHX_ SV *sv);
 PERL_CALLCONV bool     Perl_sv_utf8_decode(pTHX_ SV *sv);
 PERL_CALLCONV void     Perl_sv_force_normal(pTHX_ SV *sv);
+PERL_CALLCONV void     Perl_sv_force_normal_flags(pTHX_ SV *sv, U32 flags);
 PERL_CALLCONV void     Perl_tmps_grow(pTHX_ I32 n);
 PERL_CALLCONV SV*      Perl_sv_rvweaken(pTHX_ SV *sv);
 PERL_CALLCONV int      Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg);
@@ -1098,35 +1106,34 @@ STATIC int      S_dooneliner(pTHX_ char *cmd, char *filename);
 #endif
 
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
-STATIC regnode*        S_reg(pTHX_ I32, I32 *);
-STATIC regnode*        S_reganode(pTHX_ U8, U32);
-STATIC regnode*        S_regatom(pTHX_ I32 *);
-STATIC regnode*        S_regbranch(pTHX_ I32 *, I32);
-STATIC void    S_reguni(pTHX_ UV, char *, I32*);
-STATIC regnode*        S_regclass(pTHX);
-STATIC regnode*        S_regclassutf8(pTHX);
+STATIC regnode*        S_reg(pTHX_ struct RExC_state_t*, I32, I32 *);
+STATIC regnode*        S_reganode(pTHX_ struct RExC_state_t*, U8, U32);
+STATIC regnode*        S_regatom(pTHX_ struct RExC_state_t*, I32 *);
+STATIC regnode*        S_regbranch(pTHX_ struct RExC_state_t*, I32 *, I32);
+STATIC void    S_reguni(pTHX_ struct RExC_state_t*, UV, char *, STRLEN*);
+STATIC regnode*        S_regclass(pTHX_ struct RExC_state_t*);
 STATIC I32     S_regcurly(pTHX_ char *);
-STATIC regnode*        S_reg_node(pTHX_ U8);
-STATIC regnode*        S_regpiece(pTHX_ I32 *);
-STATIC void    S_reginsert(pTHX_ U8, regnode *);
-STATIC void    S_regoptail(pTHX_ regnode *, regnode *);
-STATIC void    S_regtail(pTHX_ regnode *, regnode *);
+STATIC regnode*        S_reg_node(pTHX_ struct RExC_state_t*, U8);
+STATIC regnode*        S_regpiece(pTHX_ struct RExC_state_t*, I32 *);
+STATIC void    S_reginsert(pTHX_ struct RExC_state_t*, U8, regnode *);
+STATIC void    S_regoptail(pTHX_ struct RExC_state_t*, regnode *, regnode *);
+STATIC void    S_regtail(pTHX_ struct RExC_state_t*, regnode *, regnode *);
 STATIC char*   S_regwhite(pTHX_ char *, char *);
-STATIC char*   S_nextchar(pTHX);
+STATIC char*   S_nextchar(pTHX_ struct RExC_state_t*);
 STATIC regnode*        S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l);
 STATIC void    S_put_byte(pTHX_ SV* sv, int c);
-STATIC void    S_scan_commit(pTHX_ struct scan_data_t *data);
-STATIC void    S_cl_anything(pTHX_ struct regnode_charclass_class *cl);
+STATIC void    S_scan_commit(pTHX_ struct RExC_state_t*, struct scan_data_t *data);
+STATIC void    S_cl_anything(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl);
 STATIC int     S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl);
-STATIC void    S_cl_init(pTHX_ struct regnode_charclass_class *cl);
-STATIC void    S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl);
+STATIC void    S_cl_init(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl);
+STATIC void    S_cl_init_zero(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl);
 STATIC void    S_cl_and(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *and_with);
-STATIC void    S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with);
-STATIC I32     S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags);
-STATIC I32     S_add_data(pTHX_ I32 n, char *s);
+STATIC void    S_cl_or(pTHX_ struct RExC_state_t*, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with);
+STATIC I32     S_study_chunk(pTHX_ struct RExC_state_t*, regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags);
+STATIC I32     S_add_data(pTHX_ struct RExC_state_t*, I32 n, char *s);
 STATIC void    S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribute__((noreturn));
-STATIC I32     S_regpposixcc(pTHX_ I32 value);
-STATIC void    S_checkposixcc(pTHX);
+STATIC I32     S_regpposixcc(pTHX_ struct RExC_state_t*, I32 value);
+STATIC void    S_checkposixcc(pTHX_ struct RExC_state_t*);
 #endif
 
 #if defined(PERL_IN_REGEXEC_C) || defined(PERL_DECL_PROT)
@@ -1134,14 +1141,15 @@ STATIC I32      S_regmatch(pTHX_ regnode *prog);
 STATIC I32     S_regrepeat(pTHX_ regnode *p, I32 max);
 STATIC I32     S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp);
 STATIC I32     S_regtry(pTHX_ regexp *prog, char *startpos);
-STATIC bool    S_reginclass(pTHX_ regnode *p, I32 c);
-STATIC bool    S_reginclassutf8(pTHX_ regnode *f, U8* p);
+STATIC bool    S_reginclass(pTHX_ regnode *n, U8 *p, bool do_utf8sv_is_utf8);
 STATIC CHECKPOINT      S_regcppush(pTHX_ I32 parenfloor);
 STATIC char*   S_regcppop(pTHX);
 STATIC char*   S_regcp_set_to(pTHX_ I32 ss);
 STATIC void    S_cache_re(pTHX_ regexp *prog);
 STATIC U8*     S_reghop(pTHX_ U8 *pos, I32 off);
+STATIC U8*     S_reghop3(pTHX_ U8 *pos, I32 off, U8 *lim);
 STATIC U8*     S_reghopmaybe(pTHX_ U8 *pos, I32 off);
+STATIC U8*     S_reghopmaybe3(pTHX_ U8 *pos, I32 off, U8 *lim);
 STATIC char*   S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *startpos, I32 norun);
 #endif
 
@@ -1201,6 +1209,10 @@ STATIC void      S_sv_del_backref(pTHX_ SV *sv);
 #  if defined(DEBUGGING)
 STATIC void    S_del_sv(pTHX_ SV *p);
 #  endif
+#  if !defined(NV_PRESERVES_UV)
+STATIC int     S_sv_2inuv_non_preserve(pTHX_ SV *sv, I32 numtype);
+STATIC int     S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype);
+#  endif
 #endif
 
 #if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
@@ -1256,6 +1268,7 @@ STATIC SV*        S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level);
 #endif
 
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+STATIC char*   S_stdize_locale(pTHX_ char* locs);
 STATIC SV*     S_mess_alloc(pTHX);
 #  if defined(LEAKTEST)
 STATIC void    S_xstat(pTHX_ int);
index e7042ea..19d8e8e 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -69,7 +69,7 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1991-2000, Larry Wall
+ ****    Copyright (c) 1991-2001, Larry Wall
  ****
  ****    You may distribute under the terms of either the GNU General Public
  ****    License or the Artistic License, as specified in the README file.
 #define        STATIC  static
 #endif
 
+typedef struct RExC_state_t {
+    U16                flags16;                /* are we folding, multilining? */
+    char       *precomp;               /* uncompiled string. */
+    regexp     *rx;
+    char       *end;                   /* End of input for compile */
+    char       *parse;                 /* Input-scan pointer. */
+    I32                whilem_seen;            /* number of WHILEM in this expr */
+    regnode    *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
+    I32                naughty;                /* How bad is this pattern? */
+    I32                sawback;                /* Did we see \1, ...? */
+    U32                seen;
+    I32                size;                   /* Code size. */
+    I32                npar;                   /* () count. */
+    I32                extralen;
+    I32                seen_zerolen;
+    I32                seen_evals;
+    I32                utf8;
+#if ADD_TO_REGEXEC
+    char       *starttry;              /* -Dr: where regtry was called. */
+#define RExC_starttry  (pRExC_state->starttry)
+#endif
+} RExC_state_t;
+
+#define RExC_flags16   (pRExC_state->flags16)
+#define RExC_precomp   (pRExC_state->precomp)
+#define RExC_rx                (pRExC_state->rx)
+#define RExC_end       (pRExC_state->end)
+#define RExC_parse     (pRExC_state->parse)
+#define RExC_whilem_seen       (pRExC_state->whilem_seen)
+#define RExC_emit      (pRExC_state->emit)
+#define RExC_naughty   (pRExC_state->naughty)
+#define RExC_sawback   (pRExC_state->sawback)
+#define RExC_seen      (pRExC_state->seen)
+#define RExC_size      (pRExC_state->size)
+#define RExC_npar      (pRExC_state->npar)
+#define RExC_extralen  (pRExC_state->extralen)
+#define RExC_seen_zerolen      (pRExC_state->seen_zerolen)
+#define RExC_seen_evals        (pRExC_state->seen_evals)
+#define RExC_utf8      (pRExC_state->utf8)
+
 #define        ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
 #define        ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
        ((*s) == '{' && regcurly(s)))
@@ -151,6 +191,7 @@ typedef struct scan_data_t {
     I32 offset_float_max;
     I32 flags;
     I32 whilem_c;
+    I32 *last_closep;
     struct regnode_charclass_class *start_class;
 } scan_data_t;
 
@@ -159,7 +200,7 @@ typedef struct scan_data_t {
  */
 
 static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
-                                     0, 0, 0, 0, 0 };
+                                     0, 0, 0, 0, 0, 0};
 
 #define SF_BEFORE_EOL          (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
 #define SF_BEFORE_SEOL         0x1
@@ -188,14 +229,13 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define SCF_DO_STCLASS_AND     0x0800
 #define SCF_DO_STCLASS_OR      0x1000
 #define SCF_DO_STCLASS         (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
+#define SCF_WHILEM_VISITED_POS 0x2000
 
-#define RF_utf8                8
-#define UTF (PL_reg_flags & RF_utf8)
-#define LOC (PL_regflags & PMf_LOCALE)
-#define FOLD (PL_regflags & PMf_FOLD)
+#define UTF RExC_utf8
+#define LOC (RExC_flags16 & PMf_LOCALE)
+#define FOLD (RExC_flags16 & PMf_FOLD)
 
-#define OOB_CHAR8              1234
-#define OOB_UTF8               123456
+#define OOB_UNICODE            12345678
 #define OOB_NAMEDCLASS         -1
 
 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
@@ -223,10 +263,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define        FAIL(msg)                                                             \
     STMT_START {                                                             \
         char *ellipses = "";                                                 \
-        unsigned len = strlen(PL_regprecomp);                                \
+        unsigned len = strlen(RExC_precomp);                                \
                                                                              \
        if (!SIZE_ONLY)                                                      \
-           SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx);                 \
+           SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                 \
                                                                              \
        if (len > RegexLengthToShowInErrorMessages) {                        \
             /* chop 10 shorter than the max, to ensure meaning of "..." */   \
@@ -234,7 +274,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
            ellipses = "...";                                                \
        }                                                                    \
        Perl_croak(aTHX_ "%s in regex m/%.*s%s/",                            \
-                  msg, (int)len, PL_regprecomp, ellipses);                  \
+                  msg, (int)len, RExC_precomp, ellipses);                  \
     } STMT_END
 
 /*
@@ -245,10 +285,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define        FAIL2(pat,msg)                                                        \
     STMT_START {                                                             \
         char *ellipses = "";                                                 \
-        unsigned len = strlen(PL_regprecomp);                                \
+        unsigned len = strlen(RExC_precomp);                                \
                                                                              \
        if (!SIZE_ONLY)                                                      \
-           SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx);                 \
+           SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                 \
                                                                              \
        if (len > RegexLengthToShowInErrorMessages) {                        \
             /* chop 10 shorter than the max, to ensure meaning of "..." */   \
@@ -256,7 +296,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
            ellipses = "...";                                                \
        }                                                                    \
        S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/",                        \
-                   msg, (int)len, PL_regprecomp, ellipses);                \
+                   msg, (int)len, RExC_precomp, ellipses);                \
     } STMT_END
 
 
@@ -265,10 +305,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define        Simple_vFAIL(m)                                                      \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \
                                                                              \
       Perl_croak(aTHX_ "%s" REPORT_LOCATION,               \
-                m, (int)offset, PL_regprecomp, PL_regprecomp + offset);     \
+                m, (int)offset, RExC_precomp, RExC_precomp + offset);     \
     } STMT_END
 
 /*
@@ -277,7 +317,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define        vFAIL(m)                                                             \
     STMT_START {                                                             \
       if (!SIZE_ONLY)                                                        \
-           SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx);                 \
+           SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                 \
       Simple_vFAIL(m);                                                       \
     } STMT_END
 
@@ -286,10 +326,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define        Simple_vFAIL2(m,a1)                                                  \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \
                                                                              \
       S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,       \
-                 (int)offset, PL_regprecomp, PL_regprecomp + offset);       \
+                 (int)offset, RExC_precomp, RExC_precomp + offset);       \
     } STMT_END
 
 /*
@@ -298,7 +338,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define        vFAIL2(m,a1)                                                         \
     STMT_START {                                                             \
       if (!SIZE_ONLY)                                                        \
-           SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx);                 \
+           SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                 \
       Simple_vFAIL2(m, a1);                                                  \
     } STMT_END
 
@@ -308,10 +348,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define        Simple_vFAIL3(m, a1, a2)                                             \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \
                                                                              \
       S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,   \
-                 (int)offset, PL_regprecomp, PL_regprecomp + offset);       \
+                 (int)offset, RExC_precomp, RExC_precomp + offset);       \
     } STMT_END
 
 /*
@@ -320,7 +360,7 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 #define        vFAIL3(m,a1,a2)                                                      \
     STMT_START {                                                             \
       if (!SIZE_ONLY)                                                        \
-           SAVEDESTRUCTOR_X(clear_re,(void*)PL_regcomp_rx);                 \
+           SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                 \
       Simple_vFAIL3(m, a1, a2);                                              \
     } STMT_END
 
@@ -329,10 +369,10 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define        Simple_vFAIL4(m, a1, a2, a3)                                         \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \
                                                                              \
       S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,\
-                 (int)offset, PL_regprecomp, PL_regprecomp + offset);       \
+                 (int)offset, RExC_precomp, RExC_precomp + offset);       \
     } STMT_END
 
 /*
@@ -340,46 +380,45 @@ static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  */
 #define        Simple_vFAIL5(m, a1, a2, a3, a4)                                     \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-PL_regcomp_parse); \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-RExC_parse); \
       S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,\
-                 (int)offset, PL_regprecomp, PL_regprecomp + offset);       \
+                 (int)offset, RExC_precomp, RExC_precomp + offset);       \
     } STMT_END
 
 
 #define        vWARN(loc,m)                                                         \
     STMT_START {                                                             \
-        unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc));          \
+        unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc));          \
        Perl_warner(aTHX_ WARN_REGEXP, "%s" REPORT_LOCATION,\
-                m, (int)offset, PL_regprecomp, PL_regprecomp + offset);          \
+                m, (int)offset, RExC_precomp, RExC_precomp + offset);          \
     } STMT_END                                                               \
 
 
 #define        vWARN2(loc, m, a1)                                                   \
     STMT_START {                                                             \
-        unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc));          \
+        unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc));          \
        Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
                  a1,                                                         \
-                (int)offset, PL_regprecomp, PL_regprecomp + offset);        \
+                (int)offset, RExC_precomp, RExC_precomp + offset);        \
     } STMT_END
 
 #define        vWARN3(loc, m, a1, a2)                                               \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp) - (PL_regxend - (loc));        \
+      unsigned offset = strlen(RExC_precomp) - (RExC_end - (loc));        \
        Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,                    \
                  a1, a2,                                                     \
-                (int)offset, PL_regprecomp, PL_regprecomp + offset);        \
+                (int)offset, RExC_precomp, RExC_precomp + offset);        \
     } STMT_END
 
 #define        vWARN4(loc, m, a1, a2, a3)                                           \
     STMT_START {                                                             \
-      unsigned offset = strlen(PL_regprecomp)-(PL_regxend-(loc));            \
+      unsigned offset = strlen(RExC_precomp)-(RExC_end-(loc));            \
        Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
                  a1, a2, a3,                                                 \
-                (int)offset, PL_regprecomp, PL_regprecomp + offset);        \
+                (int)offset, RExC_precomp, RExC_precomp + offset);        \
     } STMT_END
 
 
-
 /* Allow for side effects in s */
 #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (s);} STMT_END
 
@@ -390,9 +429,8 @@ static void clear_re(pTHXo_ void *r);
    floating substrings if needed. */
 
 STATIC void
-S_scan_commit(pTHX_ scan_data_t *data)
+S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
 {
-    dTHR;
     STRLEN l = CHR_SVLEN(data->last_found);
     STRLEN old_l = CHR_SVLEN(*data->longest);
     
@@ -425,14 +463,14 @@ S_scan_commit(pTHX_ scan_data_t *data)
 
 /* Can match anything (initialization) */
 STATIC void
-S_cl_anything(pTHX_ struct regnode_charclass_class *cl)
+S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 {
     int value;
 
     ANYOF_CLASS_ZERO(cl);
     for (value = 0; value < 256; ++value)
        ANYOF_BITMAP_SET(cl, value);
-    cl->flags = ANYOF_EOS;
+    cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
     if (LOC)
        cl->flags |= ANYOF_LOCALE;
 }
@@ -446,6 +484,8 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
     for (value = 0; value <= ANYOF_MAX; value += 2)
        if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
            return 1;
+    if (!(cl->flags & ANYOF_UNICODE_ALL))
+       return 0;
     for (value = 0; value < 256; ++value)
        if (!ANYOF_BITMAP_TEST(cl, value))
            return 0;
@@ -454,19 +494,19 @@ S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
 
 /* Can match anything (initialization) */
 STATIC void
-S_cl_init(pTHX_ struct regnode_charclass_class *cl)
+S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 {
     Zero(cl, 1, struct regnode_charclass_class);
     cl->type = ANYOF;
-    cl_anything(cl);
+    cl_anything(pRExC_state, cl);
 }
 
 STATIC void
-S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl)
+S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 {
     Zero(cl, 1, struct regnode_charclass_class);
     cl->type = ANYOF;
-    cl_anything(cl);
+    cl_anything(pRExC_state, cl);
     if (LOC)
        cl->flags |= ANYOF_LOCALE;
 }
@@ -493,12 +533,22 @@ S_cl_and(pTHX_ struct regnode_charclass_class *cl,
     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
     if (!(and_with->flags & ANYOF_EOS))
        cl->flags &= ~ANYOF_EOS;
+
+    if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE) {
+       cl->flags &= ~ANYOF_UNICODE_ALL;
+       cl->flags |= ANYOF_UNICODE;
+       ARG_SET(cl, ARG(and_with));
+    }
+    if (!(and_with->flags & ANYOF_UNICODE_ALL))
+       cl->flags &= ~ANYOF_UNICODE_ALL;
+    if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)))
+       cl->flags &= ~ANYOF_UNICODE;
 }
 
 /* 'OR' a given class with another one.  Can create false positives */
 /* We assume that cl is not inverted */
 STATIC void
-S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
+S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
 {
     if (or_with->flags & ANYOF_INVERT) {
        /* We do not use
@@ -519,7 +569,7 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class
                cl->bitmap[i] |= ~or_with->bitmap[i];
        } /* XXXX: logic is complicated otherwise */
        else {
-           cl_anything(cl);
+           cl_anything(pRExC_state, cl);
        }
     } else {
        /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
@@ -538,11 +588,21 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class
            }
        }
        else { /* XXXX: logic is complicated, leave it along for a moment. */
-           cl_anything(cl);
+           cl_anything(pRExC_state, cl);
        }
     }
     if (or_with->flags & ANYOF_EOS)
        cl->flags |= ANYOF_EOS;
+
+    if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
+       ARG(cl) != ARG(or_with)) {
+       cl->flags |= ANYOF_UNICODE_ALL;
+       cl->flags &= ~ANYOF_UNICODE;
+    }
+    if (or_with->flags & ANYOF_UNICODE_ALL) {
+       cl->flags |= ANYOF_UNICODE_ALL;
+       cl->flags &= ~ANYOF_UNICODE;
+    }
 }
 
 /* REx optimizer.  Converts nodes into quickier variants "in place".
@@ -552,12 +612,11 @@ S_cl_or(pTHX_ struct regnode_charclass_class *cl, struct regnode_charclass_class
    to the position after last scanned or to NULL. */
 
 STATIC I32
-S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
+S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
                        /* scanp: Start here (read-write). */
                        /* deltap: Write maxlen-minlen here. */
                        /* last: Stop before this one. */
 {
-    dTHR;
     I32 min = 0, pars = 0, code;
     regnode *scan = *scanp, *next;
     I32 delta = 0;
@@ -661,29 +720,35 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                struct regnode_charclass_class accum;
                
                if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
-                   scan_commit(data);  /* Cannot merge strings after this. */
+                   scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
                if (flags & SCF_DO_STCLASS)
-                   cl_init_zero(&accum);
+                   cl_init_zero(pRExC_state, &accum);
                while (OP(scan) == code) {
-                   I32 deltanext, minnext, f = 0;
+                   I32 deltanext, minnext, f = 0, fake;
                    struct regnode_charclass_class this_class;
 
                    num++;
                    data_fake.flags = 0;
-                   if (data)
+                   if (data) {             
                        data_fake.whilem_c = data->whilem_c;
+                       data_fake.last_closep = data->last_closep;
+                   }
+                   else
+                       data_fake.last_closep = &fake;
                    next = regnext(scan);
                    scan = NEXTOPER(scan);
                    if (code != BRANCH)
                        scan = NEXTOPER(scan);
                    if (flags & SCF_DO_STCLASS) {
-                       cl_init(&this_class);
+                       cl_init(pRExC_state, &this_class);
                        data_fake.start_class = &this_class;
                        f = SCF_DO_STCLASS_AND;
                    }               
+                   if (flags & SCF_WHILEM_VISITED_POS)
+                       f |= SCF_WHILEM_VISITED_POS;
                    /* we suppose the run is continuous, last=next...*/
-                   minnext = study_chunk(&scan, &deltanext, next,
-                                         &data_fake, f);
+                   minnext = study_chunk(pRExC_state, &scan, &deltanext,
+                                         next, &data_fake, f);
                    if (min1 > minnext) 
                        min1 = minnext;
                    if (max1 < minnext + deltanext)
@@ -698,7 +763,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    if (data)
                        data->whilem_c = data_fake.whilem_c;
                    if (flags & SCF_DO_STCLASS)
-                       cl_or(&accum, &this_class);
+                       cl_or(pRExC_state, &accum, &this_class);
                    if (code == SUSPEND) 
                        break;
                }
@@ -713,7 +778,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                min += min1;
                delta += max1 - min1;
                if (flags & SCF_DO_STCLASS_OR) {
-                   cl_or(data->start_class, &accum);
+                   cl_or(pRExC_state, data->start_class, &accum);
                    if (min1) {
                        cl_and(data->start_class, &and_with);
                        flags &= ~SCF_DO_STCLASS;
@@ -745,15 +810,11 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
        }
        else if (OP(scan) == EXACT) {
            I32 l = STR_LEN(scan);
+           UV uc = *((U8*)STRING(scan));
            if (UTF) {
-               unsigned char *s = (unsigned char *)STRING(scan);
-               unsigned char *e = s + l;
-               I32 newl = 0;
-               while (s < e) {
-                   newl++;
-                   s += UTF8SKIP(s);
-               }
-               l = newl;
+               U8 *s = (U8*)STRING(scan);
+               l = utf8_length(s, s + l);
+               uc = utf8_to_uv_simple(s, NULL);
            }
            min += l;
            if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
@@ -773,21 +834,22 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                /* Check whether it is compatible with what we know already! */
                int compat = 1;
 
-               if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
-                   && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan))
+               if (uc >= 0x100 ||
+                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
+                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
                    && (!(data->start_class->flags & ANYOF_FOLD)
-                       || !ANYOF_BITMAP_TEST(data->start_class,
-                                             PL_fold[*(U8*)STRING(scan)])))
+                       || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
                    compat = 0;
                ANYOF_CLASS_ZERO(data->start_class);
                ANYOF_BITMAP_ZERO(data->start_class);
                if (compat)
-                   ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
+                   ANYOF_BITMAP_SET(data->start_class, uc);
                data->start_class->flags &= ~ANYOF_EOS;
            }
            else if (flags & SCF_DO_STCLASS_OR) {
                /* false positive possible if the class is case-folded */
-               ANYOF_BITMAP_SET(data->start_class, *STRING(scan));     
+               if (uc < 0x100)
+                   ANYOF_BITMAP_SET(data->start_class, uc);    
                data->start_class->flags &= ~ANYOF_EOS;
                cl_and(data->start_class, &and_with);
            }
@@ -795,19 +857,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
        }
        else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
            I32 l = STR_LEN(scan);
+           UV uc = *((U8*)STRING(scan));
 
            /* Search for fixed substrings supports EXACT only. */
            if (flags & SCF_DO_SUBSTR) 
-               scan_commit(data);
+               scan_commit(pRExC_state, data);
            if (UTF) {
-               unsigned char *s = (unsigned char *)STRING(scan);
-               unsigned char *e = s + l;
-               I32 newl = 0;
-               while (s < e) {
-                   newl++;
-                   s += UTF8SKIP(s);
-               }
-               l = newl;
+               U8 *s = (U8 *)STRING(scan);
+               l = utf8_length(s, s + l);
+               uc = utf8_to_uv_simple(s, NULL);
            }
            min += l;
            if (data && (flags & SCF_DO_SUBSTR))
@@ -816,15 +874,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                /* Check whether it is compatible with what we know already! */
                int compat = 1;
 
-               if (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
-                   && !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan))
-                   && !ANYOF_BITMAP_TEST(data->start_class, 
-                                         PL_fold[*(U8*)STRING(scan)]))
+               if (uc >= 0x100 ||
+                   !(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE)) 
+                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
+                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc]))
                    compat = 0;
                ANYOF_CLASS_ZERO(data->start_class);
                ANYOF_BITMAP_ZERO(data->start_class);
                if (compat) {
-                   ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
+                   ANYOF_BITMAP_SET(data->start_class, uc);
                    data->start_class->flags &= ~ANYOF_EOS;
                    data->start_class->flags |= ANYOF_FOLD;
                    if (OP(scan) == EXACTFL)
@@ -835,7 +893,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                if (data->start_class->flags & ANYOF_FOLD) {
                    /* false positive possible if the class is case-folded.
                       Assume that the locale settings are the same... */
-                   ANYOF_BITMAP_SET(data->start_class, *STRING(scan)); 
+                   if (uc < 0x100)
+                       ANYOF_BITMAP_SET(data->start_class, uc);
                    data->start_class->flags &= ~ANYOF_EOS;
                }
                cl_and(data->start_class, &and_with);
@@ -843,8 +902,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
            flags &= ~SCF_DO_STCLASS;
        }
        else if (strchr((char*)PL_varies,OP(scan))) {
-           I32 mincount, maxcount, minnext, deltanext, pos_before, fl;
-           I32 f = flags;
+           I32 mincount, maxcount, minnext, deltanext, fl;
+           I32 f = flags, pos_before = 0;
            regnode *oscan = scan;
            struct regnode_charclass_class this_class;
            struct regnode_charclass_class *oclass = NULL;
@@ -879,7 +938,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                is_inf = is_inf_internal = 1; 
                scan = regnext(scan);
                if (flags & SCF_DO_SUBSTR) {
-                   scan_commit(data);  /* Cannot extend fixed substrings */
+                   scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
                    data->longest = &(data->longest_float);
                }
                goto optimize_curly_tail;
@@ -887,10 +946,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                mincount = ARG1(scan); 
                maxcount = ARG2(scan);
                next = regnext(scan);
+               if (OP(scan) == CURLYX) {
+                   I32 lp = (data ? *(data->last_closep) : 0);
+
+                   scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX);
+               }
                scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
              do_curly:
                if (flags & SCF_DO_SUBSTR) {
-                   if (mincount == 0) scan_commit(data); /* Cannot extend fixed substrings */
+                   if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
                    pos_before = data->pos_min;
                }
                if (data) {
@@ -900,15 +964,23 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                        data->flags |= SF_IS_INF;
                }
                if (flags & SCF_DO_STCLASS) {
-                   cl_init(&this_class);
+                   cl_init(pRExC_state, &this_class);
                    oclass = data->start_class;
                    data->start_class = &this_class;
                    f |= SCF_DO_STCLASS_AND;
                    f &= ~SCF_DO_STCLASS_OR;
                }
+               /* These are the cases when once a subexpression
+                  fails at a particular position, it cannot succeed
+                  even after backtracking at the enclosing scope.
+                  
+                  XXXX what if minimal match and we are at the
+                       initial run of {n,m}? */
+               if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
+                   f &= ~SCF_WHILEM_VISITED_POS;
 
                /* This will finish on WHILEM, setting scan, or on NULL: */
-               minnext = study_chunk(&scan, &deltanext, last, data, 
+               minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data, 
                                      mincount == 0 
                                        ? (f & ~SCF_DO_SUBSTR) : f);
 
@@ -916,7 +988,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    data->start_class = oclass;
                if (mincount == 0 || minnext == 0) {
                    if (flags & SCF_DO_STCLASS_OR) {
-                       cl_or(data->start_class, &this_class);
+                       cl_or(pRExC_state, data->start_class, &this_class);
                    }
                    else if (flags & SCF_DO_STCLASS_AND) {
                        /* Switch to OR mode: cache the old value of 
@@ -931,7 +1003,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    }
                } else {                /* Non-zero len */
                    if (flags & SCF_DO_STCLASS_OR) {
-                       cl_or(data->start_class, &this_class);
+                       cl_or(pRExC_state, data->start_class, &this_class);
                        cl_and(data->start_class, &and_with);
                    }
                    else if (flags & SCF_DO_STCLASS_AND)
@@ -944,7 +1016,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
                    && maxcount <= REG_INFTY/3) /* Complement check for big count */
                {
-                   vWARN(PL_regcomp_parse,
+                   vWARN(RExC_parse,
                          "Quantifier unexpected on zero-length expression");
                }
 
@@ -1036,20 +1108,27 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                        }
 #endif
                        /* Optimize again: */
-                       study_chunk(&nxt1, &deltanext, nxt, NULL, 0);
+                       study_chunk(pRExC_state, &nxt1, &deltanext, nxt, 
+                                   NULL, 0);
                    }
                    else
                        oscan->flags = 0;
                }
-               else if (OP(oscan) == CURLYX && data && ++data->whilem_c < 16) {
-                   /* This stays as CURLYX, and can put the count/of pair. */
+               else if ((OP(oscan) == CURLYX)
+                        && (flags & SCF_WHILEM_VISITED_POS)
+                        /* See the comment on a similar expression above.
+                           However, this time it not a subexpression
+                           we care about, but the expression itself. */
+                        && (maxcount == REG_INFTY)
+                        && data && ++data->whilem_c < 16) {
+                   /* This stays as CURLYX, we can put the count/of pair. */
                    /* Find WHILEM (as in regexec.c) */
                    regnode *nxt = oscan + NEXT_OFF(oscan);
 
                    if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
                        nxt += ARG(nxt);
                    PREVOPER(nxt)->flags = data->whilem_c
-                       | (PL_reg_whilem_seen << 4); /* On WHILEM */
+                       | (RExC_whilem_seen << 4); /* On WHILEM */
                }
                if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) 
                    pars++;
@@ -1097,7 +1176,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    if (mincount != maxcount) {
                         /* Cannot extend fixed substrings found inside
                            the group.  */
-                       scan_commit(data);
+                       scan_commit(pRExC_state,data);
                        if (mincount && last_str) {
                            sv_setsv(data->last_found, last_str);
                            data->last_end = data->pos_min;
@@ -1123,21 +1202,21 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                continue;
            default:                    /* REF and CLUMP only? */
                if (flags & SCF_DO_SUBSTR) {
-                   scan_commit(data);  /* Cannot expect anything... */
+                   scan_commit(pRExC_state,data);      /* Cannot expect anything... */
                    data->longest = &(data->longest_float);
                }
                is_inf = is_inf_internal = 1;
                if (flags & SCF_DO_STCLASS_OR)
-                   cl_anything(data->start_class);
+                   cl_anything(pRExC_state, data->start_class);
                flags &= ~SCF_DO_STCLASS;
                break;
            }
        }
-       else if (strchr((char*)PL_simple,OP(scan)) || PL_regkind[(U8)OP(scan)] == ANYUTF8) {
+       else if (strchr((char*)PL_simple,OP(scan))) {
            int value;
 
            if (flags & SCF_DO_SUBSTR) {
-               scan_commit(data);
+               scan_commit(pRExC_state,data);
                data->pos_min++;
            }
            min++;
@@ -1147,25 +1226,12 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                /* Some of the logic below assumes that switching
                   locale on will only add false positives. */
                switch (PL_regkind[(U8)OP(scan)]) {
-               case ANYUTF8:
                case SANY:
-               case SANYUTF8:
-               case ALNUMUTF8:
-               case ANYOFUTF8:
-               case ALNUMLUTF8:
-               case NALNUMUTF8:
-               case NALNUMLUTF8:
-               case SPACEUTF8:
-               case NSPACEUTF8:
-               case SPACELUTF8:
-               case NSPACELUTF8:
-               case DIGITUTF8:
-               case NDIGITUTF8:
                default:
                  do_default:
                    /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
                    if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
-                       cl_anything(data->start_class);
+                       cl_anything(pRExC_state, data->start_class);
                    break;
                case REG_ANY:
                    if (OP(scan) == SANY)
@@ -1173,7 +1239,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
                        value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
                                 || (data->start_class->flags & ANYOF_CLASS));
-                       cl_anything(data->start_class);
+                       cl_anything(pRExC_state, data->start_class);
                    }
                    if (flags & SCF_DO_STCLASS_AND || !value)
                        ANYOF_BITMAP_CLEAR(data->start_class,'\n');
@@ -1183,7 +1249,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                        cl_and(data->start_class,
                               (struct regnode_charclass_class*)scan);
                    else
-                       cl_or(data->start_class,
+                       cl_or(pRExC_state, data->start_class,
                              (struct regnode_charclass_class*)scan);
                    break;
                case ALNUM:
@@ -1356,23 +1422,29 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                   && (scan->flags || data || (flags & SCF_DO_STCLASS))
                   && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
            /* Lookahead/lookbehind */
-           I32 deltanext, minnext;
+           I32 deltanext, minnext, fake = 0;
            regnode *nscan;
            struct regnode_charclass_class intrnl;
            int f = 0;
 
            data_fake.flags = 0;
-           if (data)
+           if (data) {             
                data_fake.whilem_c = data->whilem_c;
+               data_fake.last_closep = data->last_closep;
+           }
+           else
+               data_fake.last_closep = &fake;
            if ( flags & SCF_DO_STCLASS && !scan->flags
                 && OP(scan) == IFMATCH ) { /* Lookahead */
-               cl_init(&intrnl);
+               cl_init(pRExC_state, &intrnl);
                data_fake.start_class = &intrnl;
-               f = SCF_DO_STCLASS_AND;
+               f |= SCF_DO_STCLASS_AND;
            }
+           if (flags & SCF_WHILEM_VISITED_POS)
+               f |= SCF_WHILEM_VISITED_POS;
            next = regnext(scan);
            nscan = NEXTOPER(NEXTOPER(scan));
-           minnext = study_chunk(&nscan, &deltanext, last, &data_fake, f);
+           minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f);
            if (scan->flags) {
                if (deltanext) {
                    vFAIL("Variable length lookbehind not implemented");
@@ -1388,7 +1460,7 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                data->flags |= SF_HAS_EVAL;
            if (data)
                data->whilem_c = data_fake.whilem_c;
-           if (f) {
+           if (f & SCF_DO_STCLASS_AND) {
                int was = (data->start_class->flags & ANYOF_EOS);
 
                cl_and(data->start_class, &intrnl);
@@ -1399,11 +1471,15 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
        else if (OP(scan) == OPEN) {
            pars++;
        }
-       else if (OP(scan) == CLOSE && ARG(scan) == is_par) {
-           next = regnext(scan);
+       else if (OP(scan) == CLOSE) {
+           if (ARG(scan) == is_par) {
+               next = regnext(scan);
 
-           if ( next && (OP(next) != WHILEM) && next < last)
-               is_par = 0;             /* Disable optimization */
+               if ( next && (OP(next) != WHILEM) && next < last)
+                   is_par = 0;         /* Disable optimization */
+           }
+           if (data)
+               *(data->last_closep) = ARG(scan);
        }
        else if (OP(scan) == EVAL) {
                if (data)
@@ -1411,12 +1487,12 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
        }
        else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
                if (flags & SCF_DO_SUBSTR) {
-                   scan_commit(data);
+                   scan_commit(pRExC_state,data);
                    data->longest = &(data->longest_float);
                }
                is_inf = is_inf_internal = 1;
                if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
-                   cl_anything(data->start_class);
+                   cl_anything(pRExC_state, data->start_class);
                flags &= ~SCF_DO_STCLASS;
        }
        /* Else: zero-length, ignore. */
@@ -1444,30 +1520,28 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
 }
 
 STATIC I32
-S_add_data(pTHX_ I32 n, char *s)
+S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
 {
-    dTHR;
-    if (PL_regcomp_rx->data) {
-       Renewc(PL_regcomp_rx->data, 
-              sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (PL_regcomp_rx->data->count + n - 1), 
+    if (RExC_rx->data) {
+       Renewc(RExC_rx->data, 
+              sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1), 
               char, struct reg_data);
-       Renew(PL_regcomp_rx->data->what, PL_regcomp_rx->data->count + n, U8);
-       PL_regcomp_rx->data->count += n;
+       Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
+       RExC_rx->data->count += n;
     }
     else {
-       Newc(1207, PL_regcomp_rx->data, sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (n - 1),
+       Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
             char, struct reg_data);
-       New(1208, PL_regcomp_rx->data->what, n, U8);
-       PL_regcomp_rx->data->count = n;
+       New(1208, RExC_rx->data->what, n, U8);
+       RExC_rx->data->count = n;
     }
-    Copy(s, PL_regcomp_rx->data->what + PL_regcomp_rx->data->count - n, n, U8);
-    return PL_regcomp_rx->data->count - n;
+    Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
+    return RExC_rx->data->count - n;
 }
 
 void
 Perl_reginitcolors(pTHX)
 {
-    dTHR;
     int i = 0;
     char *s = PerlEnv_getenv("PERL_RE_COLORS");
            
@@ -1508,7 +1582,6 @@ Perl_reginitcolors(pTHX)
 regexp *
 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
 {
-    dTHR;
     register regexp *r;
     regnode *scan;
     regnode *first;
@@ -1517,100 +1590,102 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     I32 sawplus = 0;
     I32 sawopen = 0;
     scan_data_t data;
+    RExC_state_t RExC_state;
+    RExC_state_t *pRExC_state = &RExC_state;
 
     if (exp == NULL)
        FAIL("NULL regexp argument");
 
-    if (pm->op_pmdynflags & PMdf_UTF8) {
-       PL_reg_flags |= RF_utf8;
-    }
+    /* XXXX This looks very suspicious... */
+    if (pm->op_pmdynflags & PMdf_CMP_UTF8)
+        RExC_utf8 = 1;
     else
-       PL_reg_flags = 0;
+        RExC_utf8 = 0;
 
-    PL_regprecomp = savepvn(exp, xend - exp);
+    RExC_precomp = savepvn(exp, xend - exp);
     DEBUG_r(if (!PL_colorset) reginitcolors());
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
                      PL_colors[4],PL_colors[5],PL_colors[0],
-                     (int)(xend - exp), PL_regprecomp, PL_colors[1]));
-    PL_regflags = pm->op_pmflags;
-    PL_regsawback = 0;
+                     (int)(xend - exp), RExC_precomp, PL_colors[1]));
+    RExC_flags16 = pm->op_pmflags;
+    RExC_sawback = 0;
 
-    PL_regseen = 0;
-    PL_seen_zerolen = *exp == '^' ? -1 : 0;
-    PL_seen_evals = 0;
-    PL_extralen = 0;
+    RExC_seen = 0;
+    RExC_seen_zerolen = *exp == '^' ? -1 : 0;
+    RExC_seen_evals = 0;
+    RExC_extralen = 0;
 
     /* First pass: determine size, legality. */
-    PL_regcomp_parse = exp;
-    PL_regxend = xend;
-    PL_regnaughty = 0;
-    PL_regnpar = 1;
-    PL_regsize = 0L;
-    PL_regcode = &PL_regdummy;
-    PL_reg_whilem_seen = 0;
+    RExC_parse = exp;
+    RExC_end = xend;
+    RExC_naughty = 0;
+    RExC_npar = 1;
+    RExC_size = 0L;
+    RExC_emit = &PL_regdummy;
+    RExC_whilem_seen = 0;
 #if 0 /* REGC() is (currently) a NOP at the first pass.
        * Clever compilers notice this and complain. --jhi */
-    REGC((U8)REG_MAGIC, (char*)PL_regcode);
+    REGC((U8)REG_MAGIC, (char*)RExC_emit);
 #endif
-    if (reg(0, &flags) == NULL) {
-       Safefree(PL_regprecomp);
-       PL_regprecomp = Nullch;
+    if (reg(pRExC_state, 0, &flags) == NULL) {
+       Safefree(RExC_precomp);
+       RExC_precomp = Nullch;
        return(NULL);
     }
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)PL_regsize));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
 
     /* Small enough for pointer-storage convention?
        If extralen==0, this means that we will not need long jumps. */
-    if (PL_regsize >= 0x10000L && PL_extralen)
-        PL_regsize += PL_extralen;
+    if (RExC_size >= 0x10000L && RExC_extralen)
+        RExC_size += RExC_extralen;
     else
-       PL_extralen = 0;
-    if (PL_reg_whilem_seen > 15)
-       PL_reg_whilem_seen = 15;
+       RExC_extralen = 0;
+    if (RExC_whilem_seen > 15)
+       RExC_whilem_seen = 15;
 
     /* Allocate space and initialize. */
-    Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode),
+    Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
         char, regexp);
     if (r == NULL)
        FAIL("Regexp out of space");
 
 #ifdef DEBUGGING
     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
-    Zero(r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), char);
+    Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
 #endif
     r->refcnt = 1;
     r->prelen = xend - exp;
-    r->precomp = PL_regprecomp;
+    r->precomp = RExC_precomp;
     r->subbeg = NULL;
     r->reganch = pm->op_pmflags & PMf_COMPILETIME;
-    r->nparens = PL_regnpar - 1;       /* set early to validate backrefs */
+    r->nparens = RExC_npar - 1;        /* set early to validate backrefs */
 
     r->substrs = 0;                    /* Useful during FAIL. */
     r->startp = 0;                     /* Useful during FAIL. */
     r->endp = 0;                       /* Useful during FAIL. */
 
-    PL_regcomp_rx = r;
+    RExC_rx = r;
 
     /* Second pass: emit code. */
-    PL_regcomp_parse = exp;
-    PL_regxend = xend;
-    PL_regnaughty = 0;
-    PL_regnpar = 1;
-    PL_regcode = r->program;
+    RExC_parse = exp;
+    RExC_end = xend;
+    RExC_naughty = 0;
+    RExC_npar = 1;
+    RExC_emit = r->program;
     /* Store the count of eval-groups for security checks: */
-    PL_regcode->next_off = ((PL_seen_evals > U16_MAX) ? U16_MAX : PL_seen_evals);
-    REGC((U8)REG_MAGIC, (char*) PL_regcode++);
+    RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
+    REGC((U8)REG_MAGIC, (char*) RExC_emit++);
     r->data = 0;
-    if (reg(0, &flags) == NULL)
+    if (reg(pRExC_state, 0, &flags) == NULL)
        return(NULL);
 
     /* Dig out information for optimizations. */
     r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
-    pm->op_pmflags = PL_regflags;
+    pm->op_pmflags = RExC_flags16;
     if (UTF)
        r->reganch |= ROPT_UTF8;
     r->regstclass = NULL;
-    if (PL_regnaughty >= 10)   /* Probably an expensive pattern. */
+    if (RExC_naughty >= 10)    /* Probably an expensive pattern. */
        r->reganch |= ROPT_NAUGHTY;
     scan = r->program + 1;             /* First BRANCH. */
 
@@ -1625,6 +1700,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        STRLEN longest_float_length, longest_fixed_length;
        struct regnode_charclass_class ch_class;
        int stclass_flag;
+       I32 last_close = 0;
 
        first = scan;
        /* Skip introductions and multiplicators >= 1. */
@@ -1645,9 +1721,9 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        /* Starting-point info. */
       again:
        if (PL_regkind[(U8)OP(first)] == EXACT) {
-           if (OP(first) == EXACT);    /* Empty, get anchored substr later. */
-           else if ((OP(first) == EXACTF || OP(first) == EXACTFL)
-                    && !UTF)
+           if (OP(first) == EXACT)
+               ;       /* Empty, get anchored substr later. */
+           else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
                r->regstclass = first;
        }
        else if (strchr((char*)PL_simple,OP(first)))
@@ -1676,7 +1752,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            /* turn .* into ^.* with an implied $*=1 */
            int type = OP(NEXTOPER(first));
 
-           if (type == REG_ANY || type == ANYUTF8)
+           if (type == REG_ANY)
                type = ROPT_ANCH_MBOL;
            else
                type = ROPT_ANCH_SBOL;
@@ -1685,8 +1761,8 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            first = NEXTOPER(first);
            goto again;
        }
-       if (sawplus && (!sawopen || !PL_regsawback) 
-           && !(PL_regseen & REG_SEEN_EVAL)) /* May examine pos and $& */
+       if (sawplus && (!sawopen || !RExC_sawback) 
+           && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
            /* x+ must match at the 1st pos of run of x's */
            r->reganch |= ROPT_SKIP;
 
@@ -1712,27 +1788,28 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        data.longest = &(data.longest_fixed);
        first = scan;
        if (!r->regstclass) {
-           cl_init(&ch_class);
+           cl_init(pRExC_state, &ch_class);
            data.start_class = &ch_class;
            stclass_flag = SCF_DO_STCLASS_AND;
        } else                          /* XXXX Check for BOUND? */
            stclass_flag = 0;
+       data.last_closep = &last_close;
 
-       minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */
-                            &data, SCF_DO_SUBSTR | stclass_flag);
-       if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed)
+       minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
+                            &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
+       if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
             && data.last_start_min == 0 && data.last_end > 0 
-            && !PL_seen_zerolen
-            && (!(PL_regseen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
+            && !RExC_seen_zerolen
+            && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
            r->reganch |= ROPT_CHECK_ALL;
-       scan_commit(&data);
+       scan_commit(pRExC_state, &data);
        SvREFCNT_dec(data.last_found);
 
        longest_float_length = CHR_SVLEN(data.longest_float);
        if (longest_float_length
            || (data.flags & SF_FL_BEFORE_EOL
                && (!(data.flags & SF_FL_BEFORE_MEOL)
-                   || (PL_regflags & PMf_MULTILINE)))) {
+                   || (RExC_flags16 & PMf_MULTILINE)))) {
            int t;
 
            if (SvCUR(data.longest_fixed)                       /* ok to leave SvCUR */
@@ -1745,7 +1822,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            r->float_max_offset = data.offset_float_max;
            t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
                       && (!(data.flags & SF_FL_BEFORE_MEOL)
-                          || (PL_regflags & PMf_MULTILINE)));
+                          || (RExC_flags16 & PMf_MULTILINE)));
            fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
        }
        else {
@@ -1759,14 +1836,14 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        if (longest_fixed_length
            || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
                && (!(data.flags & SF_FIX_BEFORE_MEOL)
-                   || (PL_regflags & PMf_MULTILINE)))) {
+                   || (RExC_flags16 & PMf_MULTILINE)))) {
            int t;
 
            r->anchored_substr = data.longest_fixed;
            r->anchored_offset = data.offset_fixed;
            t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
-                    || (PL_regflags & PMf_MULTILINE)));
+                    || (RExC_flags16 & PMf_MULTILINE)));
            fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
        }
        else {
@@ -1775,22 +1852,22 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            longest_fixed_length = 0;
        }
        if (r->regstclass 
-           && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == ANYUTF8
-               || OP(r->regstclass) == SANYUTF8 || OP(r->regstclass) == SANY))
+           && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
            r->regstclass = NULL;
        if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
            && !(data.start_class->flags & ANYOF_EOS)
            && !cl_is_anything(data.start_class)) {
            SV *sv;
-           I32 n = add_data(1, "f");
+           I32 n = add_data(pRExC_state, 1, "f");
 
-           New(1006, PL_regcomp_rx->data->data[n], 1, 
+           New(1006, RExC_rx->data->data[n], 1, 
                struct regnode_charclass_class);
            StructCopy(data.start_class,
-                      (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n],
+                      (struct regnode_charclass_class*)RExC_rx->data->data[n],
                       struct regnode_charclass_class);
-           r->regstclass = (regnode*)PL_regcomp_rx->data->data[n];
+           r->regstclass = (regnode*)RExC_rx->data->data[n];
            r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
+           PL_regdata = r->data; /* for regprop() */
            DEBUG_r((sv = sv_newmortal(),
                     regprop(sv, (regnode*)data.start_class),
                     PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n",
@@ -1821,24 +1898,26 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        /* Several toplevels. Best we can is to set minlen. */
        I32 fake;
        struct regnode_charclass_class ch_class;
+       I32 last_close = 0;
        
        DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
        scan = r->program + 1;
-       cl_init(&ch_class);
+       cl_init(pRExC_state, &ch_class);
        data.start_class = &ch_class;
-       minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, SCF_DO_STCLASS_AND);
+       data.last_closep = &last_close;
+       minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS);
        r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
        if (!(data.start_class->flags & ANYOF_EOS)
            && !cl_is_anything(data.start_class)) {
            SV *sv;
-           I32 n = add_data(1, "f");
+           I32 n = add_data(pRExC_state, 1, "f");
 
-           New(1006, PL_regcomp_rx->data->data[n], 1, 
+           New(1006, RExC_rx->data->data[n], 1, 
                struct regnode_charclass_class);
            StructCopy(data.start_class,
-                      (struct regnode_charclass_class*)PL_regcomp_rx->data->data[n],
+                      (struct regnode_charclass_class*)RExC_rx->data->data[n],
                       struct regnode_charclass_class);
-           r->regstclass = (regnode*)PL_regcomp_rx->data->data[n];
+           r->regstclass = (regnode*)RExC_rx->data->data[n];
            r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
            DEBUG_r((sv = sv_newmortal(),
                     regprop(sv, (regnode*)data.start_class),
@@ -1848,14 +1927,15 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     }
 
     r->minlen = minlen;
-    if (PL_regseen & REG_SEEN_GPOS) 
+    if (RExC_seen & REG_SEEN_GPOS) 
        r->reganch |= ROPT_GPOS_SEEN;
-    if (PL_regseen & REG_SEEN_LOOKBEHIND)
+    if (RExC_seen & REG_SEEN_LOOKBEHIND)
        r->reganch |= ROPT_LOOKBEHIND_SEEN;
-    if (PL_regseen & REG_SEEN_EVAL)
+    if (RExC_seen & REG_SEEN_EVAL)
        r->reganch |= ROPT_EVAL_SEEN;
-    Newz(1002, r->startp, PL_regnpar, I32);
-    Newz(1002, r->endp, PL_regnpar, I32);
+    Newz(1002, r->startp, RExC_npar, I32);
+    Newz(1002, r->endp, RExC_npar, I32);
+    PL_regdata = r->data; /* for regprop() */
     DEBUG_r(regdump(r));
     return(r);
 }
@@ -1870,43 +1950,42 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
  * follows makes it hard to avoid.
  */
 STATIC regnode *
-S_reg(pTHX_ I32 paren, I32 *flagp)
+S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
 {
-    dTHR;
     register regnode *ret;             /* Will be the head of the group. */
     register regnode *br;
     register regnode *lastbr;
     register regnode *ender = 0;
     register I32 parno = 0;
-    I32 flags, oregflags = PL_regflags, have_branch = 0, open = 0;
-    char *oregcomp_parse = PL_regcomp_parse;
+    I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
+    char *oregcomp_parse = RExC_parse;
     char c;
 
     *flagp = 0;                                /* Tentatively. */
 
     /* Make an OPEN node, if parenthesized. */
     if (paren) {
-       if (*PL_regcomp_parse == '?') {
+       if (*RExC_parse == '?') {
            U16 posflags = 0, negflags = 0;
            U16 *flagsp = &posflags;
            int logical = 0;
-           char *seqstart = PL_regcomp_parse;
+           char *seqstart = RExC_parse;
 
-           PL_regcomp_parse++;
-           paren = *PL_regcomp_parse++;
+           RExC_parse++;
+           paren = *RExC_parse++;
            ret = NULL;                 /* For look-ahead/behind. */
            switch (paren) {
            case '<':
-               PL_regseen |= REG_SEEN_LOOKBEHIND;
-               if (*PL_regcomp_parse == '!') 
+               RExC_seen |= REG_SEEN_LOOKBEHIND;
+               if (*RExC_parse == '!') 
                    paren = ',';
-               if (*PL_regcomp_parse != '=' && *PL_regcomp_parse != '!') 
+               if (*RExC_parse != '=' && *RExC_parse != '!') 
                    goto unknown;
-               PL_regcomp_parse++;
+               RExC_parse++;
            case '=':
            case '!':
-               PL_seen_zerolen++;
+               RExC_seen_zerolen++;
            case ':':
            case '>':
                break;
@@ -1915,51 +1994,50 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
                vFAIL2("Sequence (?%c...) not implemented", (int)paren);
                break;
            case '#':
-               while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
-                   PL_regcomp_parse++;
-               if (*PL_regcomp_parse != ')')
+               while (*RExC_parse && *RExC_parse != ')')
+                   RExC_parse++;
+               if (*RExC_parse != ')')
                    FAIL("Sequence (?#... not terminated");
-               nextchar();
+               nextchar(pRExC_state);
                *flagp = TRYAGAIN;
                return NULL;
            case 'p':
                if (SIZE_ONLY)
-                   vWARN(PL_regcomp_parse, "(?p{}) is deprecated - use (??{})");
+                   vWARN(RExC_parse, "(?p{}) is deprecated - use (??{})");
                /* FALL THROUGH*/
            case '?':
                logical = 1;
-               paren = *PL_regcomp_parse++;
+               paren = *RExC_parse++;
                /* FALL THROUGH */
            case '{':
            {
-               dTHR;
                I32 count = 1, n = 0;
                char c;
-               char *s = PL_regcomp_parse;
+               char *s = RExC_parse;
                SV *sv;
                OP_4tree *sop, *rop;
 
-               PL_seen_zerolen++;
-               PL_regseen |= REG_SEEN_EVAL;
-               while (count && (c = *PL_regcomp_parse)) {
-                   if (c == '\\' && PL_regcomp_parse[1])
-                       PL_regcomp_parse++;
+               RExC_seen_zerolen++;
+               RExC_seen |= REG_SEEN_EVAL;
+               while (count && (c = *RExC_parse)) {
+                   if (c == '\\' && RExC_parse[1])
+                       RExC_parse++;
                    else if (c == '{') 
                        count++;
                    else if (c == '}') 
                        count--;
-                   PL_regcomp_parse++;
+                   RExC_parse++;
                }
-               if (*PL_regcomp_parse != ')')
+               if (*RExC_parse != ')')
                {
-                   PL_regcomp_parse = s;                   
+                   RExC_parse = s;                 
                    vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
                }
                if (!SIZE_ONLY) {
                    AV *av;
                    
-                   if (PL_regcomp_parse - 1 - s) 
-                       sv = newSVpvn(s, PL_regcomp_parse - 1 - s);
+                   if (RExC_parse - 1 - s) 
+                       sv = newSVpvn(s, RExC_parse - 1 - s);
                    else
                        sv = newSVpvn("", 0);
 
@@ -1968,14 +2046,14 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
                    rop = sv_compile_2op(sv, &sop, "re", &av);
                    LEAVE;
 
-                   n = add_data(3, "nop");
-                   PL_regcomp_rx->data->data[n] = (void*)rop;
-                   PL_regcomp_rx->data->data[n+1] = (void*)sop;
-                   PL_regcomp_rx->data->data[n+2] = (void*)av;
+                   n = add_data(pRExC_state, 3, "nop");
+                   RExC_rx->data->data[n] = (void*)rop;
+                   RExC_rx->data->data[n+1] = (void*)sop;
+                   RExC_rx->data->data[n+2] = (void*)av;
                    SvREFCNT_dec(sv);
                }
                else {                                          /* First pass */
-                   if (PL_reginterp_cnt < ++PL_seen_evals
+                   if (PL_reginterp_cnt < ++RExC_seen_evals
                        && PL_curcop != &PL_compiling)
                        /* No compiled RE interpolated, has runtime
                           components ===> unsafe.  */
@@ -1984,113 +2062,113 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
                        FAIL("Eval-group in insecure regular expression");
                }
                
-               nextchar();
+               nextchar(pRExC_state);
                if (logical) {
-                   ret = reg_node(LOGICAL);
+                   ret = reg_node(pRExC_state, LOGICAL);
                    if (!SIZE_ONLY)
                        ret->flags = 2;
-                   regtail(ret, reganode(EVAL, n));
+                   regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
                    return ret;
                }
-               return reganode(EVAL, n);
+               return reganode(pRExC_state, EVAL, n);
            }
            case '(':
            {
-               if (PL_regcomp_parse[0] == '?') {
-                   if (PL_regcomp_parse[1] == '=' || PL_regcomp_parse[1] == '!' 
-                       || PL_regcomp_parse[1] == '<' 
-                       || PL_regcomp_parse[1] == '{') { /* Lookahead or eval. */
+               if (RExC_parse[0] == '?') {
+                   if (RExC_parse[1] == '=' || RExC_parse[1] == '!' 
+                       || RExC_parse[1] == '<' 
+                       || RExC_parse[1] == '{') { /* Lookahead or eval. */
                        I32 flag;
                        
-                       ret = reg_node(LOGICAL);
+                       ret = reg_node(pRExC_state, LOGICAL);
                        if (!SIZE_ONLY)
                            ret->flags = 1;
-                       regtail(ret, reg(1, &flag));
+                       regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
                        goto insert_if;
                    } 
                }
-               else if (PL_regcomp_parse[0] >= '1' && PL_regcomp_parse[0] <= '9' ) {
-                   parno = atoi(PL_regcomp_parse++);
+               else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
+                   parno = atoi(RExC_parse++);
 
-                   while (isDIGIT(*PL_regcomp_parse))
-                       PL_regcomp_parse++;
-                   ret = reganode(GROUPP, parno);
-                   if ((c = *nextchar()) != ')')
+                   while (isDIGIT(*RExC_parse))
+                       RExC_parse++;
+                   ret = reganode(pRExC_state, GROUPP, parno);
+                   if ((c = *nextchar(pRExC_state)) != ')')
                        vFAIL("Switch condition not recognized");
                  insert_if:
-                   regtail(ret, reganode(IFTHEN, 0));
-                   br = regbranch(&flags, 1);
+                   regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
+                   br = regbranch(pRExC_state, &flags, 1);
                    if (br == NULL)
-                       br = reganode(LONGJMP, 0);
+                       br = reganode(pRExC_state, LONGJMP, 0);
                    else
-                       regtail(br, reganode(LONGJMP, 0));
-                   c = *nextchar();
+                       regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
+                   c = *nextchar(pRExC_state);
                    if (flags&HASWIDTH)
                        *flagp |= HASWIDTH;
                    if (c == '|') {
-                       lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */
-                       regbranch(&flags, 1);
-                       regtail(ret, lastbr);
+                       lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
+                       regbranch(pRExC_state, &flags, 1);
+                       regtail(pRExC_state, ret, lastbr);
                        if (flags&HASWIDTH)
                            *flagp |= HASWIDTH;
-                       c = *nextchar();
+                       c = *nextchar(pRExC_state);
                    }
                    else
                        lastbr = NULL;
                    if (c != ')')
                        vFAIL("Switch (?(condition)... contains too many branches");
-                   ender = reg_node(TAIL);
-                   regtail(br, ender);
+                   ender = reg_node(pRExC_state, TAIL);
+                   regtail(pRExC_state, br, ender);
                    if (lastbr) {
-                       regtail(lastbr, ender);
-                       regtail(NEXTOPER(NEXTOPER(lastbr)), ender);
+                       regtail(pRExC_state, lastbr, ender);
+                       regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
                    }
                    else
-                       regtail(ret, ender);
+                       regtail(pRExC_state, ret, ender);
                    return ret;
                }
                else {
-                   vFAIL2("Unknown switch condition (?(%.2s", PL_regcomp_parse);
+                   vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
                }
            }
             case 0:
-               PL_regcomp_parse--; /* for vFAIL to print correctly */
+               RExC_parse--; /* for vFAIL to print correctly */
                 vFAIL("Sequence (? incomplete");
                 break;
            default:
-               --PL_regcomp_parse;
+               --RExC_parse;
              parse_flags:
-               while (*PL_regcomp_parse && strchr("iogcmsx", *PL_regcomp_parse)) {
-                   if (*PL_regcomp_parse != 'o')
-                       pmflag(flagsp, *PL_regcomp_parse);
-                   ++PL_regcomp_parse;
+               while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
+                   if (*RExC_parse != 'o')
+                       pmflag(flagsp, *RExC_parse);
+                   ++RExC_parse;
                }
-               if (*PL_regcomp_parse == '-') {
+               if (*RExC_parse == '-') {
                    flagsp = &negflags;
-                   ++PL_regcomp_parse;
+                   ++RExC_parse;
                    goto parse_flags;
                }
-               PL_regflags |= posflags;
-               PL_regflags &= ~negflags;
-               if (*PL_regcomp_parse == ':') {
-                   PL_regcomp_parse++;
+               RExC_flags16 |= posflags;
+               RExC_flags16 &= ~negflags;
+               if (*RExC_parse == ':') {
+                   RExC_parse++;
                    paren = ':';
                    break;
                }               
              unknown:
-               if (*PL_regcomp_parse != ')') {
-                   PL_regcomp_parse++;
-                   vFAIL3("Sequence (%.*s...) not recognized", PL_regcomp_parse-seqstart, seqstart);
+               if (*RExC_parse != ')') {
+                   RExC_parse++;
+                   vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
                }
-               nextchar();
+               nextchar(pRExC_state);
                *flagp = TRYAGAIN;
                return NULL;
            }
        }
        else {
-           parno = PL_regnpar;
-           PL_regnpar++;
-           ret = reganode(OPEN, parno);
+           parno = RExC_npar;
+           RExC_npar++;
+           ret = reganode(pRExC_state, OPEN, parno);
            open = 1;
        }
     }
@@ -2098,24 +2176,24 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
        ret = NULL;
 
     /* Pick up the branches, linking them together. */
-    br = regbranch(&flags, 1);
+    br = regbranch(pRExC_state, &flags, 1);
     if (br == NULL)
        return(NULL);
-    if (*PL_regcomp_parse == '|') {
-       if (!SIZE_ONLY && PL_extralen) {
-           reginsert(BRANCHJ, br);
+    if (*RExC_parse == '|') {
+       if (!SIZE_ONLY && RExC_extralen) {
+           reginsert(pRExC_state, BRANCHJ, br);
        }
        else
-           reginsert(BRANCH, br);
+           reginsert(pRExC_state, BRANCH, br);
        have_branch = 1;
        if (SIZE_ONLY)
-           PL_extralen += 1;           /* For BRANCHJ-BRANCH. */
+           RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
     }
     else if (paren == ':') {
        *flagp |= flags&SIMPLE;
     }
     if (open) {                                /* Starts with OPEN. */
-       regtail(ret, br);               /* OPEN -> first. */
+       regtail(pRExC_state, ret, br);          /* OPEN -> first. */
     }
     else if (paren != '?')             /* Not Conditional */
        ret = br;
@@ -2123,18 +2201,18 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
        *flagp |= HASWIDTH;
     *flagp |= flags&SPSTART;
     lastbr = br;
-    while (*PL_regcomp_parse == '|') {
-       if (!SIZE_ONLY && PL_extralen) {
-           ender = reganode(LONGJMP,0);
-           regtail(NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
+    while (*RExC_parse == '|') {
+       if (!SIZE_ONLY && RExC_extralen) {
+           ender = reganode(pRExC_state, LONGJMP,0);
+           regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
        }
        if (SIZE_ONLY)
-           PL_extralen += 2;           /* Account for LONGJMP. */
-       nextchar();
-       br = regbranch(&flags, 0);
+           RExC_extralen += 2;         /* Account for LONGJMP. */
+       nextchar(pRExC_state);
+       br = regbranch(pRExC_state, &flags, 0);
        if (br == NULL)
            return(NULL);
-       regtail(lastbr, br);            /* BRANCH -> BRANCH. */
+       regtail(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
        lastbr = br;
        if (flags&HASWIDTH)
            *flagp |= HASWIDTH;
@@ -2145,10 +2223,10 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
        /* Make a closing node, and hook it on the end. */
        switch (paren) {
        case ':':
-           ender = reg_node(TAIL);
+           ender = reg_node(pRExC_state, TAIL);
            break;
        case 1:
-           ender = reganode(CLOSE, parno);
+           ender = reganode(pRExC_state, CLOSE, parno);
            break;
        case '<':
        case ',':
@@ -2157,18 +2235,18 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
            *flagp &= ~HASWIDTH;
            /* FALL THROUGH */
        case '>':
-           ender = reg_node(SUCCEED);
+           ender = reg_node(pRExC_state, SUCCEED);
            break;
        case 0:
-           ender = reg_node(END);
+           ender = reg_node(pRExC_state, END);
            break;
        }
-       regtail(lastbr, ender);
+       regtail(pRExC_state, lastbr, ender);
 
        if (have_branch) {
            /* Hook the tails of the branches to the closing node. */
            for (br = ret; br != NULL; br = regnext(br)) {
-               regoptail(br, ender);
+               regoptail(pRExC_state, br, ender);
            }
        }
     }
@@ -2183,23 +2261,23 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
 
            if (paren == '>')
                node = SUSPEND, flag = 0;
-           reginsert(node,ret);
+           reginsert(pRExC_state, node,ret);
            ret->flags = flag;
-           regtail(ret, reg_node(TAIL));
+           regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
        }
     }
 
     /* Check for proper termination. */
     if (paren) {
-       PL_regflags = oregflags;
-       if (PL_regcomp_parse >= PL_regxend || *nextchar() != ')') {
-           PL_regcomp_parse = oregcomp_parse;
+       RExC_flags16 = oregflags;
+       if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
+           RExC_parse = oregcomp_parse;
            vFAIL("Unmatched (");
        }
     }
-    else if (!paren && PL_regcomp_parse < PL_regxend) {
-       if (*PL_regcomp_parse == ')') {
-           PL_regcomp_parse++;
+    else if (!paren && RExC_parse < RExC_end) {
+       if (*RExC_parse == ')') {
+           RExC_parse++;
            vFAIL("Unmatched )");
        }
        else
@@ -2216,9 +2294,8 @@ S_reg(pTHX_ I32 paren, I32 *flagp)
  * Implements the concatenation operator.
  */
 STATIC regnode *
-S_regbranch(pTHX_ I32 *flagp, I32 first)
+S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
 {
-    dTHR;
     register regnode *ret;
     register regnode *chain = NULL;
     register regnode *latest;
@@ -2227,22 +2304,22 @@ S_regbranch(pTHX_ I32 *flagp, I32 first)
     if (first) 
        ret = NULL;
     else {
-       if (!SIZE_ONLY && PL_extralen) 
-           ret = reganode(BRANCHJ,0);
+       if (!SIZE_ONLY && RExC_extralen) 
+           ret = reganode(pRExC_state, BRANCHJ,0);
        else
-           ret = reg_node(BRANCH);
+           ret = reg_node(pRExC_state, BRANCH);
     }
        
     if (!first && SIZE_ONLY) 
-       PL_extralen += 1;                       /* BRANCHJ */
+       RExC_extralen += 1;                     /* BRANCHJ */
     
     *flagp = WORST;                    /* Tentatively. */
 
-    PL_regcomp_parse--;
-    nextchar();
-    while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '|' && *PL_regcomp_parse != ')') {
+    RExC_parse--;
+    nextchar(pRExC_state);
+    while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
        flags &= ~TRYAGAIN;
-       latest = regpiece(&flags);
+       latest = regpiece(pRExC_state, &flags);
        if (latest == NULL) {
            if (flags & TRYAGAIN)
                continue;
@@ -2254,14 +2331,14 @@ S_regbranch(pTHX_ I32 *flagp, I32 first)
        if (chain == NULL)      /* First piece. */
            *flagp |= flags&SPSTART;
        else {
-           PL_regnaughty++;
-           regtail(chain, latest);
+           RExC_naughty++;
+           regtail(pRExC_state, chain, latest);
        }
        chain = latest;
        c++;
     }
     if (chain == NULL) {       /* Loop ran zero times. */
-       chain = reg_node(NOTHING);
+       chain = reg_node(pRExC_state, NOTHING);
        if (ret == NULL)
            ret = chain;
     }
@@ -2282,29 +2359,28 @@ S_regbranch(pTHX_ I32 *flagp, I32 first)
  * endmarker role is not redundant.
  */
 STATIC regnode *
-S_regpiece(pTHX_ I32 *flagp)
+S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
 {
-    dTHR;
     register regnode *ret;
     register char op;
     register char *next;
     I32 flags;
-    char *origparse = PL_regcomp_parse;
+    char *origparse = RExC_parse;
     char *maxpos;
     I32 min;
     I32 max = REG_INFTY;
 
-    ret = regatom(&flags);
+    ret = regatom(pRExC_state, &flags);
     if (ret == NULL) {
        if (flags & TRYAGAIN)
            *flagp |= TRYAGAIN;
        return(NULL);
     }
 
-    op = *PL_regcomp_parse;
+    op = *RExC_parse;
 
-    if (op == '{' && regcurly(PL_regcomp_parse)) {
-       next = PL_regcomp_parse + 1;
+    if (op == '{' && regcurly(RExC_parse)) {
+       next = RExC_parse + 1;
        maxpos = Nullch;
        while (isDIGIT(*next) || *next == ',') {
            if (*next == ',') {
@@ -2318,42 +2394,42 @@ S_regpiece(pTHX_ I32 *flagp)
        if (*next == '}') {             /* got one */
            if (!maxpos)
                maxpos = next;
-           PL_regcomp_parse++;
-           min = atoi(PL_regcomp_parse);
+           RExC_parse++;
+           min = atoi(RExC_parse);
            if (*maxpos == ',')
                maxpos++;
            else
-               maxpos = PL_regcomp_parse;
+               maxpos = RExC_parse;
            max = atoi(maxpos);
            if (!max && *maxpos != '0')
                max = REG_INFTY;                /* meaning "infinity" */
            else if (max >= REG_INFTY)
                vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
-           PL_regcomp_parse = next;
-           nextchar();
+           RExC_parse = next;
+           nextchar(pRExC_state);
 
        do_curly:
            if ((flags&SIMPLE)) {
-               PL_regnaughty += 2 + PL_regnaughty / 2;
-               reginsert(CURLY, ret);
+               RExC_naughty += 2 + RExC_naughty / 2;
+               reginsert(pRExC_state, CURLY, ret);
            }
            else {
-               regnode *w = reg_node(WHILEM);
+               regnode *w = reg_node(pRExC_state, WHILEM);
 
                w->flags = 0;
-               regtail(ret, w);
-               if (!SIZE_ONLY && PL_extralen) {
-                   reginsert(LONGJMP,ret);
-                   reginsert(NOTHING,ret);
+               regtail(pRExC_state, ret, w);
+               if (!SIZE_ONLY && RExC_extralen) {
+                   reginsert(pRExC_state, LONGJMP,ret);
+                   reginsert(pRExC_state, NOTHING,ret);
                    NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
                }
-               reginsert(CURLYX,ret);
-               if (!SIZE_ONLY && PL_extralen)
+               reginsert(pRExC_state, CURLYX,ret);
+               if (!SIZE_ONLY && RExC_extralen)
                    NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
-               regtail(ret, reg_node(NOTHING));
+               regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
                if (SIZE_ONLY)
-                   PL_reg_whilem_seen++, PL_extralen += 3;
-               PL_regnaughty += 4 + PL_regnaughty;     /* compound interest */
+                   RExC_whilem_seen++, RExC_extralen += 3;
+               RExC_naughty += 4 + RExC_naughty;       /* compound interest */
            }
            ret->flags = 0;
 
@@ -2393,23 +2469,23 @@ S_regpiece(pTHX_ I32 *flagp)
       vFAIL("Regexp *+ operand could be empty");
 #endif 
 
-    nextchar();
+    nextchar(pRExC_state);
 
     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
 
     if (op == '*' && (flags&SIMPLE)) {
-       reginsert(STAR, ret);
+       reginsert(pRExC_state, STAR, ret);
        ret->flags = 0;
-       PL_regnaughty += 4;
+       RExC_naughty += 4;
     }
     else if (op == '*') {
        min = 0;
        goto do_curly;
     }
     else if (op == '+' && (flags&SIMPLE)) {
-       reginsert(PLUS, ret);
+       reginsert(pRExC_state, PLUS, ret);
        ret->flags = 0;
-       PL_regnaughty += 3;
+       RExC_naughty += 3;
     }
     else if (op == '+') {
        min = 1;
@@ -2421,19 +2497,19 @@ S_regpiece(pTHX_ I32 *flagp)
     }
   nest_check:
     if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
-       vWARN3(PL_regcomp_parse,
+       vWARN3(RExC_parse,
               "%.*s matches null string many times",
-              PL_regcomp_parse - origparse,
+              RExC_parse - origparse,
               origparse);
     }
 
-    if (*PL_regcomp_parse == '?') {
-       nextchar();
-       reginsert(MINMOD, ret);
-       regtail(ret, ret + NODE_STEP_REGNODE);
+    if (*RExC_parse == '?') {
+       nextchar(pRExC_state);
+       reginsert(pRExC_state, MINMOD, ret);
+       regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
     }
-    if (ISMULT2(PL_regcomp_parse)) {
-       PL_regcomp_parse++;
+    if (ISMULT2(RExC_parse)) {
+       RExC_parse++;
        vFAIL("Nested quantifiers");
     }
 
@@ -2450,73 +2526,63 @@ S_regpiece(pTHX_ I32 *flagp)
  *
  * [Yes, it is worth fixing, some scripts can run twice the speed.] */
 STATIC regnode *
-S_regatom(pTHX_ I32 *flagp)
+S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
 {
-    dTHR;
     register regnode *ret = 0;
     I32 flags;
 
     *flagp = WORST;            /* Tentatively. */
 
 tryagain:
-    switch (*PL_regcomp_parse) {
+    switch (*RExC_parse) {
     case '^':
-       PL_seen_zerolen++;
-       nextchar();
-       if (PL_regflags & PMf_MULTILINE)
-           ret = reg_node(MBOL);
-       else if (PL_regflags & PMf_SINGLELINE)
-           ret = reg_node(SBOL);
+       RExC_seen_zerolen++;
+       nextchar(pRExC_state);
+       if (RExC_flags16 & PMf_MULTILINE)
+           ret = reg_node(pRExC_state, MBOL);
+       else if (RExC_flags16 & PMf_SINGLELINE)
+           ret = reg_node(pRExC_state, SBOL);
        else
-           ret = reg_node(BOL);
+           ret = reg_node(pRExC_state, BOL);
        break;
     case '$':
-       nextchar();
-       if (*PL_regcomp_parse) 
-           PL_seen_zerolen++;
-       if (PL_regflags & PMf_MULTILINE)
-           ret = reg_node(MEOL);
-       else if (PL_regflags & PMf_SINGLELINE)
-           ret = reg_node(SEOL);
+       nextchar(pRExC_state);
+       if (*RExC_parse) 
+           RExC_seen_zerolen++;
+       if (RExC_flags16 & PMf_MULTILINE)
+           ret = reg_node(pRExC_state, MEOL);
+       else if (RExC_flags16 & PMf_SINGLELINE)
+           ret = reg_node(pRExC_state, SEOL);
        else
-           ret = reg_node(EOL);
+           ret = reg_node(pRExC_state, EOL);
        break;
     case '.':
-       nextchar();
-       if (UTF) {
-           if (PL_regflags & PMf_SINGLELINE)
-               ret = reg_node(SANYUTF8);
-           else
-               ret = reg_node(ANYUTF8);
-           *flagp |= HASWIDTH;
-       }
-       else {
-           if (PL_regflags & PMf_SINGLELINE)
-               ret = reg_node(SANY);
-           else
-               ret = reg_node(REG_ANY);
-           *flagp |= HASWIDTH|SIMPLE;
-       }
-       PL_regnaughty++;
+       nextchar(pRExC_state);
+       if (RExC_flags16 & PMf_SINGLELINE)
+           ret = reg_node(pRExC_state, SANY);
+       else
+           ret = reg_node(pRExC_state, REG_ANY);
+       *flagp |= HASWIDTH|SIMPLE;
+       RExC_naughty++;
        break;
     case '[':
     {
-       char *oregcomp_parse = ++PL_regcomp_parse;
-       ret = (UTF ? regclassutf8() : regclass());
-       if (*PL_regcomp_parse != ']') {
-           PL_regcomp_parse = oregcomp_parse;
+       char *oregcomp_parse = ++RExC_parse;
+       ret = regclass(pRExC_state);
+       if (*RExC_parse != ']') {
+           RExC_parse = oregcomp_parse;
            vFAIL("Unmatched [");
        }
-       nextchar();
+       nextchar(pRExC_state);
        *flagp |= HASWIDTH|SIMPLE;
        break;
     }
     case '(':
-       nextchar();
-       ret = reg(1, &flags);
+       nextchar(pRExC_state);
+       ret = reg(pRExC_state, 1, &flags);
        if (ret == NULL) {
                if (flags & TRYAGAIN) {
-                   if (PL_regcomp_parse == PL_regxend) {
+                   if (RExC_parse == RExC_end) {
                         /* Make parent create an empty node if needed. */
                        *flagp |= TRYAGAIN;
                        return(NULL);
@@ -2537,155 +2603,137 @@ tryagain:
                                /* Supposed to be caught earlier. */
        break;
     case '{':
-       if (!regcurly(PL_regcomp_parse)) {
-           PL_regcomp_parse++;
+       if (!regcurly(RExC_parse)) {
+           RExC_parse++;
            goto defchar;
        }
        /* FALL THROUGH */
     case '?':
     case '+':
     case '*':
-       PL_regcomp_parse++;
+       RExC_parse++;
        vFAIL("Quantifier follows nothing");
        break;
     case '\\':
-       switch (*++PL_regcomp_parse) {
+       switch (*++RExC_parse) {
        case 'A':
-           PL_seen_zerolen++;
-           ret = reg_node(SBOL);
+           RExC_seen_zerolen++;
+           ret = reg_node(pRExC_state, SBOL);
            *flagp |= SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            break;
        case 'G':
-           ret = reg_node(GPOS);
-           PL_regseen |= REG_SEEN_GPOS;
+           ret = reg_node(pRExC_state, GPOS);
+           RExC_seen |= REG_SEEN_GPOS;
            *flagp |= SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            break;
        case 'Z':
-           ret = reg_node(SEOL);
+           ret = reg_node(pRExC_state, SEOL);
            *flagp |= SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            break;
        case 'z':
-           ret = reg_node(EOS);
+           ret = reg_node(pRExC_state, EOS);
            *flagp |= SIMPLE;
-           PL_seen_zerolen++;          /* Do not optimize RE away */
-           nextchar();
+           RExC_seen_zerolen++;                /* Do not optimize RE away */
+           nextchar(pRExC_state);
            break;
        case 'C':
-           ret = reg_node(SANY);
+           ret = reg_node(pRExC_state, SANY);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            break;
        case 'X':
-           ret = reg_node(CLUMP);
+           ret = reg_node(pRExC_state, CLUMP);
            *flagp |= HASWIDTH;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_mark)
                is_utf8_mark((U8*)"~");         /* preload table */
            break;
        case 'w':
-           ret = reg_node(
-               UTF
-                   ? (LOC ? ALNUMLUTF8 : ALNUMUTF8)
-                   : (LOC ? ALNUML     : ALNUM));
+           ret = reg_node(pRExC_state, LOC ? ALNUML     : ALNUM);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_alnum)
                is_utf8_alnum((U8*)"a");        /* preload table */
            break;
        case 'W':
-           ret = reg_node(
-               UTF
-                   ? (LOC ? NALNUMLUTF8 : NALNUMUTF8)
-                   : (LOC ? NALNUML     : NALNUM));
+           ret = reg_node(pRExC_state, LOC ? NALNUML     : NALNUM);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_alnum)
                is_utf8_alnum((U8*)"a");        /* preload table */
            break;
        case 'b':
-           PL_seen_zerolen++;
-           PL_regseen |= REG_SEEN_LOOKBEHIND;
-           ret = reg_node(
-               UTF
-                   ? (LOC ? BOUNDLUTF8 : BOUNDUTF8)
-                   : (LOC ? BOUNDL     : BOUND));
+           RExC_seen_zerolen++;
+           RExC_seen |= REG_SEEN_LOOKBEHIND;
+           ret = reg_node(pRExC_state, LOC ? BOUNDL     : BOUND);
            *flagp |= SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_alnum)
                is_utf8_alnum((U8*)"a");        /* preload table */
            break;
        case 'B':
-           PL_seen_zerolen++;
-           PL_regseen |= REG_SEEN_LOOKBEHIND;
-           ret = reg_node(
-               UTF
-                   ? (LOC ? NBOUNDLUTF8 : NBOUNDUTF8)
-                   : (LOC ? NBOUNDL     : NBOUND));
+           RExC_seen_zerolen++;
+           RExC_seen |= REG_SEEN_LOOKBEHIND;
+           ret = reg_node(pRExC_state, LOC ? NBOUNDL     : NBOUND);
            *flagp |= SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_alnum)
                is_utf8_alnum((U8*)"a");        /* preload table */
            break;
        case 's':
-           ret = reg_node(
-               UTF
-                   ? (LOC ? SPACELUTF8 : SPACEUTF8)
-                   : (LOC ? SPACEL     : SPACE));
+           ret = reg_node(pRExC_state, LOC ? SPACEL     : SPACE);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_space)
                is_utf8_space((U8*)" ");        /* preload table */
            break;
        case 'S':
-           ret = reg_node(
-               UTF
-                   ? (LOC ? NSPACELUTF8 : NSPACEUTF8)
-                   : (LOC ? NSPACEL     : NSPACE));
+           ret = reg_node(pRExC_state, LOC ? NSPACEL     : NSPACE);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_space)
                is_utf8_space((U8*)" ");        /* preload table */
            break;
        case 'd':
-           ret = reg_node(UTF ? DIGITUTF8 : DIGIT);
+           ret = reg_node(pRExC_state, DIGIT);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_digit)
                is_utf8_digit((U8*)"1");        /* preload table */
            break;
        case 'D':
-           ret = reg_node(UTF ? NDIGITUTF8 : NDIGIT);
+           ret = reg_node(pRExC_state, NDIGIT);
            *flagp |= HASWIDTH|SIMPLE;
-           nextchar();
+           nextchar(pRExC_state);
            if (UTF && !PL_utf8_digit)
                is_utf8_digit((U8*)"1");        /* preload table */
            break;
        case 'p':
        case 'P':
            {   /* a lovely hack--pretend we saw [\pX] instead */
-               char* oldregxend = PL_regxend;
+               char* oldregxend = RExC_end;
 
-               if (PL_regcomp_parse[1] == '{') {
-                   PL_regxend = strchr(PL_regcomp_parse, '}');
-                   if (!PL_regxend) {
-                       PL_regcomp_parse += 2;
-                       PL_regxend = oldregxend;
+               if (RExC_parse[1] == '{') {
+                   RExC_end = strchr(RExC_parse, '}');
+                   if (!RExC_end) {
+                       RExC_parse += 2;
+                       RExC_end = oldregxend;
                        vFAIL("Missing right brace on \\p{}");
                    }
-                   PL_regxend++;
+                   RExC_end++;
                }
                else
-                   PL_regxend = PL_regcomp_parse + 2;
-               PL_regcomp_parse--;
+                   RExC_end = RExC_parse + 2;
+               RExC_parse--;
 
-               ret = regclassutf8();
+               ret = regclass(pRExC_state);
 
-               PL_regxend = oldregxend;
-               PL_regcomp_parse--;
-               nextchar();
+               RExC_end = oldregxend;
+               RExC_parse--;
+               nextchar(pRExC_state);
                *flagp |= HASWIDTH|SIMPLE;
            }
            break;
@@ -2702,28 +2750,28 @@ tryagain:
        case '1': case '2': case '3': case '4':
        case '5': case '6': case '7': case '8': case '9':
            {
-               I32 num = atoi(PL_regcomp_parse);
+               I32 num = atoi(RExC_parse);
 
-               if (num > 9 && num >= PL_regnpar)
+               if (num > 9 && num >= RExC_npar)
                    goto defchar;
                else {
-                   while (isDIGIT(*PL_regcomp_parse))
-                       PL_regcomp_parse++;
+                   while (isDIGIT(*RExC_parse))
+                       RExC_parse++;
 
-                   if (!SIZE_ONLY && num > PL_regcomp_rx->nparens)
+                   if (!SIZE_ONLY && num > RExC_rx->nparens)
                        vFAIL("Reference to nonexistent group");
-                   PL_regsawback = 1;
-                   ret = reganode(FOLD
+                   RExC_sawback = 1;
+                   ret = reganode(pRExC_state, FOLD
                                   ? (LOC ? REFFL : REFF)
                                   : REF, num);
                    *flagp |= HASWIDTH;
-                   PL_regcomp_parse--;
-                   nextchar();
+                   RExC_parse--;
+                   nextchar(pRExC_state);
                }
            }
            break;
        case '\0':
-           if (PL_regcomp_parse >= PL_regxend)
+           if (RExC_parse >= RExC_end)
                FAIL("Trailing \\");
            /* FALL THROUGH */
        default:
@@ -2734,35 +2782,35 @@ tryagain:
        break;
 
     case '#':
-       if (PL_regflags & PMf_EXTENDED) {
-           while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '\n') PL_regcomp_parse++;
-           if (PL_regcomp_parse < PL_regxend)
+       if (RExC_flags16 & PMf_EXTENDED) {
+           while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
+           if (RExC_parse < RExC_end)
                goto tryagain;
        }
        /* FALL THROUGH */
 
     default: {
-           register I32 len;
+           register STRLEN len;
            register UV ender;
            register char *p;
            char *oldp, *s;
-           I32 numlen;
+           STRLEN numlen;
 
-           PL_regcomp_parse++;
+           RExC_parse++;
 
        defchar:
-           ret = reg_node(FOLD
+           ret = reg_node(pRExC_state, FOLD
                          ? (LOC ? EXACTFL : EXACTF)
                          : EXACT);
            s = STRING(ret);
-           for (len = 0, p = PL_regcomp_parse - 1;
-             len < 127 && p < PL_regxend;
+           for (len = 0, p = RExC_parse - 1;
+             len < 127 && p < RExC_end;
              len++)
            {
                oldp = p;
 
-               if (PL_regflags & PMf_EXTENDED)
-                   p = regwhite(p, PL_regxend);
+               if (RExC_flags16 & PMf_EXTENDED)
+                   p = regwhite(p, RExC_end);
                switch (*p) {
                case '^':
                case '$':
@@ -2827,10 +2875,10 @@ tryagain:
                            char* e = strchr(p, '}');
         
                            if (!e) {
-                               PL_regcomp_parse = p + 1;
+                               RExC_parse = p + 1;
                                vFAIL("Missing right brace on \\x{}");
                            }
-                           else if (UTF) {
+                           else {
                                numlen = 1;     /* allow underscores */
                                ender = (UV)scan_hex(p + 1, e - p - 1, &numlen);
                                /* numlen is generous */
@@ -2840,12 +2888,6 @@ tryagain:
                                }
                                p = e + 1;
                            }
-                           else
-                           {
-                               PL_regcomp_parse = e + 1;
-                               vFAIL("Can't use \\x{} without 'use utf8' declaration");
-                           }
-
                        }
                        else {
                            numlen = 0;         /* disallow underscores */
@@ -2861,7 +2903,7 @@ tryagain:
                    case '0': case '1': case '2': case '3':case '4':
                    case '5': case '6': case '7': case '8':case '9':
                        if (*p == '0' ||
-                         (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) {
+                         (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
                            numlen = 0;         /* disallow underscores */
                            ender = (UV)scan_oct(p, 3, &numlen);
                            p += numlen;
@@ -2872,7 +2914,7 @@ tryagain:
                        }
                        break;
                    case '\0':
-                       if (p >= PL_regxend)
+                       if (p >= RExC_end)
                            FAIL("Trailing \\");
                        /* FALL THROUGH */
                    default:
@@ -2883,16 +2925,17 @@ tryagain:
                    break;
                default:
                  normal_default:
-                   if ((*p & 0xc0) == 0xc0 && UTF) {
-                       ender = utf8_to_uv_chk((U8*)p, &numlen, 0);
+                   if (UTF8_IS_START(*p) && UTF) {
+                       ender = utf8_to_uv((U8*)p, RExC_end - p,
+                                              &numlen, 0);
                        p += numlen;
                    }
                    else
                        ender = *p++;
                    break;
                }
-               if (PL_regflags & PMf_EXTENDED)
-                   p = regwhite(p, PL_regxend);
+               if (RExC_flags16 & PMf_EXTENDED)
+                   p = regwhite(p, RExC_end);
                if (UTF && FOLD) {
                    if (LOC)
                        ender = toLOWER_LC_uni(ender);
@@ -2902,8 +2945,10 @@ tryagain:
                if (ISMULT2(p)) { /* Back off on ?+*. */
                    if (len)
                        p = oldp;
+                   /* ender is a Unicode value so it can be > 0xff --
+                    * in other words, do not use UTF8_IS_CONTINUED(). */
                    else if (ender >= 0x80 && UTF) {
-                       reguni(ender, s, &numlen);
+                       reguni(pRExC_state, ender, s, &numlen);
                        s += numlen;
                        len += numlen;
                    }
@@ -2913,8 +2958,10 @@ tryagain:
                    }
                    break;
                }
+               /* ender is a Unicode value so it can be > 0xff --
+                * in other words, do not use UTF8_IS_CONTINUED(). */
                if (ender >= 0x80 && UTF) {
-                   reguni(ender, s, &numlen);
+                   reguni(pRExC_state, ender, s, &numlen);
                    s += numlen;
                    len += numlen - 1;
                }
@@ -2922,10 +2969,14 @@ tryagain:
                    REGC(ender, s++);
            }
        loopdone:
-           PL_regcomp_parse = p - 1;
-           nextchar();
-           if (len < 0)
-               vFAIL("Internal disaster");
+           RExC_parse = p - 1;
+           nextchar(pRExC_state);
+           {
+               /* len is STRLEN which is unsigned, need to copy to signed */
+               IV iv = len;
+               if (iv < 0)
+                   vFAIL("Internal disaster");
+           }
            if (len > 0)
                *flagp |= HASWIDTH;
            if (len == 1)
@@ -2933,9 +2984,9 @@ tryagain:
            if (!SIZE_ONLY)
                STR_LEN(ret) = len;
            if (SIZE_ONLY)
-               PL_regsize += STR_SZ(len);
+               RExC_size += STR_SZ(len);
            else
-               PL_regcode += STR_SZ(len);
+               RExC_emit += STR_SZ(len);
        }
        break;
     }
@@ -2966,30 +3017,29 @@ S_regwhite(pTHX_ char *p, char *e)
    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
    but trigger warnings because they are currently unimplemented. */
 STATIC I32
-S_regpposixcc(pTHX_ I32 value)
+S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
 {
-    dTHR;
     char *posixcc = 0;
     I32 namedclass = OOB_NAMEDCLASS;
 
-    if (value == '[' && PL_regcomp_parse + 1 < PL_regxend &&
+    if (value == '[' && RExC_parse + 1 < RExC_end &&
        /* I smell either [: or [= or [. -- POSIX has been here, right? */
-       (*PL_regcomp_parse == ':' ||
-        *PL_regcomp_parse == '=' ||
-        *PL_regcomp_parse == '.')) {
-       char  c = *PL_regcomp_parse;
-       char* s = PL_regcomp_parse++;
+       (*RExC_parse == ':' ||
+        *RExC_parse == '=' ||
+        *RExC_parse == '.')) {
+       char  c = *RExC_parse;
+       char* s = RExC_parse++;
            
-       while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != c)
-           PL_regcomp_parse++;
-       if (PL_regcomp_parse == PL_regxend)
+       while (RExC_parse < RExC_end && *RExC_parse != c)
+           RExC_parse++;
+       if (RExC_parse == RExC_end)
            /* Grandfather lone [:, [=, [. */
-           PL_regcomp_parse = s;
+           RExC_parse = s;
        else {
-           char* t = PL_regcomp_parse++; /* skip over the c */
+           char* t = RExC_parse++; /* skip over the c */
 
-           if (*PL_regcomp_parse == ']') {
-               PL_regcomp_parse++; /* skip over the ending ] */
+           if (*RExC_parse == ']') {
+               RExC_parse++; /* skip over the ending ] */
                posixcc = s + 1;
                if (*s == ':') {
                    I32 complement = *posixcc == '^' ? *posixcc++ : 0;
@@ -3075,16 +3125,16 @@ S_regpposixcc(pTHX_ I32 value)
                } else if (!SIZE_ONLY) {
                    /* [[=foo=]] and [[.foo.]] are still future. */
 
-                   /* adjust PL_regcomp_parse so the warning shows after
+                   /* adjust RExC_parse so the warning shows after
                       the class closes */
-                   while (*PL_regcomp_parse && *PL_regcomp_parse != ']')
-                       PL_regcomp_parse++;
+                   while (*RExC_parse && *RExC_parse != ']')
+                       RExC_parse++;
                    Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
                }
            } else {
                /* Maternal grandfather:
                 * "[:" ending in ":" but not in ":]" */
-               PL_regcomp_parse = s;
+               RExC_parse = s;
            }
        }
     }
@@ -3093,13 +3143,13 @@ S_regpposixcc(pTHX_ I32 value)
 }
 
 STATIC void
-S_checkposixcc(pTHX)
+S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
 {
     if (!SIZE_ONLY && ckWARN(WARN_REGEXP) &&
-       (*PL_regcomp_parse == ':' ||
-        *PL_regcomp_parse == '=' ||
-        *PL_regcomp_parse == '.')) {
-       char *s = PL_regcomp_parse;
+       (*RExC_parse == ':' ||
+        *RExC_parse == '=' ||
+        *RExC_parse == '.')) {
+       char *s = RExC_parse;
        char  c = *s++;
 
        while(*s && isALNUM(*s))
@@ -3110,9 +3160,9 @@ S_checkposixcc(pTHX)
            /* [[=foo=]] and [[.foo.]] are still future. */
            if (c == '=' || c == '.')
            {
-               /* adjust PL_regcomp_parse so the error shows after
+               /* adjust RExC_parse so the error shows after
                   the class closes */
-               while (*PL_regcomp_parse && *PL_regcomp_parse++ != ']')
+               while (*RExC_parse && *RExC_parse++ != ']')
                    ;
                Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
            }
@@ -3121,61 +3171,113 @@ S_checkposixcc(pTHX)
 }
 
 STATIC regnode *
-S_regclass(pTHX)
+S_regclass(pTHX_ RExC_state_t *pRExC_state)
 {
-    dTHR;
-    register U32 value;
-    register I32 lastvalue = OOB_CHAR8;
-    register I32 range = 0;
+    register UV value;
+    register IV lastvalue = OOB_UNICODE;
+    register IV range = 0;
     register regnode *ret;
-    I32 numlen;
-    I32 namedclass;
+    STRLEN numlen;
+    IV namedclass;
     char *rangebegin;
     bool need_class = 0;
+    SV *listsv;
+    register char *e;
+    UV n;
+    bool dont_optimize_invert = FALSE;
+
+    ret = reganode(pRExC_state, ANYOF, 0);
+
+    if (!SIZE_ONLY)
+       ANYOF_FLAGS(ret) = 0;
+
+    if (*RExC_parse == '^') {  /* Complement of range. */
+       RExC_naughty++;
+       RExC_parse++;
+       if (!SIZE_ONLY)
+           ANYOF_FLAGS(ret) |= ANYOF_INVERT;
+    }
 
-    ret = reg_node(ANYOF);
     if (SIZE_ONLY)
-       PL_regsize += ANYOF_SKIP;
+       RExC_size += ANYOF_SKIP;
     else {
-       ret->flags = 0;
-       ANYOF_BITMAP_ZERO(ret);
-       PL_regcode += ANYOF_SKIP;
+       RExC_emit += ANYOF_SKIP;
        if (FOLD)
            ANYOF_FLAGS(ret) |= ANYOF_FOLD;
        if (LOC)
            ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
-    }
-    if (*PL_regcomp_parse == '^') {    /* Complement of range. */
-       PL_regnaughty++;
-       PL_regcomp_parse++;
-       if (!SIZE_ONLY)
-           ANYOF_FLAGS(ret) |= ANYOF_INVERT;
+       ANYOF_BITMAP_ZERO(ret);
+       listsv = newSVpvn("# comment\n", 10);
     }
 
     if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
-       checkposixcc();
+       checkposixcc(pRExC_state);
+
+    if (*RExC_parse == ']' || *RExC_parse == '-')
+       goto charclassloop;             /* allow 1st char to be ] or - */
+
+    while (RExC_parse < RExC_end && *RExC_parse != ']') {
+
+    charclassloop:
+
+       namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
 
-    if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
-       goto skipcond;          /* allow 1st char to be ] or - */
-    while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
-       skipcond:
-       namedclass = OOB_NAMEDCLASS;
        if (!range)
-           rangebegin = PL_regcomp_parse;
-       value = UCHARAT(PL_regcomp_parse++);
+           rangebegin = RExC_parse;
+       if (UTF) {
+           value = utf8_to_uv((U8*)RExC_parse,
+                              RExC_end - RExC_parse,
+                              &numlen, 0);
+           RExC_parse += numlen;
+       }
+       else
+           value = UCHARAT(RExC_parse++);
        if (value == '[')
-           namedclass = regpposixcc(value);
+           namedclass = regpposixcc(pRExC_state, value);
        else if (value == '\\') {
-           value = UCHARAT(PL_regcomp_parse++);
+           if (UTF) {
+               value = utf8_to_uv((U8*)RExC_parse,
+                                  RExC_end - RExC_parse,
+                                  &numlen, 0);
+               RExC_parse += numlen;
+           }
+           else
+               value = UCHARAT(RExC_parse++);
            /* Some compilers cannot handle switching on 64-bit integer
-            * values, therefore the 'value' cannot be an UV. --jhi */
-           switch (value) {
+            * values, therefore value cannot be an UV.  Yes, this will
+            * be a problem later if we want switch on Unicode.
+            * A similar issue a little bit later when switching on
+            * namedclass. --jhi */
+           switch ((I32)value) {
            case 'w':   namedclass = ANYOF_ALNUM;       break;
            case 'W':   namedclass = ANYOF_NALNUM;      break;
            case 's':   namedclass = ANYOF_SPACE;       break;
            case 'S':   namedclass = ANYOF_NSPACE;      break;
            case 'd':   namedclass = ANYOF_DIGIT;       break;
            case 'D':   namedclass = ANYOF_NDIGIT;      break;
+           case 'p':
+           case 'P':
+               if (*RExC_parse == '{') {
+                   e = strchr(RExC_parse++, '}');
+                    if (!e)
+                        vFAIL("Missing right brace on \\p{}");
+                   n = e - RExC_parse;
+               }
+               else {
+                   e = RExC_parse;
+                   n = 1;
+               }
+               if (!SIZE_ONLY) {
+                   if (value == 'p')
+                       Perl_sv_catpvf(aTHX_ listsv,
+                                      "+utf8::%.*s\n", (int)n, RExC_parse);
+                   else
+                       Perl_sv_catpvf(aTHX_ listsv,
+                                      "!utf8::%.*s\n", (int)n, RExC_parse);
+               }
+               RExC_parse = e + 1;
+               ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
+               continue;
            case 'n':   value = '\n';                   break;
            case 'r':   value = '\r';                   break;
            case 't':   value = '\t';                   break;
@@ -3189,46 +3291,78 @@ S_regclass(pTHX)
            case 'a':   value = '\057';                 break;
 #endif
            case 'x':
-               numlen = 0;             /* disallow underscores */
-               value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen);
-               PL_regcomp_parse += numlen;
+               if (*RExC_parse == '{') {
+                   e = strchr(RExC_parse++, '}');
+                    if (!e) 
+                        vFAIL("Missing right brace on \\x{}");
+                   numlen = 1;         /* allow underscores */
+                   value = (UV)scan_hex(RExC_parse,
+                                        e - RExC_parse,
+                                        &numlen);
+                   RExC_parse = e + 1;
+               }
+               else {
+                   numlen = 0;         /* disallow underscores */
+                   value = (UV)scan_hex(RExC_parse, 2, &numlen);
+                   RExC_parse += numlen;
+               }
                break;
            case 'c':
-               value = UCHARAT(PL_regcomp_parse++);
+               value = UCHARAT(RExC_parse++);
                value = toCTRL(value);
                break;
            case '0': case '1': case '2': case '3': case '4':
            case '5': case '6': case '7': case '8': case '9':
                numlen = 0;             /* disallow underscores */
-               value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen);
-               PL_regcomp_parse += numlen;
+               value = (UV)scan_oct(--RExC_parse, 3, &numlen);
+               RExC_parse += numlen;
                break;
            default:
                if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
-
-                   vWARN2(PL_regcomp_parse, "Unrecognized escape \\%c in character class passed through", (int)value);
+                   vWARN2(RExC_parse,
+                          "Unrecognized escape \\%c in character class passed through",
+                          (int)value);
                break;
            }
-       }
-       if (namedclass > OOB_NAMEDCLASS) {
-           if (!need_class && !SIZE_ONLY)
+       } /* end of \blah */
+
+       if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
+
+           if (!SIZE_ONLY && !need_class)
                ANYOF_CLASS_ZERO(ret);
+
            need_class = 1;
-           if (range) { /* a-\d, a-[:digit:] */
+
+           /* a bad range like a-\d, a-[:digit:] ? */
+           if (range) {
                if (!SIZE_ONLY) {
                    if (ckWARN(WARN_REGEXP))
-                       vWARN4(PL_regcomp_parse,
+                       vWARN4(RExC_parse,
                               "False [] range \"%*.*s\"",
-                              PL_regcomp_parse - rangebegin,
-                              PL_regcomp_parse - rangebegin,
+                              RExC_parse - rangebegin,
+                              RExC_parse - rangebegin,
                               rangebegin);
-                   ANYOF_BITMAP_SET(ret, lastvalue);
-                   ANYOF_BITMAP_SET(ret, '-');
+                   if (lastvalue < 256) {
+                       ANYOF_BITMAP_SET(ret, lastvalue);
+                       ANYOF_BITMAP_SET(ret, '-');
+                   }
+                   else {
+                       ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
+                       Perl_sv_catpvf(aTHX_ listsv,
+                                      /* 0x002D is Unicode for '-' */
+                                      "%04"UVxf"\n002D\n", (UV)lastvalue);
+                   }
                }
-               range = 0; /* this is not a true range */
+
+               range = 0; /* this was not a true range */
            }
+
            if (!SIZE_ONLY) {
-               switch (namedclass) {
+               /* Possible truncation here but in some 64-bit environments
+                * the compiler gets heartburn about switch on 64-bit values.
+                * A similar issue a little earlier when switching on value.
+                * --jhi */
+               switch ((I32)namedclass) {
                case ANYOF_ALNUM:
                    if (LOC)
                        ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
@@ -3237,6 +3371,8 @@ S_regclass(pTHX)
                            if (isALNUM(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");    
                    break;
                case ANYOF_NALNUM:
                    if (LOC)
@@ -3246,42 +3382,19 @@ S_regclass(pTHX)
                            if (!isALNUM(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
                    break;
-               case ANYOF_SPACE:
-                   if (LOC)
-                       ANYOF_CLASS_SET(ret, ANYOF_SPACE);
-                   else {
-                       for (value = 0; value < 256; value++)
-                           if (isSPACE(value))
-                               ANYOF_BITMAP_SET(ret, value);
-                   }
-                   break;
-               case ANYOF_NSPACE:
+               case ANYOF_ALNUMC:
                    if (LOC)
-                       ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
+                       ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
                    else {
                        for (value = 0; value < 256; value++)
-                           if (!isSPACE(value))
+                           if (isALNUMC(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
-                   break;
-               case ANYOF_DIGIT:
-                   if (LOC)
-                       ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
-                   else {
-                       for (value = '0'; value <= '9'; value++)
-                           ANYOF_BITMAP_SET(ret, value);
-                   }
-                   break;
-               case ANYOF_NDIGIT:
-                   if (LOC)
-                       ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
-                   else {
-                       for (value = 0; value < '0'; value++)
-                           ANYOF_BITMAP_SET(ret, value);
-                       for (value = '9' + 1; value < 256; value++)
-                           ANYOF_BITMAP_SET(ret, value);
-                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
                    break;
                case ANYOF_NALNUMC:
                    if (LOC)
@@ -3291,15 +3404,8 @@ S_regclass(pTHX)
                            if (!isALNUMC(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
-                   break;
-               case ANYOF_ALNUMC:
-                   if (LOC)
-                       ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
-                   else {
-                       for (value = 0; value < 256; value++)
-                           if (isALNUMC(value))
-                               ANYOF_BITMAP_SET(ret, value);
-                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
                    break;
                case ANYOF_ALPHA:
                    if (LOC)
@@ -3309,6 +3415,8 @@ S_regclass(pTHX)
                            if (isALPHA(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
                    break;
                case ANYOF_NALPHA:
                    if (LOC)
@@ -3318,6 +3426,8 @@ S_regclass(pTHX)
                            if (!isALPHA(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
                    break;
                case ANYOF_ASCII:
                    if (LOC)
@@ -3332,6 +3442,8 @@ S_regclass(pTHX)
                                ANYOF_BITMAP_SET(ret, value);
 #endif /* EBCDIC */
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
                    break;
                case ANYOF_NASCII:
                    if (LOC)
@@ -3346,6 +3458,8 @@ S_regclass(pTHX)
                                ANYOF_BITMAP_SET(ret, value);
 #endif /* EBCDIC */
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
                    break;
                case ANYOF_BLANK:
                    if (LOC)
@@ -3355,6 +3469,8 @@ S_regclass(pTHX)
                            if (isBLANK(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
                    break;
                case ANYOF_NBLANK:
                    if (LOC)
@@ -3364,6 +3480,8 @@ S_regclass(pTHX)
                            if (!isBLANK(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
                    break;
                case ANYOF_CNTRL:
                    if (LOC)
@@ -3373,7 +3491,8 @@ S_regclass(pTHX)
                            if (isCNTRL(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
-                   lastvalue = OOB_CHAR8;
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
                    break;
                case ANYOF_NCNTRL:
                    if (LOC)
@@ -3383,6 +3502,32 @@ S_regclass(pTHX)
                            if (!isCNTRL(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
+                   break;
+               case ANYOF_DIGIT:
+                   if (LOC)
+                       ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
+                   else {
+                       /* consecutive digits assumed */
+                       for (value = '0'; value <= '9'; value++)
+                           ANYOF_BITMAP_SET(ret, value);
+                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
+                   break;
+               case ANYOF_NDIGIT:
+                   if (LOC)
+                       ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
+                   else {
+                       /* consecutive digits assumed */
+                       for (value = 0; value < '0'; value++)
+                           ANYOF_BITMAP_SET(ret, value);
+                       for (value = '9' + 1; value < 256; value++)
+                           ANYOF_BITMAP_SET(ret, value);
+                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
                    break;
                case ANYOF_GRAPH:
                    if (LOC)
@@ -3392,6 +3537,8 @@ S_regclass(pTHX)
                            if (isGRAPH(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
                    break;
                case ANYOF_NGRAPH:
                    if (LOC)
@@ -3401,6 +3548,8 @@ S_regclass(pTHX)
                            if (!isGRAPH(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
                    break;
                case ANYOF_LOWER:
                    if (LOC)
@@ -3410,6 +3559,8 @@ S_regclass(pTHX)
                            if (isLOWER(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
                    break;
                case ANYOF_NLOWER:
                    if (LOC)
@@ -3419,6 +3570,8 @@ S_regclass(pTHX)
                            if (!isLOWER(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
                    break;
                case ANYOF_PRINT:
                    if (LOC)
@@ -3428,6 +3581,8 @@ S_regclass(pTHX)
                            if (isPRINT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
                    break;
                case ANYOF_NPRINT:
                    if (LOC)
@@ -3437,6 +3592,8 @@ S_regclass(pTHX)
                            if (!isPRINT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
                    break;
                case ANYOF_PSXSPC:
                    if (LOC)
@@ -3446,6 +3603,8 @@ S_regclass(pTHX)
                            if (isPSXSPC(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
                    break;
                case ANYOF_NPSXSPC:
                    if (LOC)
@@ -3455,6 +3614,8 @@ S_regclass(pTHX)
                            if (!isPSXSPC(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
                    break;
                case ANYOF_PUNCT:
                    if (LOC)
@@ -3464,6 +3625,8 @@ S_regclass(pTHX)
                            if (isPUNCT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
                    break;
                case ANYOF_NPUNCT:
                    if (LOC)
@@ -3473,6 +3636,30 @@ S_regclass(pTHX)
                            if (!isPUNCT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
+                   break;
+               case ANYOF_SPACE:
+                   if (LOC)
+                       ANYOF_CLASS_SET(ret, ANYOF_SPACE);
+                   else {
+                       for (value = 0; value < 256; value++)
+                           if (isSPACE(value))
+                               ANYOF_BITMAP_SET(ret, value);
+                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
+                   break;
+               case ANYOF_NSPACE:
+                   if (LOC)
+                       ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
+                   else {
+                       for (value = 0; value < 256; value++)
+                           if (!isSPACE(value))
+                               ANYOF_BITMAP_SET(ret, value);
+                   }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
                    break;
                case ANYOF_UPPER:
                    if (LOC)
@@ -3482,6 +3669,8 @@ S_regclass(pTHX)
                            if (isUPPER(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
                    break;
                case ANYOF_NUPPER:
                    if (LOC)
@@ -3491,6 +3680,8 @@ S_regclass(pTHX)
                            if (!isUPPER(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
                    break;
                case ANYOF_XDIGIT:
                    if (LOC)
@@ -3500,6 +3691,8 @@ S_regclass(pTHX)
                            if (isXDIGIT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
                    break;
                case ANYOF_NXDIGIT:
                    if (LOC)
@@ -3509,6 +3702,8 @@ S_regclass(pTHX)
                            if (!isXDIGIT(value))
                                ANYOF_BITMAP_SET(ret, value);
                    }
+                   dont_optimize_invert = TRUE;
+                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
                    break;
                default:
                    vFAIL("Invalid [::] class");
@@ -3518,364 +3713,144 @@ S_regclass(pTHX)
                    ANYOF_FLAGS(ret) |= ANYOF_CLASS;
                continue;
            }
-       }
+       } /* end of namedclass \blah */
+
        if (range) {
            if (lastvalue > value) /* b-a */ {
                Simple_vFAIL4("Invalid [] range \"%*.*s\"",
-                             PL_regcomp_parse - rangebegin,
-                             PL_regcomp_parse - rangebegin,
+                             RExC_parse - rangebegin,
+                             RExC_parse - rangebegin,
                              rangebegin);
            }
-           range = 0;
+           range = 0; /* not a true range */
        }
        else {
-           lastvalue = value;
-           if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
-               PL_regcomp_parse[1] != ']') {
-               PL_regcomp_parse++;
-               if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
+           lastvalue = value; /* save the beginning of the range */
+           if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
+               RExC_parse[1] != ']') {
+               RExC_parse++;
+
+               /* a bad range like \w-, [:word:]- ? */
+               if (namedclass > OOB_NAMEDCLASS) {
                    if (ckWARN(WARN_REGEXP))
-                       vWARN4(PL_regcomp_parse,
+                       vWARN4(RExC_parse,
                               "False [] range \"%*.*s\"",
-                              PL_regcomp_parse - rangebegin,
-                              PL_regcomp_parse - rangebegin,
+                              RExC_parse - rangebegin,
+                              RExC_parse - rangebegin,
                               rangebegin);
                    if (!SIZE_ONLY)
                        ANYOF_BITMAP_SET(ret, '-');
                } else
-                   range = 1;
-               continue;       /* do it next time */
+                   range = 1;  /* yeah, it's a range! */
+               continue;       /* but do it the next time */
            }
        }
+
        /* now is the next time */
        if (!SIZE_ONLY) {
+           if (lastvalue < 256 && value < 256) {
 #ifndef ASCIIish /* EBCDIC, for example. */
-           if ((isLOWER(lastvalue) && isLOWER(value)) ||
-               (isUPPER(lastvalue) && isUPPER(value)))
-           {
-               I32 i;
-               if (isLOWER(lastvalue)) {
-                   for (i = lastvalue; i <= value; i++)
-                       if (isLOWER(i))
-                           ANYOF_BITMAP_SET(ret, i);
-               } else {
-                   for (i = lastvalue; i <= value; i++)
-                       if (isUPPER(i))
-                           ANYOF_BITMAP_SET(ret, i);
+               if ((isLOWER(lastvalue) && isLOWER(value)) ||
+                   (isUPPER(lastvalue) && isUPPER(value)))
+               {
+                   IV i;
+                   if (isLOWER(lastvalue)) {
+                       for (i = lastvalue; i <= value; i++)
+                           if (isLOWER(i))
+                               ANYOF_BITMAP_SET(ret, i);
+                   } else {
+                       for (i = lastvalue; i <= value; i++)
+                           if (isUPPER(i))
+                               ANYOF_BITMAP_SET(ret, i);
+                   }
                }
-           }
-           else
+               else
 #endif
-               for ( ; lastvalue <= value; lastvalue++)
-                   ANYOF_BITMAP_SET(ret, lastvalue);
+                   for ( ; lastvalue <= value; lastvalue++)
+                       ANYOF_BITMAP_SET(ret, lastvalue);
+           } else {
+               ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
+               if (lastvalue < value)
+                   Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
+                                  (UV)lastvalue, (UV)value);
+               else
+                   Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+                                  (UV)value);
+           }
         }
-       range = 0;
+
+       range = 0; /* this range (if it was one) is done now */
     }
+
     if (need_class) {
        if (SIZE_ONLY)
-           PL_regsize += ANYOF_CLASS_ADD_SKIP;
+           RExC_size += ANYOF_CLASS_ADD_SKIP;
        else
-           PL_regcode += ANYOF_CLASS_ADD_SKIP;
+           RExC_emit += ANYOF_CLASS_ADD_SKIP;
     }
+
     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
     if (!SIZE_ONLY &&
-       (ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD) {
+       (ANYOF_FLAGS(ret) &
+        /* If the only flag is folding (plus possibly inversion). */
+        (ANYOF_FLAGS_ALL ^ ANYOF_INVERT) == ANYOF_FOLD)) {
        for (value = 0; value < 256; ++value) {
            if (ANYOF_BITMAP_TEST(ret, value)) {
-               I32 cf = PL_fold[value];
-               ANYOF_BITMAP_SET(ret, cf);
+               IV fold = PL_fold[value];
+
+               if (fold != value)
+                   ANYOF_BITMAP_SET(ret, fold);
            }
        }
        ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
     }
+
     /* optimize inverted simple patterns (e.g. [^a-z]) */
-    if (!SIZE_ONLY && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
+    if (!SIZE_ONLY && !dont_optimize_invert &&
+       /* If the only flag is inversion. */
+       (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
        for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
            ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
-       ANYOF_FLAGS(ret) = 0;
-    }
-    return ret;
-}
-
-STATIC regnode *
-S_regclassutf8(pTHX)
-{
-    dTHR;
-    register char *e;
-    register U32 value;
-    register U32 lastvalue = OOB_UTF8;
-    register I32 range = 0;
-    register regnode *ret;
-    I32 numlen;
-    I32 n;
-    SV *listsv;
-    U8 flags = 0;
-    I32 namedclass;
-    char *rangebegin;
-
-    if (*PL_regcomp_parse == '^') {    /* Complement of range. */
-       PL_regnaughty++;
-       PL_regcomp_parse++;
-       if (!SIZE_ONLY)
-           flags |= ANYOF_INVERT;
-    }
-    if (!SIZE_ONLY) {
-       if (FOLD)
-           flags |= ANYOF_FOLD;
-       if (LOC)
-           flags |= ANYOF_LOCALE;
-       listsv = newSVpvn("# comment\n",10);
-    }
-
-    if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
-       checkposixcc();
-
-    if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
-       goto skipcond;          /* allow 1st char to be ] or - */
-
-    while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
-       skipcond:
-       namedclass = OOB_NAMEDCLASS;
-       if (!range)
-           rangebegin = PL_regcomp_parse;
-       value = utf8_to_uv_chk((U8*)PL_regcomp_parse, &numlen, 0);
-       PL_regcomp_parse += numlen;
-       if (value == '[')
-           namedclass = regpposixcc(value);
-       else if (value == '\\') {
-           value = (U32)utf8_to_uv_chk((U8*)PL_regcomp_parse, &numlen, 0);
-           PL_regcomp_parse += numlen;
-           /* Some compilers cannot handle switching on 64-bit integer
-            * values, therefore value cannot be an UV.  Yes, this will
-            * be a problem later if we want switch on Unicode.  --jhi */
-           switch (value) {
-           case 'w':           namedclass = ANYOF_ALNUM;               break;
-           case 'W':           namedclass = ANYOF_NALNUM;              break;
-           case 's':           namedclass = ANYOF_SPACE;               break;
-           case 'S':           namedclass = ANYOF_NSPACE;              break;
-           case 'd':           namedclass = ANYOF_DIGIT;               break;
-           case 'D':           namedclass = ANYOF_NDIGIT;              break;
-           case 'p':
-           case 'P':
-               if (*PL_regcomp_parse == '{') {
-                   e = strchr(PL_regcomp_parse++, '}');
-                    if (!e)
-                        vFAIL("Missing right brace on \\p{}");
-                   n = e - PL_regcomp_parse;
-               }
-               else {
-                   e = PL_regcomp_parse;
-                   n = 1;
-               }
-               if (!SIZE_ONLY) {
-                   if (value == 'p')
-                       Perl_sv_catpvf(aTHX_ listsv,
-                                      "+utf8::%.*s\n", (int)n, PL_regcomp_parse);
-                   else
-                       Perl_sv_catpvf(aTHX_ listsv,
-                                      "!utf8::%.*s\n", (int)n, PL_regcomp_parse);
-               }
-               PL_regcomp_parse = e + 1;
-               lastvalue = OOB_UTF8;
-               continue;
-           case 'n':           value = '\n';           break;
-           case 'r':           value = '\r';           break;
-           case 't':           value = '\t';           break;
-           case 'f':           value = '\f';           break;
-           case 'b':           value = '\b';           break;
-#ifdef ASCIIish
-           case 'e':           value = '\033';         break;
-           case 'a':           value = '\007';         break;
-#else
-           case 'e':           value = '\047';         break;
-           case 'a':           value = '\057';         break;
-#endif
-           case 'x':
-               if (*PL_regcomp_parse == '{') {
-                   e = strchr(PL_regcomp_parse++, '}');
-                    if (!e) 
-                        vFAIL("Missing right brace on \\x{}");
-                   numlen = 1;         /* allow underscores */
-                   value = (UV)scan_hex(PL_regcomp_parse,
-                                    e - PL_regcomp_parse,
-                                    &numlen);
-                   PL_regcomp_parse = e + 1;
-               }
-               else {
-                   numlen = 0;         /* disallow underscores */
-                   value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen);
-                   PL_regcomp_parse += numlen;
-               }
-               break;
-           case 'c':
-               value = UCHARAT(PL_regcomp_parse++);
-               value = toCTRL(value);
-               break;
-           case '0': case '1': case '2': case '3': case '4':
-           case '5': case '6': case '7': case '8': case '9':
-               numlen = 0;             /* disallow underscores */
-               value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen);
-               PL_regcomp_parse += numlen;
-               break;
-           default:
-               if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
-                   vWARN2(PL_regcomp_parse,
-                          "Unrecognized escape \\%c in character class passed through",
-                          (int)value);
-               break;
-           }
-       }
-       if (namedclass > OOB_NAMEDCLASS) {
-           if (range) { /* a-\d, a-[:digit:] */
-               if (!SIZE_ONLY) {
-                   if (ckWARN(WARN_REGEXP))
-                       vWARN4(PL_regcomp_parse,
-                              "False [] range \"%*.*s\"",
-                              PL_regcomp_parse - rangebegin,
-                              PL_regcomp_parse - rangebegin,
-                              rangebegin);
-                   Perl_sv_catpvf(aTHX_ listsv,
-                                  /* 0x002D is Unicode for '-' */
-                                  "%04"UVxf"\n002D\n", (UV)lastvalue);
-               }
-               range = 0;
-           }
-           if (!SIZE_ONLY) {
-               switch (namedclass) {
-               case ANYOF_ALNUM:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");    break;
-               case ANYOF_NALNUM:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");    break;
-               case ANYOF_ALNUMC:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");   break;
-               case ANYOF_NALNUMC:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");   break;
-               case ANYOF_ALPHA:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");   break;
-               case ANYOF_NALPHA:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");   break;
-               case ANYOF_ASCII:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");   break;
-               case ANYOF_NASCII:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");   break;
-               case ANYOF_CNTRL:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");   break;
-               case ANYOF_NCNTRL:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");   break;
-               case ANYOF_GRAPH:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");   break;
-               case ANYOF_NGRAPH:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");   break;
-               case ANYOF_DIGIT:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");   break;
-               case ANYOF_NDIGIT:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");   break;
-               case ANYOF_LOWER:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");   break;
-               case ANYOF_NLOWER:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");   break;
-               case ANYOF_PRINT:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");   break;
-               case ANYOF_NPRINT:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");   break;
-               case ANYOF_PUNCT:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");   break;
-               case ANYOF_NPUNCT:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");   break;
-               case ANYOF_SPACE:
-               case ANYOF_PSXSPC:
-               case ANYOF_BLANK:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");   break;
-               case ANYOF_NSPACE:
-               case ANYOF_NPSXSPC:
-               case ANYOF_NBLANK:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");   break;
-               case ANYOF_UPPER:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");   break;
-               case ANYOF_NUPPER:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");   break;
-               case ANYOF_XDIGIT:
-                   Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");  break;
-               case ANYOF_NXDIGIT:
-                   Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");  break;
-               }
-               continue;
-           }
-       }
-        if (range) {
-           if (lastvalue > value) { /* b-a */
-               Simple_vFAIL4("invalid [] range \"%*.*s\"",
-                             PL_regcomp_parse - rangebegin,
-                             PL_regcomp_parse - rangebegin,
-                             rangebegin);
-           }
-           range = 0;
-       }
-       else {
-           lastvalue = value;
-           if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
-               PL_regcomp_parse[1] != ']') {
-               PL_regcomp_parse++;
-               if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
-                   if (ckWARN(WARN_REGEXP))
-                       vWARN4(PL_regcomp_parse,
-                              "False [] range \"%*.*s\"",
-                              PL_regcomp_parse - rangebegin,
-                              PL_regcomp_parse - rangebegin,
-                              rangebegin);
-                   if (!SIZE_ONLY)
-                       Perl_sv_catpvf(aTHX_ listsv,
-                                      /* 0x002D is Unicode for '-' */
-                                      "002D\n");
-               } else
-                   range = 1;
-               continue;       /* do it next time */
-           }
-       }
-       /* now is the next time */
-       if (!SIZE_ONLY)
-           Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
-                          (UV)lastvalue, (UV)value);
-       range = 0;
+       ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
     }
 
-    ret = reganode(ANYOFUTF8, 0);
+    if (!SIZE_ONLY) { 
+       AV *av = newAV();
+       SV *rv;
 
-    if (!SIZE_ONLY) {
-       SV *rv = swash_init("utf8", "", listsv, 1, 0);
-       SvREFCNT_dec(listsv);
-       n = add_data(1,"s");
-       PL_regcomp_rx->data->data[n] = (void*)rv;
-       ARG1_SET(ret, flags);
-       ARG2_SET(ret, n);
+       av_store(av, 0, listsv);
+       av_store(av, 1, NULL);
+       rv = newRV_noinc((SV*)av);
+       n = add_data(pRExC_state, 1, "s");
+       RExC_rx->data->data[n] = (void*)rv;
+       ARG_SET(ret, n);
     }
 
     return ret;
 }
 
 STATIC char*
-S_nextchar(pTHX)
+S_nextchar(pTHX_ RExC_state_t *pRExC_state)
 {
-    dTHR;
-    char* retval = PL_regcomp_parse++;
+    char* retval = RExC_parse++;
 
     for (;;) {
-       if (*PL_regcomp_parse == '(' && PL_regcomp_parse[1] == '?' &&
-               PL_regcomp_parse[2] == '#') {
-           while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
-               PL_regcomp_parse++;
-           PL_regcomp_parse++;
+       if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
+               RExC_parse[2] == '#') {
+           while (*RExC_parse && *RExC_parse != ')')
+               RExC_parse++;
+           RExC_parse++;
            continue;
        }
-       if (PL_regflags & PMf_EXTENDED) {
-           if (isSPACE(*PL_regcomp_parse)) {
-               PL_regcomp_parse++;
+       if (RExC_flags16 & PMf_EXTENDED) {
+           if (isSPACE(*RExC_parse)) {
+               RExC_parse++;
                continue;
            }
-           else if (*PL_regcomp_parse == '#') {
-               while (*PL_regcomp_parse && *PL_regcomp_parse != '\n')
-                   PL_regcomp_parse++;
-               PL_regcomp_parse++;
+           else if (*RExC_parse == '#') {
+               while (*RExC_parse && *RExC_parse != '\n')
+                   RExC_parse++;
+               RExC_parse++;
                continue;
            }
        }
@@ -3887,23 +3862,22 @@ S_nextchar(pTHX)
 - reg_node - emit a node
 */
 STATIC regnode *                       /* Location. */
-S_reg_node(pTHX_ U8 op)
+S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
 {
-    dTHR;
     register regnode *ret;
     register regnode *ptr;
 
-    ret = PL_regcode;
+    ret = RExC_emit;
     if (SIZE_ONLY) {
-       SIZE_ALIGN(PL_regsize);
-       PL_regsize += 1;
+       SIZE_ALIGN(RExC_size);
+       RExC_size += 1;
        return(ret);
     }
 
     NODE_ALIGN_FILL(ret);
     ptr = ret;
     FILL_ADVANCE_NODE(ptr, op);
-    PL_regcode = ptr;
+    RExC_emit = ptr;
 
     return(ret);
 }
@@ -3912,23 +3886,22 @@ S_reg_node(pTHX_ U8 op)
 - reganode - emit a node with an argument
 */
 STATIC regnode *                       /* Location. */
-S_reganode(pTHX_ U8 op, U32 arg)
+S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
 {
-    dTHR;
     register regnode *ret;
     register regnode *ptr;
 
-    ret = PL_regcode;
+    ret = RExC_emit;
     if (SIZE_ONLY) {
-       SIZE_ALIGN(PL_regsize);
-       PL_regsize += 2;
+       SIZE_ALIGN(RExC_size);
+       RExC_size += 2;
        return(ret);
     }
 
     NODE_ALIGN_FILL(ret);
     ptr = ret;
     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
-    PL_regcode = ptr;
+    RExC_emit = ptr;
 
     return(ret);
 }
@@ -3937,16 +3910,9 @@ S_reganode(pTHX_ U8 op, U32 arg)
 - reguni - emit (if appropriate) a Unicode character
 */
 STATIC void
-S_reguni(pTHX_ UV uv, char* s, I32* lenp)
+S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
 {
-    dTHR;
-    if (SIZE_ONLY) {
-       U8 tmpbuf[UTF8_MAXLEN];
-       *lenp = uv_to_utf8(tmpbuf, uv) - tmpbuf;
-    }
-    else
-       *lenp = uv_to_utf8((U8*)s, uv) - (U8*)s;
-
+    *lenp = SIZE_ONLY ? UNISKIP(uv) : (uv_to_utf8((U8*)s, uv) - (U8*)s);
 }
 
 /*
@@ -3955,9 +3921,8 @@ S_reguni(pTHX_ UV uv, char* s, I32* lenp)
 * Means relocating the operand.
 */
 STATIC void
-S_reginsert(pTHX_ U8 op, regnode *opnd)
+S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
 {
-    dTHR;
     register regnode *src;
     register regnode *dst;
     register regnode *place;
@@ -3966,13 +3931,13 @@ S_reginsert(pTHX_ U8 op, regnode *opnd)
 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
 
     if (SIZE_ONLY) {
-       PL_regsize += NODE_STEP_REGNODE + offset;
+       RExC_size += NODE_STEP_REGNODE + offset;
        return;
     }
 
-    src = PL_regcode;
-    PL_regcode += NODE_STEP_REGNODE + offset;
-    dst = PL_regcode;
+    src = RExC_emit;
+    RExC_emit += NODE_STEP_REGNODE + offset;
+    dst = RExC_emit;
     while (src > opnd)
        StructCopy(--src, --dst, regnode);
 
@@ -3986,9 +3951,8 @@ S_reginsert(pTHX_ U8 op, regnode *opnd)
 - regtail - set the next-pointer at the end of a node chain of p to val.
 */
 STATIC void
-S_regtail(pTHX_ regnode *p, regnode *val)
+S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
 {
-    dTHR;
     register regnode *scan;
     register regnode *temp;
 
@@ -4016,17 +3980,16 @@ S_regtail(pTHX_ regnode *p, regnode *val)
 - regoptail - regtail on operand of first argument; nop if operandless
 */
 STATIC void
-S_regoptail(pTHX_ regnode *p, regnode *val)
+S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
 {
-    dTHR;
     /* "Operandless" and "op != BRANCH" are synonymous in practice. */
     if (p == NULL || SIZE_ONLY)
        return;
     if (PL_regkind[(U8)OP(p)] == BRANCH) {
-       regtail(NEXTOPER(p), val);
+       regtail(pRExC_state, NEXTOPER(p), val);
     }
     else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
-       regtail(NEXTOPER(NEXTOPER(p)), val);
+       regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val);
     }
     else
        return;
@@ -4132,7 +4095,6 @@ void
 Perl_regdump(pTHX_ regexp *r)
 {
 #ifdef DEBUGGING
-    dTHR;
     SV *sv = sv_newmortal();
 
     (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
@@ -4199,7 +4161,7 @@ Perl_regdump(pTHX_ regexp *r)
 STATIC void
 S_put_byte(pTHX_ SV *sv, int c)
 {
-    if (c <= ' ' || c == 127 || c == 255)
+    if (isCNTRL(c) || c == 127 || c == 255 || !isPRINT(c))
        Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
     else if (c == '-' || c == ']' || c == '\\' || c == '^')
        Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
@@ -4214,12 +4176,13 @@ void
 Perl_regprop(pTHX_ SV *sv, regnode *o)
 {
 #ifdef DEBUGGING
-    dTHR;
     register int k;
 
     sv_setpvn(sv, "", 0);
     if (OP(o) >= reg_num)              /* regnode.type is unsigned */
-       FAIL("Corrupted regexp opcode");
+       /* It would be nice to FAIL() here, but this may be called from
+          regexec.c, and it would be hard to supply pRExC_state. */
+       Perl_croak(aTHX_ "Corrupted regexp opcode");
     sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
 
     k = PL_regkind[(U8)OP(o)];
@@ -4228,7 +4191,7 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
        Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>", PL_colors[0],
                       STR_LEN(o), STRING(o), PL_colors[1]);
     else if (k == CURLY) {
-       if (OP(o) == CURLYM || OP(o) == CURLYN)
+       if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
            Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
        Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
     }
@@ -4240,8 +4203,9 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
        Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
     else if (k == ANYOF) {
        int i, rangestart = -1;
-       const char * const out[] = {    /* Should be syncronized with
-                                          ANYOF_ #xdefines in regcomp.h */
+       U8 flags = ANYOF_FLAGS(o);
+       const char * const anyofs[] = { /* Should be syncronized with
+                                        * ANYOF_ #xdefines in regcomp.h */
            "\\w",
            "\\W",
            "\\s",
@@ -4274,12 +4238,12 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
            "[:^blank:]"
        };
 
-       if (o->flags & ANYOF_LOCALE)
+       if (flags & ANYOF_LOCALE)
            sv_catpv(sv, "{loc}");
-       if (o->flags & ANYOF_FOLD)
+       if (flags & ANYOF_FOLD)
            sv_catpv(sv, "{i}");
        Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
-       if (o->flags & ANYOF_INVERT)
+       if (flags & ANYOF_INVERT)
            sv_catpv(sv, "^");
        for (i = 0; i <= 256; i++) {
            if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
@@ -4297,10 +4261,79 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
                rangestart = -1;
            }
        }
+
        if (o->flags & ANYOF_CLASS)
-           for (i = 0; i < sizeof(out)/sizeof(char*); i++)
+           for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++)
                if (ANYOF_CLASS_TEST(o,i))
-                   sv_catpv(sv, out[i]);
+                   sv_catpv(sv, anyofs[i]);
+
+       if (flags & ANYOF_UNICODE)
+           sv_catpv(sv, "{unicode}");
+       else if (flags & ANYOF_UNICODE_ALL)
+           sv_catpv(sv, "{all-unicode}");
+
+       {
+           SV *lv;
+           SV *sw = regclass_swash(o, FALSE, &lv);
+           
+           if (lv) {
+               if (sw) {
+                   UV i;
+                   U8 s[UTF8_MAXLEN+1];
+                   
+                   for (i = 0; i <= 256; i++) { /* just the first 256 */
+                       U8 *e = uv_to_utf8(s, i);
+                       
+                       if (i < 256 && swash_fetch(sw, s)) {
+                           if (rangestart == -1)
+                               rangestart = i;
+                       } else if (rangestart != -1) {
+                           U8 *p;
+                           
+                           if (i <= rangestart + 3)
+                               for (; rangestart < i; rangestart++) {
+                                   for(e = uv_to_utf8(s, rangestart), p = s; p < e; p++)
+                                       put_byte(sv, *p);
+                               }
+                           else {
+                               for (e = uv_to_utf8(s, rangestart), p = s; p < e; p++)
+                                   put_byte(sv, *p);
+                               sv_catpv(sv, "-");
+                                   for (e = uv_to_utf8(s, i - 1), p = s; p < e; p++)
+                                       put_byte(sv, *p);
+                               }
+                               rangestart = -1;
+                           }
+                       }
+                       
+                   sv_catpv(sv, "..."); /* et cetera */
+               }
+
+               {
+                   char *s = savepv(SvPVX(lv));
+                   char *origs = s;
+                   
+                   while(*s && *s != '\n') s++;
+                   
+                   if (*s == '\n') {
+                       char *t = ++s;
+                       
+                       while (*s) {
+                           if (*s == '\n')
+                               *s = ' ';
+                           s++;
+                       }
+                       if (s[-1] == ' ')
+                           s[-1] = 0;
+                       
+                       sv_catpv(sv, t);
+                   }
+                   
+                   Safefree(origs);
+               }
+           }
+       }
+
        Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
     }
     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
@@ -4330,7 +4363,6 @@ Perl_re_intuit_string(pTHX_ regexp *prog)
 void
 Perl_pregfree(pTHX_ struct regexp *r)
 {
-    dTHR;
     DEBUG_r(if (!PL_colorset) reginitcolors());
 
     if (!r || (--r->refcnt > 0))
@@ -4391,7 +4423,7 @@ Perl_pregfree(pTHX_ struct regexp *r)
            case 'n':
                break;
            default:
-               FAIL2("panic: regfree data code '%c'", r->data->what[n]);
+               Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
            }
        }
        Safefree(r->data->what);
@@ -4411,7 +4443,6 @@ Perl_pregfree(pTHX_ struct regexp *r)
 regnode *
 Perl_regnext(pTHX_ register regnode *p)
 {
-    dTHR;
     register I32 offset;
 
     if (p == &PL_regdummy)
@@ -4463,12 +4494,22 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
 void
 Perl_save_re_context(pTHX)
 {                   
-    dTHR;
+#if 0
+    SAVEPPTR(RExC_precomp);            /* uncompiled string. */
+    SAVEI32(RExC_npar);                /* () count. */
+    SAVEI32(RExC_size);                /* Code size. */
+    SAVEI16(RExC_flags16);             /* are we folding, multilining? */
+    SAVEVPTR(RExC_rx);         /* from regcomp.c */
+    SAVEI32(RExC_seen);                /* from regcomp.c */
+    SAVEI32(RExC_sawback);             /* Did we see \1, ...? */
+    SAVEI32(RExC_naughty);             /* How bad is this pattern? */
+    SAVEVPTR(RExC_emit);               /* Code-emit pointer; &regdummy = don't */
+    SAVEPPTR(RExC_end);                /* End of input for compile */
+    SAVEPPTR(RExC_parse);              /* Input-scan pointer. */
+#endif
+
+    SAVEI32(PL_reg_flags);             /* from regexec.c */
     SAVEPPTR(PL_bostr);
-    SAVEPPTR(PL_regprecomp);           /* uncompiled string. */
-    SAVEI32(PL_regnpar);               /* () count. */
-    SAVEI32(PL_regsize);               /* Code size. */
-    SAVEI16(PL_regflags);              /* are we folding, multilining? */
     SAVEPPTR(PL_reginput);             /* String-input pointer. */
     SAVEPPTR(PL_regbol);               /* Beginning of input, for ^ check. */
     SAVEPPTR(PL_regeol);               /* End of input, for $ check. */
@@ -4483,20 +4524,12 @@ Perl_save_re_context(pTHX)
     SAVEI32(PL_reg_start_tmpl);                /* from regexec.c */
     PL_reg_start_tmpl = 0;
     SAVEVPTR(PL_regdata);
-    SAVEI32(PL_reg_flags);             /* from regexec.c */
     SAVEI32(PL_reg_eval_set);          /* from regexec.c */
     SAVEI32(PL_regnarrate);            /* from regexec.c */
     SAVEVPTR(PL_regprogram);           /* from regexec.c */
     SAVEINT(PL_regindent);             /* from regexec.c */
     SAVEVPTR(PL_regcc);                        /* from regexec.c */
     SAVEVPTR(PL_curcop);
-    SAVEVPTR(PL_regcomp_rx);           /* from regcomp.c */
-    SAVEI32(PL_regseen);               /* from regcomp.c */
-    SAVEI32(PL_regsawback);            /* Did we see \1, ...? */
-    SAVEI32(PL_regnaughty);            /* How bad is this pattern? */
-    SAVEVPTR(PL_regcode);              /* Code-emit pointer; &regdummy = don't */
-    SAVEPPTR(PL_regxend);              /* End of input for compile */
-    SAVEPPTR(PL_regcomp_parse);                /* Input-scan pointer. */
     SAVEVPTR(PL_reg_call_cc);          /* from regexec.c */
     SAVEVPTR(PL_reg_re);               /* from regexec.c */
     SAVEPPTR(PL_reg_ganch);            /* from regexec.c */
@@ -4505,6 +4538,7 @@ Perl_save_re_context(pTHX)
     SAVEI32(PL_reg_oldpos);                    /* from regexec.c */
     SAVEVPTR(PL_reg_oldcurpm);         /* from regexec.c */
     SAVEVPTR(PL_reg_curpm);            /* from regexec.c */
+    SAVEI32(PL_regnpar);               /* () count. */
 #ifdef DEBUGGING
     SAVEPPTR(PL_reg_starttry);         /* from regexec.c */    
 #endif
@@ -4521,4 +4555,3 @@ clear_re(pTHXo_ void *r)
 {
     ReREFCNT_dec((regexp *)r);
 }
-
index 225ff74..066e31f 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -88,12 +88,13 @@ struct regnode_2 {
 };
 
 #define ANYOF_BITMAP_SIZE      32      /* 256 b/(8 b/B) */
-#define ANYOF_CLASSBITMAP_SIZE  4
+#define ANYOF_CLASSBITMAP_SIZE  4      /* up to 32 (8*4) named classes */
 
 struct regnode_charclass {
     U8 flags;
     U8  type;
     U16 next_off;
+    U32 arg1;
     char bitmap[ANYOF_BITMAP_SIZE];
 };
 
@@ -101,6 +102,7 @@ struct regnode_charclass_class {
     U8 flags;
     U8  type;
     U16 next_off;
+    U32 arg1;
     char bitmap[ANYOF_BITMAP_SIZE];
     char classflags[ANYOF_CLASSBITMAP_SIZE];
 };
@@ -176,17 +178,26 @@ struct regnode_charclass_class {
 
 #define REG_MAGIC 0234
 
-#define SIZE_ONLY (PL_regcode == &PL_regdummy)
+#define SIZE_ONLY (RExC_emit == &PL_regdummy)
 
 /* Flags for node->flags of ANYOF */
 
-#define ANYOF_CLASS    0x08
-#define ANYOF_INVERT   0x04
-#define ANYOF_FOLD     0x02
-#define ANYOF_LOCALE   0x01
+#define ANYOF_CLASS            0x08
+#define ANYOF_INVERT           0x04
+#define ANYOF_FOLD             0x02
+#define ANYOF_LOCALE           0x01
 
 /* Used for regstclass only */
-#define ANYOF_EOS      0x10            /* Can match an empty string too */
+#define ANYOF_EOS              0x10            /* Can match an empty string too */
+
+/* There is a character or a range past 0xff */
+#define ANYOF_UNICODE          0x20
+#define ANYOF_UNICODE_ALL      0x40    /* Can match any char past 0xff */
+
+/* Are there any runtime flags on in this node? */
+#define ANYOF_RUNTIME(s)       (ANYOF_FLAGS(s) & 0x0f)
+
+#define ANYOF_FLAGS_ALL                0xff
 
 /* Character classes for node->classflags of ANYOF */
 /* Should be synchronized with a table in regprop() */
@@ -220,7 +231,7 @@ struct regnode_charclass_class {
 #define ANYOF_NXDIGIT  25
 #define ANYOF_PSXSPC   26      /* POSIX space: \s plus the vertical tab */
 #define ANYOF_NPSXSPC  27
-#define ANYOF_BLANK    28      /* GNU extension: space and tab */
+#define ANYOF_BLANK    28      /* GNU extension: space and tab: non-vertical space */
 #define ANYOF_NBLANK   29
 
 #define ANYOF_MAX      32
@@ -238,7 +249,6 @@ struct regnode_charclass_class {
 #define ANYOF_CLASS_SIZE       (sizeof(struct regnode_charclass_class))
 
 #define ANYOF_FLAGS(p)         ((p)->flags)
-#define ANYOF_FLAGS_ALL                0xff
 
 #define ANYOF_BIT(c)           (1 << ((c) & 7))
 
@@ -300,12 +310,14 @@ EXTCONST U8 PL_varies[] = {
 EXTCONST U8 PL_simple[];
 #else
 EXTCONST U8 PL_simple[] = {
-    REG_ANY, ANYUTF8, SANY, SANYUTF8, ANYOF, ANYOFUTF8,
-    ALNUM, ALNUMUTF8, ALNUML, ALNUMLUTF8,
-    NALNUM, NALNUMUTF8, NALNUML, NALNUMLUTF8,
-    SPACE, SPACEUTF8, SPACEL, SPACELUTF8,
-    NSPACE, NSPACEUTF8, NSPACEL, NSPACELUTF8,
-    DIGIT, DIGITUTF8, NDIGIT, NDIGITUTF8, 0
+    REG_ANY,   SANY,
+    ANYOF,
+    ALNUM,     ALNUML,
+    NALNUM,    NALNUML,
+    SPACE,     SPACEL,
+    NSPACE,    NSPACEL,
+    DIGIT,     NDIGIT,
+    0
 };
 #endif
 
index bb5f8f8..59284f4 100644 (file)
@@ -16,46 +16,27 @@ EOL         EOL,    no      Match "" at end of line.
 MEOL           EOL,    no      Same, assuming multiline.
 SEOL           EOL,    no      Same, assuming singleline.
 BOUND          BOUND,  no      Match "" at any word boundary
-BOUNDUTF8      BOUND,  no      Match "" at any word boundary
 BOUNDL         BOUND,  no      Match "" at any word boundary
-BOUNDLUTF8     BOUND,  no      Match "" at any word boundary
 NBOUND         NBOUND, no      Match "" at any word non-boundary
-NBOUNDUTF8     NBOUND, no      Match "" at any word non-boundary
 NBOUNDL                NBOUND, no      Match "" at any word non-boundary
-NBOUNDLUTF8    NBOUND, no      Match "" at any word non-boundary
 GPOS           GPOS,   no      Matches where last m//g left off.
 
 # [Special] alternatives
 REG_ANY                REG_ANY,    no  Match any one character (except newline).
-ANYUTF8                REG_ANY,    no  Match any one Unicode character (except newline).
 SANY           REG_ANY,    no  Match any one character.
-SANYUTF8       REG_ANY,    no  Match any one Unicode character.
 ANYOF          ANYOF,  sv      Match character in (or not in) this class.
-ANYOFUTF8      ANYOF,  sv 1    Match character in (or not in) this class.
 ALNUM          ALNUM,  no      Match any alphanumeric character
-ALNUMUTF8      ALNUM,  no      Match any alphanumeric character in utf8
 ALNUML         ALNUM,  no      Match any alphanumeric char in locale
-ALNUMLUTF8     ALNUM,  no      Match any alphanumeric char in locale+utf8
 NALNUM         NALNUM, no      Match any non-alphanumeric character
-NALNUMUTF8     NALNUM, no      Match any non-alphanumeric character in utf8
 NALNUML                NALNUM, no      Match any non-alphanumeric char in locale
-NALNUMLUTF8    NALNUM, no      Match any non-alphanumeric char in locale+utf8
 SPACE          SPACE,  no      Match any whitespace character
-SPACEUTF8      SPACE,  no      Match any whitespace character in utf8
 SPACEL         SPACE,  no      Match any whitespace char in locale
-SPACELUTF8     SPACE,  no      Match any whitespace char in locale+utf8
 NSPACE         NSPACE, no      Match any non-whitespace character
-NSPACEUTF8     NSPACE, no      Match any non-whitespace character in utf8
 NSPACEL                NSPACE, no      Match any non-whitespace char in locale
-NSPACELUTF8    NSPACE, no      Match any non-whitespace char in locale+utf8
 DIGIT          DIGIT,  no      Match any numeric character
-DIGITUTF8      DIGIT,  no      Match any numeric character in utf8
 DIGITL         DIGIT,  no      Match any numeric character in locale
-DIGITLUTF8     DIGIT,  no      Match any numeric character in locale+utf8
 NDIGIT         NDIGIT, no      Match any non-numeric character
-NDIGITUTF8     NDIGIT, no      Match any non-numeric character in utf8
 NDIGITL                NDIGIT, no      Match any non-numeric character in locale
-NDIGITLUTF8    NDIGIT, no      Match any non-numeric character in locale+utf8
 CLUMP          CLUMP,  no      Match any combining character sequence
 
 # BRANCH       The set of branches constituting a single choice are hooked
index d3f2065..0b65d11 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -39,6 +39,7 @@
 /* *These* symbols are masked to allow static link. */
 #  define Perl_pregexec my_pregexec
 #  define Perl_reginitcolors my_reginitcolors 
+#  define Perl_regclass_swash my_regclass_swash
 
 #  define PERL_NO_GET_CONTEXT
 #endif 
@@ -66,7 +67,7 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1991-2000, Larry Wall
+ ****    Copyright (c) 1991-2001, Larry Wall
  ****
  ****    You may distribute under the terms of either the GNU General Public
  ****    License or the Artistic License, as specified in the README file.
  * Forwards.
  */
 
-#define REGINCLASS(p,c)  (ANYOF_FLAGS(p) ? reginclass(p,c) : ANYOF_BITMAP_TEST(p,c))
-#define REGINCLASSUTF8(f,p)  (ARG1(f) ? reginclassutf8(f,p) : swash_fetch((SV*)PL_regdata->data[ARG2(f)],p))
-
 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
-#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
+#define CHR_DIST(a,b) (DO_UTF8(PL_reg_sv) ? utf8_distance(a,b) : a - b)
 
 #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off))
 #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off))
-#define HOP(pos,off) (UTF ? reghop((U8*)pos, off) : (U8*)(pos + off))
-#define HOPMAYBE(pos,off) (UTF ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
+#define HOP(pos,off) (DO_UTF8(PL_reg_sv) ? reghop((U8*)pos, off) : (U8*)(pos + off))
+#define HOPMAYBE(pos,off) (DO_UTF8(PL_reg_sv) ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
 #define HOPc(pos,off) ((char*)HOP(pos,off))
 #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
 
+#define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
+#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
+#define HOP3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
+#define HOPMAYBE3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
+#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
+#define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim))
+
 static void restore_pos(pTHXo_ void *arg);
 
 
 STATIC CHECKPOINT
 S_regcppush(pTHX_ I32 parenfloor)
 {
-    dTHR;
     int retval = PL_savestack_ix;
     int i = (PL_regsize - parenfloor) * 4;
     int p;
@@ -145,19 +149,18 @@ S_regcppush(pTHX_ I32 parenfloor)
 }
 
 /* These are needed since we do not localize EVAL nodes: */
-#  define REGCP_SET  DEBUG_r(PerlIO_printf(Perl_debug_log,             \
+#  define REGCP_SET(cp)  DEBUG_r(PerlIO_printf(Perl_debug_log,         \
                             "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
-                            (IV)PL_savestack_ix)); lastcp = PL_savestack_ix
+                            (IV)PL_savestack_ix)); cp = PL_savestack_ix
 
-#  define REGCP_UNWIND  DEBUG_r(lastcp != PL_savestack_ix ?            \
+#  define REGCP_UNWIND(cp)  DEBUG_r(cp != PL_savestack_ix ?            \
                                PerlIO_printf(Perl_debug_log,           \
                                "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
-                               (IV)lastcp, (IV)PL_savestack_ix) : 0); regcpblow(lastcp)
+                               (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
 
 STATIC char *
 S_regcppop(pTHX)
 {
-    dTHR;
     I32 i = SSPOPINT;
     U32 paren = 0;
     char *input;
@@ -190,18 +193,29 @@ S_regcppop(pTHX)
                          (IV)(*PL_reglastparen + 1), (IV)PL_regnpar);
        }
     );
+#if 1
+    /* It would seem that the similar code in regtry()
+     * already takes care of this, and in fact it is in
+     * a better location to since this code can #if 0-ed out
+     * but the code in regtry() is needed or otherwise tests
+     * requiring null fields (pat.t#187 and split.t#{13,14}
+     * (as of patchlevel 7877)  will fail.  Then again,
+     * this code seems to be necessary or otherwise
+     * building DynaLoader will fail:
+     * "Error: '*' not in typemap in DynaLoader.xs, line 164"
+     * --jhi */
     for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) {
        if (paren > PL_regsize)
            PL_regstartp[paren] = -1;
        PL_regendp[paren] = -1;
     }
+#endif
     return input;
 }
 
 STATIC char *
 S_regcp_set_to(pTHX_ I32 ss)
 {
-    dTHR;
     I32 tmp = PL_savestack_ix;
 
     PL_savestack_ix = ss;
@@ -219,7 +233,7 @@ typedef struct re_cc_state
     regexp *re;
 } re_cc_state;
 
-#define regcpblow(cp) LEAVE_SCOPE(cp)
+#define regcpblow(cp) LEAVE_SCOPE(cp)  /* Ignores regcppush()ed data. */
 
 #define TRYPAREN(paren, n, input) {                            \
     if (paren) {                                               \
@@ -260,7 +274,6 @@ Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *stren
 STATIC void
 S_cache_re(pTHX_ regexp *prog)
 {
-    dTHR;
     PL_regprecomp = prog->precomp;             /* Needed for FAIL. */
 #ifdef DEBUGGING
     PL_regprogram = prog->program;
@@ -325,6 +338,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     register I32 end_shift;
     register char *s;
     register SV *check;
+    char *strbeg;
     char *t;
     I32 ml_anch;
     char *tmp;
@@ -347,10 +361,15 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                      (strend - strpos > 60 ? "..." : ""))
        );
 
-    if (prog->minlen > strend - strpos) {
+    if (prog->reganch & ROPT_UTF8)
+       PL_reg_flags |= RF_utf8;
+
+    if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) {
        DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
        goto fail;
     }
+    strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
+    PL_regeol = strend;
     check = prog->check_substr;
     if (prog->reganch & ROPT_ANCH) {   /* Match at beg-of-str or after \n */
        ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
@@ -361,7 +380,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
          if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
               /* SvCUR is not set on references: SvRV and SvPVX overlap */
               && sv && !SvROK(sv)
-              && (strpos + SvCUR(sv) != strend)) {
+              && (strpos != strbeg)) {
              DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
              goto fail;
          }
@@ -369,8 +388,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
            /* Substring at constant offset from beg-of-str... */
            I32 slen;
 
-           PL_regeol = strend;                 /* Used in HOP() */
-           s = HOPc(strpos, prog->check_offset_min);
+           s = HOP3c(strpos, prog->check_offset_min, strend);
            if (SvTAIL(check)) {
                slen = SvCUR(check);    /* >= 1 */
 
@@ -404,7 +422,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        if (!ml_anch) {
            I32 end = prog->check_offset_max + CHR_SVLEN(check)
                                         - (SvTAIL(check) != 0);
-           I32 eshift = strend - s - end;
+           I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 
            if (end_shift < eshift)
                end_shift = eshift;
@@ -428,7 +446,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     /* Find a possible match in the region s..strend by looking for
        the "check" substring in the region corrected by start/end_shift. */
     if (flags & REXEC_SCREAM) {
-       char *strbeg = SvPVX(sv);       /* XXXX Assume PV_force() on SCREAM! */
        I32 p = -1;                     /* Internal iterator of scream. */
        I32 *pp = data ? data->scream_pos : &p;
 
@@ -444,8 +461,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
            *data->scream_olds = s;
     }
     else
-       s = fbm_instr((unsigned char*)s + start_shift,
-                     (unsigned char*)strend - end_shift,
+       s = fbm_instr(HOP3(s, start_shift, strend),
+                     HOP3(strend, -end_shift, strbeg),
                      check, PL_multiline ? FBMrf_MULTILINE : 0);
 
     /* Update the count-of-usability, remove useless subpatterns,
@@ -484,34 +501,33 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        if (check == prog->float_substr) {
          do_other_anchored:
            {
-               char *last = s - start_shift, *last1, *last2;
+               char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2;
                char *s1 = s;
 
-               tmp = PL_bostr;
                t = s - prog->check_offset_max;
                if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
                    && (!(prog->reganch & ROPT_UTF8)
-                       || (PL_bostr = strpos, /* Used in regcopmaybe() */
-                           (t = reghopmaybe_c(s, -(prog->check_offset_max)))
+                       || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
                            && t > strpos)))
                    /* EMPTY */;
                else
                    t = strpos;
-               t += prog->anchored_offset;
+               t = HOP3c(t, prog->anchored_offset, strend);
                if (t < other_last)     /* These positions already checked */
                    t = other_last;
-               PL_bostr = tmp;
-               last2 = last1 = strend - prog->minlen;
+               last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
                if (last < last1)
                    last1 = last;
  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
                /* On end-of-str: see comment below. */
                s = fbm_instr((unsigned char*)t,
-                             (unsigned char*)last1 + prog->anchored_offset
-                                + SvCUR(prog->anchored_substr)
-                                - (SvTAIL(prog->anchored_substr)!=0),
-                             prog->anchored_substr, PL_multiline ? FBMrf_MULTILINE : 0);
-               DEBUG_r(PerlIO_printf(Perl_debug_log, "%s anchored substr `%s%.*s%s'%s",
+                             HOP3(HOP3(last1, prog->anchored_offset, strend)
+                                  + SvCUR(prog->anchored_substr),
+                                  -(SvTAIL(prog->anchored_substr)!=0), strbeg),
+                             prog->anchored_substr,
+                             PL_multiline ? FBMrf_MULTILINE : 0);
+               DEBUG_r(PerlIO_printf(Perl_debug_log,
+                       "%s anchored substr `%s%.*s%s'%s",
                        (s ? "Found" : "Contradicts"),
                        PL_colors[0],
                          (int)(SvCUR(prog->anchored_substr)
@@ -526,17 +542,16 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                    }
                    DEBUG_r(PerlIO_printf(Perl_debug_log,
                        ", trying floating at offset %ld...\n",
-                       (long)(s1 + 1 - i_strpos)));
-                   PL_regeol = strend;                 /* Used in HOP() */
-                   other_last = last1 + prog->anchored_offset + 1;
-                   s = HOPc(last, 1);
+                       (long)(HOP3c(s1, 1, strend) - i_strpos)));
+                   other_last = HOP3c(last1, prog->anchored_offset+1, strend);
+                   s = HOP3c(last, 1, strend);
                    goto restart;
                }
                else {
                    DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
                          (long)(s - i_strpos)));
-                   t = s - prog->anchored_offset;
-                   other_last = s + 1;
+                   t = HOP3c(s, -prog->anchored_offset, strbeg);
+                   other_last = HOP3c(s, 1, strend);
                    s = s1;
                    if (t == strpos)
                        goto try_at_start;
@@ -548,11 +563,12 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                char *last, *last1;
                char *s1 = s;
 
-               t = s - start_shift;
-               last1 = last = strend - prog->minlen + prog->float_min_offset;
-               if (last - t > prog->float_max_offset)
-                   last = t + prog->float_max_offset;
-               s = t + prog->float_min_offset;
+               t = HOP3c(s, -start_shift, strbeg);
+               last1 = last =
+                   HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
+               if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
+                   last = HOP3c(t, prog->float_max_offset, strend);
+               s = HOP3c(t, prog->float_min_offset, strend);
                if (s < other_last)
                    s = other_last;
  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
@@ -580,8 +596,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                        ", trying anchored starting at offset %ld...\n",
                        (long)(s1 + 1 - i_strpos)));
                    other_last = last + 1;
-                   PL_regeol = strend;                 /* Used in HOP() */
-                   s = HOPc(t, 1);
+                   s = HOP3c(t, 1, strend);
                    goto restart;
                }
                else {
@@ -597,13 +612,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     }
 
     t = s - prog->check_offset_max;
-    tmp = PL_bostr;
     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
         && (!(prog->reganch & ROPT_UTF8)
-           || (PL_bostr = strpos, /* Used in regcopmaybe() */
-               ((t = reghopmaybe_c(s, -(prog->check_offset_max)))
-                && t > strpos)))) {
-       PL_bostr = tmp;
+           || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
+                && t > strpos))) {
        /* Fixed substring is found far enough so that the match
           cannot start at strpos. */
       try_at_offset:
@@ -661,7 +673,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        ++BmUSEFUL(prog->check_substr); /* hooray/5 */
     }
     else {
-       PL_bostr = tmp;
        /* The found string does not prohibit matching at strpos,
           - no optimization of calling REx engine can be performed,
           unless it was an MBOL and we are not after MBOL,
@@ -670,7 +681,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
        /* Even in this situation we may use MBOL flag if strpos is offset
           wrt the start of the string. */
        if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
-           && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n'
+           && (strpos != strbeg) && strpos[-1] != '\n'
            /* May be due to an implicit anchor of m{.*foo}  */
            && !(prog->reganch & ROPT_IMPLICIT))
        {
@@ -714,18 +725,21 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
           regstclass does not come from lookahead...  */
        /* If regstclass takes bytelength more than 1: If charlength==1, OK.
           This leaves EXACTF only, which is dealt with in find_byclass().  */
+       U8* str = (U8*)STRING(prog->regstclass);
        int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
-                   ? STR_LEN(prog->regstclass)
+                   ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
                    : 1);
        char *endpos = (prog->anchored_substr || ml_anch)
-               ? s + (prog->minlen? cl_l : 0)
-               : (prog->float_substr ? check_at - start_shift + cl_l
-                                     : strend) ;
-       char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s;
+               ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
+               : (prog->float_substr
+                  ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
+                          cl_l, strend)
+                  : strend);
+       char *startpos = strbeg;
 
        t = s;
        if (prog->reganch & ROPT_UTF8) {        
-           PL_regdata = prog->data;    /* Used by REGINCLASS UTF logic */
+           PL_regdata = prog->data;
            PL_bostr = startpos;
        }
         s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
@@ -747,8 +761,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                if (prog->anchored_substr == check) {
                    DEBUG_r( what = "anchored" );
                  hop_and_restart:
-                   PL_regeol = strend; /* Used in HOP() */
-                   s = HOPc(t, 1);
+                   s = HOP3c(t, 1, strend);
                    if (s + start_shift + end_shift > strend) {
                        /* XXXX Should be taken into account earlier? */
                        DEBUG_r( PerlIO_printf(Perl_debug_log,
@@ -827,25 +840,13 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta
        unsigned int c2;
        char *e;
        register I32 tmp = 1;   /* Scratch variable? */
+       register bool do_utf8 = DO_UTF8(PL_reg_sv);
 
        /* We know what class it must start with. */
        switch (OP(c)) {
-       case ANYOFUTF8:
-           while (s < strend) {
-               if (REGINCLASSUTF8(c, (U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
-                   else
-                       tmp = doevery;
-               }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
-           }
-           break;
        case ANYOF:
            while (s < strend) {
-               if (REGINCLASS(c, *(U8*)s)) {
+               if (reginclass(c, (U8*)s, do_utf8)) {
                    if (tmp && (norun || regtry(prog, s)))
                        goto got_it;
                    else
@@ -853,14 +854,20 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta
                }
                else
                    tmp = 1;
-               s++;
+               s += do_utf8 ? UTF8SKIP(s) : 1;
            }
            break;
        case EXACTF:
            m = STRING(c);
            ln = STR_LEN(c);
-           c1 = *(U8*)m;
-           c2 = PL_fold[c1];
+           if (UTF) {
+               c1 = to_utf8_lower((U8*)m);
+               c2 = to_utf8_upper((U8*)m);
+           }
+           else {
+               c1 = *(U8*)m;
+               c2 = PL_fold[c1];
+           }
            goto do_exactf;
        case EXACTFL:
            m = STRING(c);
@@ -872,62 +879,85 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta
 
            if (norun && e < s)
                e = s;                  /* Due to minlen logic of intuit() */
-           /* Here it is NOT UTF!  */
-           if (c1 == c2) {
-               while (s <= e) {
-                   if ( *(U8*)s == c1
-                        && (ln == 1 || !(OP(c) == EXACTF
-                                         ? ibcmp(s, m, ln)
-                                         : ibcmp_locale(s, m, ln)))
-                        && (norun || regtry(prog, s)) )
-                       goto got_it;
-                   s++;
-               }
-           } else {
-               while (s <= e) {
-                   if ( (*(U8*)s == c1 || *(U8*)s == c2)
-                        && (ln == 1 || !(OP(c) == EXACTF
-                                         ? ibcmp(s, m, ln)
-                                         : ibcmp_locale(s, m, ln)))
-                        && (norun || regtry(prog, s)) )
-                       goto got_it;
-                   s++;
-               }
+
+           if (do_utf8) {
+               STRLEN len;
+               if (c1 == c2)
+                   while (s <= e) {
+                       if ( utf8_to_uv_simple((U8*)s, &len) == c1
+                            && regtry(prog, s) )
+                           goto got_it;
+                       s += len;
+                   }
+               else
+                   while (s <= e) {
+                       UV c = utf8_to_uv_simple((U8*)s, &len);
+                       if ( (c == c1 || c == c2) && regtry(prog, s) )
+                           goto got_it;
+                       s += len;
+                   }
+           }
+           else {
+               if (c1 == c2)
+                   while (s <= e) {
+                       if ( *(U8*)s == c1
+                            && (ln == 1 || !(OP(c) == EXACTF
+                                             ? ibcmp(s, m, ln)
+                                             : ibcmp_locale(s, m, ln)))
+                            && (norun || regtry(prog, s)) )
+                           goto got_it;
+                       s++;
+                   }
+               else
+                   while (s <= e) {
+                       if ( (*(U8*)s == c1 || *(U8*)s == c2)
+                            && (ln == 1 || !(OP(c) == EXACTF
+                                             ? ibcmp(s, m, ln)
+                                             : ibcmp_locale(s, m, ln)))
+                            && (norun || regtry(prog, s)) )
+                           goto got_it;
+                       s++;
+                   }
            }
            break;
        case BOUNDL:
            PL_reg_flags |= RF_tainted;
            /* FALL THROUGH */
        case BOUND:
-           tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
-           tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
-           while (s < strend) {
-               if (tmp == !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
-                   tmp = !tmp;
-                   if ((norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               if (s == startpos)
+                   tmp = '\n';
+               else {
+                   U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
+                   
+                   tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0);
+               }
+               tmp = ((OP(c) == BOUND ?
+                       isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
+               while (s < strend) {
+                   if (tmp == !(OP(c) == BOUND ?
+                                swash_fetch(PL_utf8_alnum, (U8*)s) :
+                                isALNUM_LC_utf8((U8*)s)))
+                   {
+                       tmp = !tmp;
+                       if ((norun || regtry(prog, s)))
+                           goto got_it;
+                   }
+                   s += UTF8SKIP(s);
                }
-               s++;
            }
-           if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
-               goto got_it;
-           break;
-       case BOUNDLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case BOUNDUTF8:
-           tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), 0, 0) : '\n';
-           tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
-           while (s < strend) {
-               if (tmp == !(OP(c) == BOUNDUTF8 ?
-                            swash_fetch(PL_utf8_alnum, (U8*)s) :
-                            isALNUM_LC_utf8((U8*)s)))
-               {
-                   tmp = !tmp;
-                   if ((norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
+               tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
+               while (s < strend) {
+                   if (tmp ==
+                       !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
+                       tmp = !tmp;
+                       if ((norun || regtry(prog, s)))
+                           goto got_it;
+                   }
+                   s++;
                }
-               s += UTF8SKIP(s);
            }
            if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
                goto got_it;
@@ -936,358 +966,382 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta
            PL_reg_flags |= RF_tainted;
            /* FALL THROUGH */
        case NBOUND:
-           tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
-           tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
-           while (s < strend) {
-               if (tmp == !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
-                   tmp = !tmp;
-               else if ((norun || regtry(prog, s)))
-                   goto got_it;
-               s++;
+           if (do_utf8) {
+               if (s == startpos)
+                   tmp = '\n';
+               else {
+                   U8 *r = reghop3((U8*)s, -1, (U8*)startpos);
+                   
+                   tmp = (I32)utf8_to_uv(r, s - (char*)r, 0, 0);
+               }
+               tmp = ((OP(c) == NBOUND ?
+                       isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
+               while (s < strend) {
+                   if (tmp == !(OP(c) == NBOUND ?
+                                swash_fetch(PL_utf8_alnum, (U8*)s) :
+                                isALNUM_LC_utf8((U8*)s)))
+                       tmp = !tmp;
+                   else if ((norun || regtry(prog, s)))
+                       goto got_it;
+                   s += UTF8SKIP(s);
+               }
            }
-           if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
-               goto got_it;
-           break;
-       case NBOUNDLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case NBOUNDUTF8:
-           tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), 0, 0) : '\n';
-           tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
-           while (s < strend) {
-               if (tmp == !(OP(c) == NBOUNDUTF8 ?
-                            swash_fetch(PL_utf8_alnum, (U8*)s) :
-                            isALNUM_LC_utf8((U8*)s)))
-                   tmp = !tmp;
-               else if ((norun || regtry(prog, s)))
-                   goto got_it;
-               s += UTF8SKIP(s);
+           else {
+               tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
+               tmp = ((OP(c) == NBOUND ?
+                       isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
+               while (s < strend) {
+                   if (tmp ==
+                       !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
+                       tmp = !tmp;
+                   else if ((norun || regtry(prog, s)))
+                       goto got_it;
+                   s++;
+               }
            }
            if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
                goto got_it;
            break;
        case ALNUM:
-           while (s < strend) {
-               if (isALNUM(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (swash_fetch(PL_utf8_alnum, (U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case ALNUMUTF8:
-           while (s < strend) {
-               if (swash_fetch(PL_utf8_alnum, (U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isALNUM(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case ALNUML:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (isALNUM_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (isALNUM_LC_utf8((U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case ALNUMLUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (isALNUM_LC_utf8((U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isALNUM_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NALNUM:
-           while (s < strend) {
-               if (!isALNUM(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!swash_fetch(PL_utf8_alnum, (U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NALNUMUTF8:
-           while (s < strend) {
-               if (!swash_fetch(PL_utf8_alnum, (U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isALNUM(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NALNUML:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!isALNUM_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!isALNUM_LC_utf8((U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NALNUMLUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!isALNUM_LC_utf8((U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isALNUM_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case SPACE:
-           while (s < strend) {
-               if (isSPACE(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case SPACEUTF8:
-           while (s < strend) {
-               if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isSPACE(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case SPACEL:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (isSPACE_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case SPACELUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isSPACE_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NSPACE:
-           while (s < strend) {
-               if (!isSPACE(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s))) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NSPACEUTF8:
-           while (s < strend) {
-               if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s))) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isSPACE(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NSPACEL:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!isSPACE_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NSPACELUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isSPACE_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case DIGIT:
-           while (s < strend) {
-               if (isDIGIT(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (swash_fetch(PL_utf8_digit,(U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case DIGITUTF8:
-           while (s < strend) {
-               if (swash_fetch(PL_utf8_digit,(U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isDIGIT(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case DIGITL:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (isDIGIT_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (isDIGIT_LC_utf8((U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case DIGITLUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (isDIGIT_LC_utf8((U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (isDIGIT_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NDIGIT:
-           while (s < strend) {
-               if (!isDIGIT(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!swash_fetch(PL_utf8_digit,(U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NDIGITUTF8:
-           while (s < strend) {
-               if (!swash_fetch(PL_utf8_digit,(U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isDIGIT(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        case NDIGITL:
            PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!isDIGIT_LC(*s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           if (do_utf8) {
+               while (s < strend) {
+                   if (!isDIGIT_LC_utf8((U8*)s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s += UTF8SKIP(s);
                }
-               else
-                   tmp = 1;
-               s++;
            }
-           break;
-       case NDIGITLUTF8:
-           PL_reg_flags |= RF_tainted;
-           while (s < strend) {
-               if (!isDIGIT_LC_utf8((U8*)s)) {
-                   if (tmp && (norun || regtry(prog, s)))
-                       goto got_it;
+           else {
+               while (s < strend) {
+                   if (!isDIGIT_LC(*s)) {
+                       if (tmp && (norun || regtry(prog, s)))
+                           goto got_it;
+                       else
+                           tmp = doevery;
+                   }
                    else
-                       tmp = doevery;
+                       tmp = 1;
+                   s++;
                }
-               else
-                   tmp = 1;
-               s += UTF8SKIP(s);
            }
            break;
        default:
@@ -1311,7 +1365,6 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 /* data: May be used for some additional optimizations. */
 /* nosave: For optimizations. */
 {
-    dTHR;
     register char *s;
     register regnode *c;
     register char *startpos = stringarg;
@@ -1323,6 +1376,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     I32 scream_pos = -1;               /* Internal iterator of scream. */
     char *scream_olds;
     SV* oreplsv = GvSV(PL_replgv);
+    bool do_utf8 = DO_UTF8(sv);
 
     PL_regcc = 0;
 
@@ -1338,12 +1392,22 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     }
 
     minlen = prog->minlen;
-    if (strend - startpos < minlen) goto phooey;
+    if (do_utf8) {
+      if (utf8_distance((U8*)strend, (U8*)startpos) < minlen) goto phooey;
+    }
+    else {
+      if (strend - startpos < minlen) goto phooey;
+    }
 
     if (startpos == strbeg)    /* is ^ valid at stringarg? */
        PL_regprev = '\n';
     else {
-       PL_regprev = (U32)stringarg[-1];
+        if (prog->reganch & ROPT_UTF8 && do_utf8) {
+           U8 *s = reghop3((U8*)stringarg, -1, (U8*)strbeg);
+           PL_regprev = utf8_to_uv(s, (U8*)stringarg - s, NULL, 0);
+       }
+       else
+           PL_regprev = (U32)stringarg[-1];
        if (!PL_multiline && PL_regprev == '\n')
            PL_regprev = '\0';          /* force ^ to NOT match */
     }
@@ -1431,7 +1495,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 
            if (minlen)
                dontbother = minlen - 1;
-           end = HOPc(strend, -dontbother) - 1;
+           end = HOP3c(strend, -dontbother, strbeg) - 1;
            /* for multiline we only have to try after newlines */
            if (prog->check_substr) {
                if (s == startpos)
@@ -1477,7 +1541,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
        int did_match = 0;
 #endif
 
-       if (UTF) {
+       if (do_utf8) {
            while (s < strend) {
                if (*s == ch) {
                    DEBUG_r( did_match = 1 );
@@ -1506,18 +1570,19 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                              "Did not find anchored character...\n"));
     }
     /*SUPPRESS 560*/
-    else if (prog->anchored_substr != Nullsv
-            || (prog->float_substr != Nullsv 
-                && prog->float_max_offset < strend - s)) {
+    else if (do_utf8 == (UTF!=0) &&
+            (prog->anchored_substr != Nullsv
+             || (prog->float_substr != Nullsv 
+                 && prog->float_max_offset < strend - s))) {
        SV *must = prog->anchored_substr 
            ? prog->anchored_substr : prog->float_substr;
        I32 back_max = 
            prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
        I32 back_min = 
            prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
-       char *last = HOPc(strend,       /* Cannot start after this */
+       char *last = HOP3c(strend,      /* Cannot start after this */
                          -(I32)(CHR_SVLEN(must)
-                                - (SvTAIL(must) != 0) + back_min));
+                                - (SvTAIL(must) != 0) + back_min), strbeg);
        char *last1;            /* Last position checked before */
 #ifdef DEBUGGING
        int did_match = 0;
@@ -1535,9 +1600,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
        strend = HOPc(strend, -dontbother);
        while ( (s <= last) &&
                ((flags & REXEC_SCREAM) 
-                ? (s = screaminstr(sv, must, HOPc(s, back_min) - strbeg,
+                ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
                                    end_shift, &scream_pos, 0))
-                : (s = fbm_instr((unsigned char*)HOP(s, back_min),
+                : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
                                  (unsigned char*)strend, must, 
                                  PL_multiline ? FBMrf_MULTILINE : 0))) ) {
            DEBUG_r( did_match = 1 );
@@ -1551,7 +1616,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                last1 = HOPc(s, -back_min);
                s = t;          
            }
-           if (UTF) {
+           if (do_utf8) {
                while (s <= last1) {
                    if (regtry(prog, s))
                        goto got_it;
@@ -1580,6 +1645,11 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
        if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT)
            /* don't bother with what can't match */
            strend = HOPc(strend, -(minlen - 1));
+       DEBUG_r({
+           SV *prop = sv_newmortal();
+           regprop(prop, c);
+           PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), s);
+       });
        if (find_byclass(prog, c, s, strend, startpos, 0))
            goto got_it;
        DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
@@ -1593,7 +1663,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                last = screaminstr(sv, prog->float_substr, s - strbeg,
                                   end_shift, &scream_pos, 1); /* last one */
                if (!last)
-                   last = scream_olds; /* Only one occurence. */
+                   last = scream_olds; /* Only one occurrence. */
            }
            else {
                STRLEN len;
@@ -1627,7 +1697,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
            dontbother = minlen - 1;
        strend -= dontbother;              /* this one's always in bytes! */
        /* We don't know much -- general case. */
-       if (UTF) {
+       if (do_utf8) {
            for (;;) {
                if (regtry(prog, s))
                    goto got_it;
@@ -1695,12 +1765,14 @@ phooey:
 STATIC I32                     /* 0 failure, 1 success */
 S_regtry(pTHX_ regexp *prog, char *startpos)
 {
-    dTHR;
     register I32 i;
     register I32 *sp;
     register I32 *ep;
     CHECKPOINT lastcp;
 
+#ifdef DEBUGGING
+    PL_regindent = 0;  /* XXXX Not good when matches are reenterable... */
+#endif
     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
        MAGIC *mg;
 
@@ -1772,24 +1844,67 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
 
     /* XXXX What this code is doing here?!!!  There should be no need
        to do this again and again, PL_reglastparen should take care of
-       this!  */
+       this!  --ilya*/
+
+    /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
+     * Actually, the code in regcppop() (which Ilya may be meaning by
+     * PL_reglastparen), is not needed at all by the test suite
+     * (op/regexp, op/pat, op/split), but that code is needed, oddly
+     * enough, for building DynaLoader, or otherwise this
+     * "Error: '*' not in typemap in DynaLoader.xs, line 164"
+     * will happen.  Meanwhile, this code *is* needed for the
+     * above-mentioned test suite tests to succeed.  The common theme
+     * on those tests seems to be returning null fields from matches.
+     * --jhi */
+#if 1
     sp = prog->startp;
     ep = prog->endp;
     if (prog->nparens) {
-       for (i = prog->nparens; i >= 1; i--) {
+       for (i = prog->nparens; i > *PL_reglastparen; i--) {
            *++sp = -1;
            *++ep = -1;
        }
     }
-    REGCP_SET;
+#endif
+    REGCP_SET(lastcp);
     if (regmatch(prog->program + 1)) {
        prog->endp[0] = PL_reginput - PL_bostr;
        return 1;
     }
-    REGCP_UNWIND;
+    REGCP_UNWIND(lastcp);
     return 0;
 }
 
+#define RE_UNWIND_BRANCH       1
+#define RE_UNWIND_BRANCHJ      2
+
+union re_unwind_t;
+
+typedef struct {               /* XX: makes sense to enlarge it... */
+    I32 type;
+    I32 prev;
+    CHECKPOINT lastcp;
+} re_unwind_generic_t;
+
+typedef struct {
+    I32 type;
+    I32 prev;
+    CHECKPOINT lastcp;
+    I32 lastparen;
+    regnode *next;
+    char *locinput;
+    I32 nextchr;
+#ifdef DEBUGGING
+    int regindent;
+#endif
+} re_unwind_branch_t;
+
+typedef union re_unwind_t {
+    I32 type;
+    re_unwind_generic_t generic;
+    re_unwind_branch_t branch;
+} re_unwind_t;
+
 /*
  - regmatch - main matching routine
  *
@@ -1807,7 +1922,6 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
 STATIC I32                     /* 0 failure, 1 success */
 S_regmatch(pTHX_ regnode *prog)
 {
-    dTHR;
     register regnode *scan;    /* Current node. */
     regnode *next;             /* Next node. */
     regnode *inner;            /* Next node in internal branch. */
@@ -1819,6 +1933,10 @@ S_regmatch(pTHX_ regnode *prog)
     register char *locinput = PL_reginput;
     register I32 c1, c2, paren;        /* case fold search, parenth */
     int minmod = 0, sw = 0, logical = 0;
+    I32 unwind = 0;
+    I32 firstcp = PL_savestack_ix;
+    register bool do_utf8 = DO_UTF8(PL_reg_sv);
+
 #ifdef DEBUGGING
     PL_regindent++;
 #endif
@@ -1828,7 +1946,7 @@ S_regmatch(pTHX_ regnode *prog)
     scan = prog;
     while (scan != NULL) {
 #define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO)
-#ifdef DEBUGGING
+#if 1
 #  define sayYES goto yes
 #  define sayNO goto no
 #  define sayYES_FINAL goto yes_final
@@ -1850,20 +1968,25 @@ S_regmatch(pTHX_ regnode *prog)
            SV *prop = sv_newmortal();
            int docolor = *PL_colors[0];
            int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
-           int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput);
+           int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
            /* The part of the string before starttry has one color
               (pref0_len chars), between starttry and current
               position another one (pref_len - pref0_len chars),
               after the current position the third one.
               We assume that pref0_len <= pref_len, otherwise we
               decrease pref0_len.  */
-           int pref_len = (locinput - PL_bostr > (5 + taill) - l 
-                           ? (5 + taill) - l : locinput - PL_bostr);
-           int pref0_len = pref_len  - (locinput - PL_reg_starttry);
+           int pref_len = (locinput - PL_bostr) > (5 + taill) - l 
+               ? (5 + taill) - l : locinput - PL_bostr;
+           int pref0_len;
 
+           while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
+               pref_len++;
+           pref0_len = pref_len  - (locinput - PL_reg_starttry);
            if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
                l = ( PL_regeol - locinput > (5 + taill) - pref_len 
                      ? (5 + taill) - pref_len : PL_regeol - locinput);
+           while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
+               l--;
            if (pref0_len < 0)
                pref0_len = 0;
            if (pref0_len > pref_len)
@@ -1936,8 +2059,8 @@ S_regmatch(pTHX_ regnode *prog)
            if (PL_regeol != locinput)
                sayNO;
            break;
-       case SANYUTF8:
-           if (nextchr & 0x80) {
+       case SANY:
+           if (do_utf8) {
                locinput += PL_utf8skip[nextchr];
                if (locinput > PL_regeol)
                    sayNO;
@@ -1948,31 +2071,47 @@ S_regmatch(pTHX_ regnode *prog)
                sayNO;
            nextchr = UCHARAT(++locinput);
            break;
-       case SANY:
-           if (!nextchr && locinput >= PL_regeol)
+       case REG_ANY:
+           if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
                sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case ANYUTF8:
-           if (nextchr & 0x80) {
+           if (do_utf8) {
                locinput += PL_utf8skip[nextchr];
                if (locinput > PL_regeol)
                    sayNO;
                nextchr = UCHARAT(locinput);
-               break;
            }
-           if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case REG_ANY:
-           if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
-               sayNO;
-           nextchr = UCHARAT(++locinput);
+           else
+               nextchr = UCHARAT(++locinput);
            break;
        case EXACT:
            s = STRING(scan);
            ln = STR_LEN(scan);
+           if (do_utf8 != (UTF!=0)) {
+               char *l = locinput;
+               char *e = s + ln;
+               STRLEN len;
+               if (do_utf8)
+                   while (s < e) {
+                       if (l >= PL_regeol)
+                           sayNO;
+                       if (*((U8*)s) != utf8_to_uv_simple((U8*)l, &len))
+                           sayNO;
+                       s++;
+                       l += len;
+                   }
+               else
+                   while (s < e) {
+                       if (l >= PL_regeol)
+                           sayNO;
+                       if (*((U8*)l) != utf8_to_uv_simple((U8*)s, &len))
+                           sayNO;
+                       s += len;
+                       l++;
+                   }
+               locinput = l;
+               nextchr = UCHARAT(locinput);
+               break;
+           }
            /* Inline the first character, for speed. */
            if (UCHARAT(s) != nextchr)
                sayNO;
@@ -1990,20 +2129,19 @@ S_regmatch(pTHX_ regnode *prog)
            s = STRING(scan);
            ln = STR_LEN(scan);
 
-           if (UTF) {
+           if (do_utf8) {
                char *l = locinput;
-               char *e = s + ln;
+               char *e;
+               e = s + ln;
                c1 = OP(scan) == EXACTF;
                while (s < e) {
-                   if (l >= PL_regeol)
-                       sayNO;
-                   if (utf8_to_uv_chk((U8*)s, 0, 0) != (c1 ?
-                                                 toLOWER_utf8((U8*)l) :
-                                                 toLOWER_LC_utf8((U8*)l)))
-                   {
+                   if (l >= PL_regeol) {
                        sayNO;
                    }
-                   s += UTF8SKIP(s);
+                   if ((UTF ? utf8_to_uv((U8*)s, e - s, 0, 0) : *((U8*)s)) !=
+                       (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l)))
+                           sayNO;
+                   s += UTF ? UTF8SKIP(s) : 1;
                    l += UTF8SKIP(l);
                }
                locinput = l;
@@ -2025,22 +2163,24 @@ S_regmatch(pTHX_ regnode *prog)
            locinput += ln;
            nextchr = UCHARAT(locinput);
            break;
-       case ANYOFUTF8:
-           if (!REGINCLASSUTF8(scan, (U8*)locinput))
-               sayNO;
-           if (locinput >= PL_regeol)
-               sayNO;
-           locinput += PL_utf8skip[nextchr];
-           nextchr = UCHARAT(locinput);
-           break;
        case ANYOF:
-           if (nextchr < 0)
+           if (do_utf8) {
+               if (!reginclass(scan, (U8*)locinput, do_utf8))
+                   sayNO;
+               if (locinput >= PL_regeol)
+                   sayNO;
+               locinput += PL_utf8skip[nextchr];
                nextchr = UCHARAT(locinput);
-           if (!REGINCLASS(scan, nextchr))
-               sayNO;
-           if (!nextchr && locinput >= PL_regeol)
-               sayNO;
-           nextchr = UCHARAT(++locinput);
+           }
+           else {
+               if (nextchr < 0)
+                   nextchr = UCHARAT(locinput);
+               if (!reginclass(scan, (U8*)locinput, do_utf8))
+                   sayNO;
+               if (!nextchr && locinput >= PL_regeol)
+                   sayNO;
+               nextchr = UCHARAT(++locinput);
+           }
            break;
        case ALNUML:
            PL_reg_flags |= RF_tainted;
@@ -2048,19 +2188,8 @@ S_regmatch(pTHX_ regnode *prog)
        case ALNUM:
            if (!nextchr)
                sayNO;
-           if (!(OP(scan) == ALNUM
-                 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case ALNUMLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case ALNUMUTF8:
-           if (!nextchr)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (!(OP(scan) == ALNUMUTF8
+           if (do_utf8) {
+               if (!(OP(scan) == ALNUM
                      ? swash_fetch(PL_utf8_alnum, (U8*)locinput)
                      : isALNUM_LC_utf8((U8*)locinput)))
                {
@@ -2070,7 +2199,7 @@ S_regmatch(pTHX_ regnode *prog)
                nextchr = UCHARAT(locinput);
                break;
            }
-           if (!(OP(scan) == ALNUMUTF8
+           if (!(OP(scan) == ALNUM
                  ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
                sayNO;
            nextchr = UCHARAT(++locinput);
@@ -2081,19 +2210,8 @@ S_regmatch(pTHX_ regnode *prog)
        case NALNUM:
            if (!nextchr && locinput >= PL_regeol)
                sayNO;
-           if (OP(scan) == NALNUM
-               ? isALNUM(nextchr) : isALNUM_LC(nextchr))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case NALNUMLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case NALNUMUTF8:
-           if (!nextchr && locinput >= PL_regeol)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (OP(scan) == NALNUMUTF8
+           if (do_utf8) {
+               if (OP(scan) == NALNUM
                    ? swash_fetch(PL_utf8_alnum, (U8*)locinput)
                    : isALNUM_LC_utf8((U8*)locinput))
                {
@@ -2103,7 +2221,7 @@ S_regmatch(pTHX_ regnode *prog)
                nextchr = UCHARAT(locinput);
                break;
            }
-           if (OP(scan) == NALNUMUTF8
+           if (OP(scan) == NALNUM
                ? isALNUM(nextchr) : isALNUM_LC(nextchr))
                sayNO;
            nextchr = UCHARAT(++locinput);
@@ -2115,37 +2233,38 @@ S_regmatch(pTHX_ regnode *prog)
        case BOUND:
        case NBOUND:
            /* was last char in word? */
-           ln = (locinput != PL_regbol) ? UCHARAT(locinput - 1) : PL_regprev;
-           if (OP(scan) == BOUND || OP(scan) == NBOUND) {
-               ln = isALNUM(ln);
-               n = isALNUM(nextchr);
-           }
-           else {
-               ln = isALNUM_LC(ln);
-               n = isALNUM_LC(nextchr);
-           }
-           if (((!ln) == (!n)) == (OP(scan) == BOUND || OP(scan) == BOUNDL))
-               sayNO;
-           break;
-       case BOUNDLUTF8:
-       case NBOUNDLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case BOUNDUTF8:
-       case NBOUNDUTF8:
-           /* was last char in word? */
-           ln = (locinput != PL_regbol)
-               ? utf8_to_uv_chk(reghop((U8*)locinput, -1), 0, 0) : PL_regprev;
-           if (OP(scan) == BOUNDUTF8 || OP(scan) == NBOUNDUTF8) {
-               ln = isALNUM_uni(ln);
-               n = swash_fetch(PL_utf8_alnum, (U8*)locinput);
+           if (do_utf8) {
+               if (locinput == PL_regbol)
+                   ln = PL_regprev;
+               else {
+                   U8 *r = reghop((U8*)locinput, -1);
+                   
+                   ln = utf8_to_uv(r, s - (char*)r, 0, 0);
+               }
+               if (OP(scan) == BOUND || OP(scan) == NBOUND) {
+                   ln = isALNUM_uni(ln);
+                   n = swash_fetch(PL_utf8_alnum, (U8*)locinput);
+               }
+               else {
+                   ln = isALNUM_LC_uni(ln);
+                   n = isALNUM_LC_utf8((U8*)locinput);
+               }
            }
            else {
-               ln = isALNUM_LC_uni(ln);
-               n = isALNUM_LC_utf8((U8*)locinput);
+               ln = (locinput != PL_regbol) ?
+                   UCHARAT(locinput - 1) : PL_regprev;
+               if (OP(scan) == BOUND || OP(scan) == NBOUND) {
+                   ln = isALNUM(ln);
+                   n = isALNUM(nextchr);
+               }
+               else {
+                   ln = isALNUM_LC(ln);
+                   n = isALNUM_LC(nextchr);
+               }
            }
-           if (((!ln) == (!n)) == (OP(scan) == BOUNDUTF8 || OP(scan) == BOUNDLUTF8))
-               sayNO;
+           if (((!ln) == (!n)) == (OP(scan) == BOUND ||
+                                   OP(scan) == BOUNDL))
+                   sayNO;
            break;
        case SPACEL:
            PL_reg_flags |= RF_tainted;
@@ -2153,32 +2272,29 @@ S_regmatch(pTHX_ regnode *prog)
        case SPACE:
            if (!nextchr)
                sayNO;
-           if (!(OP(scan) == SPACE
-                 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case SPACELUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case SPACEUTF8:
-           if (!nextchr)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (!(OP(scan) == SPACEUTF8
-                     ? swash_fetch(PL_utf8_space, (U8*)locinput)
-                     : isSPACE_LC_utf8((U8*)locinput)))
-               {
-                   sayNO;
+           if (do_utf8) {
+               if (UTF8_IS_CONTINUED(nextchr)) {
+                   if (!(OP(scan) == SPACE
+                         ? swash_fetch(PL_utf8_space, (U8*)locinput)
+                         : isSPACE_LC_utf8((U8*)locinput)))
+                   {
+                       sayNO;
+                   }
+                   locinput += PL_utf8skip[nextchr];
+                   nextchr = UCHARAT(locinput);
+                   break;
                }
-               locinput += PL_utf8skip[nextchr];
-               nextchr = UCHARAT(locinput);
-               break;
+               if (!(OP(scan) == SPACE
+                     ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
+                   sayNO;
+               nextchr = UCHARAT(++locinput);
+           }
+           else {
+               if (!(OP(scan) == SPACE
+                     ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
+                   sayNO;
+               nextchr = UCHARAT(++locinput);
            }
-           if (!(OP(scan) == SPACEUTF8
-                 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
            break;
        case NSPACEL:
            PL_reg_flags |= RF_tainted;
@@ -2186,19 +2302,8 @@ S_regmatch(pTHX_ regnode *prog)
        case NSPACE:
            if (!nextchr && locinput >= PL_regeol)
                sayNO;
-           if (OP(scan) == NSPACE
-               ? isSPACE(nextchr) : isSPACE_LC(nextchr))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case NSPACELUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case NSPACEUTF8:
-           if (!nextchr && locinput >= PL_regeol)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (OP(scan) == NSPACEUTF8
+           if (do_utf8) {
+               if (OP(scan) == NSPACE
                    ? swash_fetch(PL_utf8_space, (U8*)locinput)
                    : isSPACE_LC_utf8((U8*)locinput))
                {
@@ -2208,7 +2313,7 @@ S_regmatch(pTHX_ regnode *prog)
                nextchr = UCHARAT(locinput);
                break;
            }
-           if (OP(scan) == NSPACEUTF8
+           if (OP(scan) == NSPACE
                ? isSPACE(nextchr) : isSPACE_LC(nextchr))
                sayNO;
            nextchr = UCHARAT(++locinput);
@@ -2219,19 +2324,8 @@ S_regmatch(pTHX_ regnode *prog)
        case DIGIT:
            if (!nextchr)
                sayNO;
-           if (!(OP(scan) == DIGIT
-                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case DIGITLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case DIGITUTF8:
-           if (!nextchr)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (!(OP(scan) == DIGITUTF8
+           if (do_utf8) {
+               if (!(OP(scan) == DIGIT
                      ? swash_fetch(PL_utf8_digit, (U8*)locinput)
                      : isDIGIT_LC_utf8((U8*)locinput)))
                {
@@ -2241,7 +2335,7 @@ S_regmatch(pTHX_ regnode *prog)
                nextchr = UCHARAT(locinput);
                break;
            }
-           if (!(OP(scan) == DIGITUTF8
+           if (!(OP(scan) == DIGIT
                  ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
                sayNO;
            nextchr = UCHARAT(++locinput);
@@ -2252,19 +2346,8 @@ S_regmatch(pTHX_ regnode *prog)
        case NDIGIT:
            if (!nextchr && locinput >= PL_regeol)
                sayNO;
-           if (OP(scan) == NDIGIT
-               ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
-               sayNO;
-           nextchr = UCHARAT(++locinput);
-           break;
-       case NDIGITLUTF8:
-           PL_reg_flags |= RF_tainted;
-           /* FALL THROUGH */
-       case NDIGITUTF8:
-           if (!nextchr && locinput >= PL_regeol)
-               sayNO;
-           if (nextchr & 0x80) {
-               if (OP(scan) == NDIGITUTF8
+           if (do_utf8) {
+               if (OP(scan) == NDIGIT
                    ? swash_fetch(PL_utf8_digit, (U8*)locinput)
                    : isDIGIT_LC_utf8((U8*)locinput))
                {
@@ -2274,7 +2357,7 @@ S_regmatch(pTHX_ regnode *prog)
                nextchr = UCHARAT(locinput);
                break;
            }
-           if (OP(scan) == NDIGITUTF8
+           if (OP(scan) == NDIGIT
                ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
                sayNO;
            nextchr = UCHARAT(++locinput);
@@ -2303,7 +2386,7 @@ S_regmatch(pTHX_ regnode *prog)
                break;
 
            s = PL_bostr + ln;
-           if (UTF && OP(scan) != REF) {       /* REF can do byte comparison */
+           if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
                char *l = locinput;
                char *e = PL_bostr + PL_regendp[n];
                /*
@@ -2408,7 +2491,6 @@ S_regmatch(pTHX_ regnode *prog)
                        I32 onpar = PL_regnpar;
 
                        pm.op_pmflags = 0;
-                       pm.op_pmdynflags = (UTF||DO_UTF8(ret) ? PMdf_UTF8 : 0);
                        re = CALLREGCOMP(aTHX_ t, t + len, &pm);
                        if (!(SvFLAGS(ret) 
                              & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
@@ -2433,7 +2515,7 @@ S_regmatch(pTHX_ regnode *prog)
                    PL_regcc = 0;
                    
                    cp = regcppush(0);  /* Save *all* the positions. */
-                   REGCP_SET;
+                   REGCP_SET(lastcp);
                    cache_re(re);
                    state.ss = PL_savestack_ix;
                    *PL_reglastparen = 0;
@@ -2463,7 +2545,7 @@ S_regmatch(pTHX_ regnode *prog)
                        sayYES;
                    }
                    ReREFCNT_dec(re);
-                   REGCP_UNWIND;
+                   REGCP_UNWIND(lastcp);
                    regcppop();
                    PL_reg_call_cc = state.prev;
                    PL_regcc = state.cc;
@@ -2590,12 +2672,18 @@ S_regmatch(pTHX_ regnode *prog)
        case CURLYX: {
                CURCUR cc;
                CHECKPOINT cp = PL_savestack_ix;
+               /* No need to save/restore up to this paren */
+               I32 parenfloor = scan->flags;
 
                if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
                    next += ARG(next);
                cc.oldcc = PL_regcc;
                PL_regcc = &cc;
-               cc.parenfloor = *PL_reglastparen;
+               /* XXXX Probably it is better to teach regpush to support
+                  parenfloor > PL_regsize... */
+               if (parenfloor > *PL_reglastparen)
+                   parenfloor = *PL_reglastparen; /* Pessimization... */
+               cc.parenfloor = parenfloor;
                cc.cur = -1;
                cc.min = ARG1(scan);
                cc.max  = ARG2(scan);
@@ -2718,12 +2806,12 @@ S_regmatch(pTHX_ regnode *prog)
                    if (PL_regcc)
                        ln = PL_regcc->cur;
                    cp = regcppush(cc->parenfloor);
-                   REGCP_SET;
+                   REGCP_SET(lastcp);
                    if (regmatch(cc->next)) {
                        regcpblow(cp);
                        sayYES; /* All done. */
                    }
-                   REGCP_UNWIND;
+                   REGCP_UNWIND(lastcp);
                    regcppop();
                    if (PL_regcc)
                        PL_regcc->cur = ln;
@@ -2750,12 +2838,12 @@ S_regmatch(pTHX_ regnode *prog)
                    cc->cur = n;
                    cc->lastloc = locinput;
                    cp = regcppush(cc->parenfloor);
-                   REGCP_SET;
+                   REGCP_SET(lastcp);
                    if (regmatch(cc->scan)) {
                        regcpblow(cp);
                        sayYES;
                    }
-                   REGCP_UNWIND;
+                   REGCP_UNWIND(lastcp);
                    regcppop();
                    cc->cur = n - 1;
                    cc->lastloc = lastloc;
@@ -2768,12 +2856,12 @@ S_regmatch(pTHX_ regnode *prog)
                    cp = regcppush(cc->parenfloor);
                    cc->cur = n;
                    cc->lastloc = locinput;
-                   REGCP_SET;
+                   REGCP_SET(lastcp);
                    if (regmatch(cc->scan)) {
                        regcpblow(cp);
                        sayYES;
                    }
-                   REGCP_UNWIND;
+                   REGCP_UNWIND(lastcp);
                    regcppop();         /* Restore some previous $<digit>s? */
                    PL_reginput = locinput;
                    DEBUG_r(
@@ -2819,30 +2907,30 @@ S_regmatch(pTHX_ regnode *prog)
                if (OP(next) != c1)     /* No choice. */
                    next = inner;       /* Avoid recursion. */
                else {
-                   int lastparen = *PL_reglastparen;
+                   I32 lastparen = *PL_reglastparen;
+                   I32 unwind1;
+                   re_unwind_branch_t *uw;
+
+                   /* Put unwinding data on stack */
+                   unwind1 = SSNEWt(1,re_unwind_branch_t);
+                   uw = SSPTRt(unwind1,re_unwind_branch_t);
+                   uw->prev = unwind;
+                   unwind = unwind1;
+                   uw->type = ((c1 == BRANCH)
+                               ? RE_UNWIND_BRANCH
+                               : RE_UNWIND_BRANCHJ);
+                   uw->lastparen = lastparen;
+                   uw->next = next;
+                   uw->locinput = locinput;
+                   uw->nextchr = nextchr;
+#ifdef DEBUGGING
+                   uw->regindent = ++PL_regindent;
+#endif
 
-                   REGCP_SET;
-                   do {
-                       PL_reginput = locinput;
-                       if (regmatch(inner))
-                           sayYES;
-                       REGCP_UNWIND;
-                       for (n = *PL_reglastparen; n > lastparen; n--)
-                           PL_regendp[n] = -1;
-                       *PL_reglastparen = n;
-                       scan = next;
-                       /*SUPPRESS 560*/
-                       if ((n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next))))
-                           next += n;
-                       else
-                           next = NULL;
-                       inner = NEXTOPER(scan);
-                       if (c1 == BRANCHJ) {
-                           inner = NEXTOPER(inner);
-                       }
-                   } while (scan != NULL && OP(scan) == c1);
-                   sayNO;
-                   /* NOTREACHED */
+                   REGCP_SET(uw->lastcp);
+
+                   /* Now go into the first branch */
+                   next = inner;
                }
            }
            break;
@@ -2892,7 +2980,7 @@ S_regmatch(pTHX_ regnode *prog)
                }
                else
                    c1 = c2 = -1000;
-               REGCP_SET;
+               REGCP_SET(lastcp);
                /* This may be improved if l == 0.  */
                while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
                    /* If it could work, try it. */
@@ -2911,7 +2999,7 @@ S_regmatch(pTHX_ regnode *prog)
                        }
                        if (regmatch(next))
                            sayYES;
-                       REGCP_UNWIND;
+                       REGCP_UNWIND(lastcp);
                    }
                    /* Couldn't or didn't -- move forward. */
                    PL_reginput = locinput;
@@ -2951,7 +3039,7 @@ S_regmatch(pTHX_ regnode *prog)
                    else
                        c1 = c2 = -1000;
                }
-               REGCP_SET;
+               REGCP_SET(lastcp);
                while (n >= ln) {
                    /* If it could work, try it. */
                    if (c1 == -1000 ||
@@ -2973,7 +3061,7 @@ S_regmatch(pTHX_ regnode *prog)
                        }
                        if (regmatch(next))
                            sayYES;
-                       REGCP_UNWIND;
+                       REGCP_UNWIND(lastcp);
                    }
                    /* Couldn't or didn't -- back up. */
                    n--;
@@ -3017,13 +3105,23 @@ S_regmatch(pTHX_ regnode *prog)
            * when we know what character comes next.
            */
            if (PL_regkind[(U8)OP(next)] == EXACT) {
-               c1 = (U8)*STRING(next);
-               if (OP(next) == EXACTF)
-                   c2 = PL_fold[c1];
-               else if (OP(next) == EXACTFL)
-                   c2 = PL_fold_locale[c1];
-               else
-                   c2 = c1;
+               U8 *s = (U8*)STRING(next);
+               if (!UTF) {
+                   c2 = c1 = *s;
+                   if (OP(next) == EXACTF)
+                       c2 = PL_fold[c1];
+                   else if (OP(next) == EXACTFL)
+                       c2 = PL_fold_locale[c1];
+               }
+               else { /* UTF */
+                   if (OP(next) == EXACTF) {
+                       c1 = to_utf8_lower(s);
+                       c2 = to_utf8_upper(s);
+                   }
+                   else {
+                       c2 = c1 = utf8_to_uv_simple(s, NULL);
+                   }
+               }
            }
            else
                c1 = c2 = -1000;
@@ -3034,50 +3132,95 @@ S_regmatch(pTHX_ regnode *prog)
                if (ln && regrepeat(scan, ln) < ln)
                    sayNO;
                locinput = PL_reginput;
-               REGCP_SET;
+               REGCP_SET(lastcp);
                if (c1 != -1000) {
-                   char *e = locinput + n - ln; /* Should not check after this */
+                   char *e; /* Should not check after this */
                    char *old = locinput;
 
-                   if (e >= PL_regeol || (n == REG_INFTY))
+                   if  (n == REG_INFTY) {
                        e = PL_regeol - 1;
+                       if (do_utf8)
+                           while (UTF8_IS_CONTINUATION(*(U8*)e))
+                               e--;
+                   }
+                   else if (do_utf8) {
+                       int m = n - ln;
+                       for (e = locinput;
+                            m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
+                           e += UTF8SKIP(e);
+                   }
+                   else {
+                       e = locinput + n - ln;
+                       if (e >= PL_regeol)
+                           e = PL_regeol - 1;
+                   }
                    while (1) {
+                       int count;
                        /* Find place 'next' could work */
-                       if (c1 == c2) {
-                           while (locinput <= e && *locinput != c1)
-                               locinput++;
-                       } else {
-                           while (locinput <= e 
-                                  && *locinput != c1
-                                  && *locinput != c2)
-                               locinput++;                         
+                       if (!do_utf8) {
+                           if (c1 == c2) {
+                               while (locinput <= e && *locinput != c1)
+                                   locinput++;
+                           } else {
+                               while (locinput <= e 
+                                      && *locinput != c1
+                                      && *locinput != c2)
+                                   locinput++;
+                           }
+                           count = locinput - old;
+                       }
+                       else {
+                           STRLEN len;
+                           if (c1 == c2) {
+                               for (count = 0;
+                                    locinput <= e &&
+                                        utf8_to_uv_simple((U8*)locinput, &len) != c1;
+                                    count++)
+                                   locinput += len;
+                               
+                           } else {
+                               for (count = 0; locinput <= e; count++) {
+                                   UV c = utf8_to_uv_simple((U8*)locinput, &len);
+                                   if (c == c1 || c == c2)
+                                       break;
+                                   locinput += len;                        
+                               }
+                           }
                        }
                        if (locinput > e) 
                            sayNO;
                        /* PL_reginput == old now */
                        if (locinput != old) {
                            ln = 1;     /* Did some */
-                           if (regrepeat(scan, locinput - old) <
-                                locinput - old)
+                           if (regrepeat(scan, count) < count)
                                sayNO;
                        }
                        /* PL_reginput == locinput now */
                        TRYPAREN(paren, ln, locinput);
                        PL_reginput = locinput; /* Could be reset... */
-                       REGCP_UNWIND;
+                       REGCP_UNWIND(lastcp);
                        /* Couldn't or didn't -- move forward. */
-                       old = locinput++;
+                       old = locinput;
+                       if (do_utf8)
+                           locinput += UTF8SKIP(locinput);
+                       else
+                           locinput++;
                    }
                }
                else
                while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
+                   UV c;
+                   if (c1 != -1000) {
+                       if (do_utf8)
+                           c = utf8_to_uv_simple((U8*)PL_reginput, NULL);
+                       else
+                           c = UCHARAT(PL_reginput); 
+                   }
                    /* If it could work, try it. */
-                   if (c1 == -1000 ||
-                       UCHARAT(PL_reginput) == c1 ||
-                       UCHARAT(PL_reginput) == c2)
+                   if (c1 == -1000 || c == c1 || c == c2)
                    {
                        TRYPAREN(paren, n, PL_reginput);
-                       REGCP_UNWIND;
+                       REGCP_UNWIND(lastcp);
                    }
                    /* Couldn't or didn't -- move forward. */
                    PL_reginput = locinput;
@@ -3102,16 +3245,21 @@ S_regmatch(pTHX_ regnode *prog)
                    if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
                        ln--;
                }
-               REGCP_SET;
+               REGCP_SET(lastcp);
                if (paren) {
+                   UV c;
                    while (n >= ln) {
+                       if (c1 != -1000) {
+                           if (do_utf8)
+                               c = utf8_to_uv_simple((U8*)PL_reginput, NULL);
+                           else
+                               c = UCHARAT(PL_reginput); 
+                       }
                        /* If it could work, try it. */
-                       if (c1 == -1000 ||
-                           UCHARAT(PL_reginput) == c1 ||
-                           UCHARAT(PL_reginput) == c2)
+                       if (c1 == -1000 || c == c1 || c == c2)
                            {
                                TRYPAREN(paren, n, PL_reginput);
-                               REGCP_UNWIND;
+                               REGCP_UNWIND(lastcp);
                            }
                        /* Couldn't or didn't -- back up. */
                        n--;
@@ -3119,14 +3267,19 @@ S_regmatch(pTHX_ regnode *prog)
                    }
                }
                else {
+                   UV c;
                    while (n >= ln) {
+                       if (c1 != -1000) {
+                           if (do_utf8)
+                               c = utf8_to_uv_simple((U8*)PL_reginput, NULL);
+                           else
+                               c = UCHARAT(PL_reginput); 
+                       }
                        /* If it could work, try it. */
-                       if (c1 == -1000 ||
-                           UCHARAT(PL_reginput) == c1 ||
-                           UCHARAT(PL_reginput) == c2)
+                       if (c1 == -1000 || c == c1 || c == c2)
                            {
                                TRYPAREN(paren, n, PL_reginput);
-                               REGCP_UNWIND;
+                               REGCP_UNWIND(lastcp);
                            }
                        /* Couldn't or didn't -- back up. */
                        n--;
@@ -3144,7 +3297,7 @@ S_regmatch(pTHX_ regnode *prog)
                CHECKPOINT cp, lastcp;
                
                cp = regcppush(0);      /* Save *all* the positions. */
-               REGCP_SET;
+               REGCP_SET(lastcp);
                regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
                                                    the caller. */
                PL_reginput = locinput; /* Make position available to
@@ -3157,7 +3310,7 @@ S_regmatch(pTHX_ regnode *prog)
                    regcpblow(cp);
                    sayYES;
                }
-               REGCP_UNWIND;
+               REGCP_UNWIND(lastcp);
                regcppop();
                PL_reg_call_cc = cur_call_cc;
                PL_regcc = cctmp;
@@ -3264,6 +3417,7 @@ S_regmatch(pTHX_ regnode *prog)
                          PTR2UV(scan), OP(scan));
            Perl_croak(aTHX_ "regexp memory corruption");
        }
+      reenter:
        scan = next;
     }
 
@@ -3289,6 +3443,11 @@ yes:
 #ifdef DEBUGGING
     PL_regindent--;
 #endif
+
+#if 0                                  /* Breaks $^R */
+    if (unwind)
+       regcpblow(firstcp);
+#endif
     return 1;
 
 no:
@@ -3300,6 +3459,55 @@ no:
     goto do_no;
 no_final:
 do_no:
+    if (unwind) {
+       re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
+
+       switch (uw->type) {
+       case RE_UNWIND_BRANCH:
+       case RE_UNWIND_BRANCHJ:
+       {
+           re_unwind_branch_t *uwb = &(uw->branch);
+           I32 lastparen = uwb->lastparen;
+           
+           REGCP_UNWIND(uwb->lastcp);
+           for (n = *PL_reglastparen; n > lastparen; n--)
+               PL_regendp[n] = -1;
+           *PL_reglastparen = n;
+           scan = next = uwb->next;
+           if ( !scan || 
+                OP(scan) != (uwb->type == RE_UNWIND_BRANCH 
+                             ? BRANCH : BRANCHJ) ) {           /* Failure */
+               unwind = uwb->prev;
+#ifdef DEBUGGING
+               PL_regindent--;
+#endif
+               goto do_no;
+           }
+           /* Have more choice yet.  Reuse the same uwb.  */
+           /*SUPPRESS 560*/
+           if ((n = (uwb->type == RE_UNWIND_BRANCH
+                     ? NEXT_OFF(next) : ARG(next))))
+               next += n;
+           else
+               next = NULL;    /* XXXX Needn't unwinding in this case... */
+           uwb->next = next;
+           next = NEXTOPER(scan);
+           if (uwb->type == RE_UNWIND_BRANCHJ)
+               next = NEXTOPER(next);
+           locinput = uwb->locinput;
+           nextchr = uwb->nextchr;
+#ifdef DEBUGGING
+           PL_regindent = uwb->regindent;
+#endif
+
+           goto reenter;
+       }
+       /* NOT REACHED */
+       default:
+           Perl_croak(aTHX_ "regexp unwind memory corruption");
+       }
+       /* NOT REACHED */
+    }
 #ifdef DEBUGGING
     PL_regindent--;
 #endif
@@ -3317,35 +3525,37 @@ do_no:
 STATIC I32
 S_regrepeat(pTHX_ regnode *p, I32 max)
 {
-    dTHR;
     register char *scan;
     register I32 c;
     register char *loceol = PL_regeol;
     register I32 hardcount = 0;
+    register bool do_utf8 = DO_UTF8(PL_reg_sv);
 
     scan = PL_reginput;
     if (max != REG_INFTY && max < loceol - scan)
       loceol = scan + max;
     switch (OP(p)) {
     case REG_ANY:
-       while (scan < loceol && *scan != '\n')
-           scan++;
-       break;
-    case SANY:
-       scan = loceol;
-       break;
-    case ANYUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && *scan != '\n') {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (scan < loceol && hardcount < max && *scan != '\n') {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && *scan != '\n')
+               scan++;
        }
        break;
-    case SANYUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+    case SANY:
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           scan = loceol;
        }
        break;
     case EXACT:                /* length of string is 1 */
@@ -3366,135 +3576,151 @@ S_regrepeat(pTHX_ regnode *p, I32 max)
               (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
            scan++;
        break;
-    case ANYOFUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && REGINCLASSUTF8(p, (U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
-       }
-       break;
     case ANYOF:
-       while (scan < loceol && REGINCLASS(p, *scan))
-           scan++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  reginclass(p, (U8*)scan, do_utf8)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
+               scan++;
+       }
        break;
     case ALNUM:
-       while (scan < loceol && isALNUM(*scan))
-           scan++;
-       break;
-    case ALNUMUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && swash_fetch(PL_utf8_alnum, (U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  swash_fetch(PL_utf8_alnum, (U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && isALNUM(*scan))
+               scan++;
        }
        break;
     case ALNUML:
        PL_reg_flags |= RF_tainted;
-       while (scan < loceol && isALNUM_LC(*scan))
-           scan++;
-       break;
-    case ALNUMLUTF8:
-       PL_reg_flags |= RF_tainted;
-       loceol = PL_regeol;
-       while (scan < loceol && isALNUM_LC_utf8((U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  isALNUM_LC_utf8((U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && isALNUM_LC(*scan))
+               scan++;
        }
        break;
-       break;
     case NALNUM:
-       while (scan < loceol && !isALNUM(*scan))
-           scan++;
-       break;
-    case NALNUMUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && !isALNUM(*scan))
+               scan++;
        }
        break;
     case NALNUML:
        PL_reg_flags |= RF_tainted;
-       while (scan < loceol && !isALNUM_LC(*scan))
-           scan++;
-       break;
-    case NALNUMLUTF8:
-       PL_reg_flags |= RF_tainted;
-       loceol = PL_regeol;
-       while (scan < loceol && !isALNUM_LC_utf8((U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  !isALNUM_LC_utf8((U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && !isALNUM_LC(*scan))
+               scan++;
        }
        break;
     case SPACE:
-       while (scan < loceol && isSPACE(*scan))
-           scan++;
-       break;
-    case SPACEUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && isSPACE(*scan))
+               scan++;
        }
        break;
     case SPACEL:
        PL_reg_flags |= RF_tainted;
-       while (scan < loceol && isSPACE_LC(*scan))
-           scan++;
-       break;
-    case SPACELUTF8:
-       PL_reg_flags |= RF_tainted;
-       loceol = PL_regeol;
-       while (scan < loceol && (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && isSPACE_LC(*scan))
+               scan++;
        }
        break;
     case NSPACE:
-       while (scan < loceol && !isSPACE(*scan))
-           scan++;
-       break;
-    case NSPACEUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && !isSPACE(*scan))
+               scan++;
+           break;
        }
-       break;
     case NSPACEL:
        PL_reg_flags |= RF_tainted;
-       while (scan < loceol && !isSPACE_LC(*scan))
-           scan++;
-       break;
-    case NSPACELUTF8:
-       PL_reg_flags |= RF_tainted;
-       loceol = PL_regeol;
-       while (scan < loceol && !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && !isSPACE_LC(*scan))
+               scan++;
        }
        break;
     case DIGIT:
-       while (scan < loceol && isDIGIT(*scan))
-           scan++;
-       break;
-    case DIGITUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && swash_fetch(PL_utf8_digit,(U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  swash_fetch(PL_utf8_digit,(U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && isDIGIT(*scan))
+               scan++;
        }
        break;
-       break;
     case NDIGIT:
-       while (scan < loceol && !isDIGIT(*scan))
-           scan++;
-       break;
-    case NDIGITUTF8:
-       loceol = PL_regeol;
-       while (scan < loceol && !swash_fetch(PL_utf8_digit,(U8*)scan)) {
-           scan += UTF8SKIP(scan);
-           hardcount++;
+       if (do_utf8) {
+           loceol = PL_regeol;
+           while (hardcount < max && scan < loceol &&
+                  !swash_fetch(PL_utf8_digit,(U8*)scan)) {
+               scan += UTF8SKIP(scan);
+               hardcount++;
+           }
+       } else {
+           while (scan < loceol && !isDIGIT(*scan))
+               scan++;
        }
        break;
     default:           /* Called on something of 0 width. */
@@ -3529,7 +3755,6 @@ S_regrepeat(pTHX_ regnode *p, I32 max)
 STATIC I32
 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
 {
-    dTHR;
     register char *scan;
     register char *start;
     register char *loceol = PL_regeol;
@@ -3540,7 +3765,7 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
        return 0;
 
     start = PL_reginput;
-    if (UTF) {
+    if (DO_UTF8(PL_reg_sv)) {
        while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
            if (!count++) {
                l = 0;
@@ -3574,96 +3799,141 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
 }
 
 /*
- - reginclass - determine if a character falls into a character class
- */
+- regclass_swash - prepare the utf8 swash
+*/
 
-STATIC bool
-S_reginclass(pTHX_ register regnode *p, register I32 c)
+SV *
+Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
 {
-    dTHR;
-    char flags = ANYOF_FLAGS(p);
-    bool match = FALSE;
+    SV *sw = NULL;
+    SV *si = NULL;
 
-    c &= 0xFF;
-    if (ANYOF_BITMAP_TEST(p, c))
-       match = TRUE;
-    else if (flags & ANYOF_FOLD) {
-       I32 cf;
-       if (flags & ANYOF_LOCALE) {
-           PL_reg_flags |= RF_tainted;
-           cf = PL_fold_locale[c];
-       }
-       else
-           cf = PL_fold[c];
-       if (ANYOF_BITMAP_TEST(p, cf))
-           match = TRUE;
-    }
+    if (PL_regdata && PL_regdata->count) {
+       U32 n = ARG(node);
 
-    if (!match && (flags & ANYOF_CLASS)) {
-       PL_reg_flags |= RF_tainted;
-       if (
-           (ANYOF_CLASS_TEST(p, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
-           (ANYOF_CLASS_TEST(p, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_ASCII)   &&  isASCII(c))     ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NASCII)  && !isASCII(c))     ||
-           (ANYOF_CLASS_TEST(p, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
-           (ANYOF_CLASS_TEST(p, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
-           (ANYOF_CLASS_TEST(p, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
-           (ANYOF_CLASS_TEST(p, ANYOF_BLANK)   &&  isBLANK(c))    ||
-           (ANYOF_CLASS_TEST(p, ANYOF_NBLANK)  && !isBLANK(c))
-           ) /* How's that for a conditional? */
-       {
-           match = TRUE;
+       if (PL_regdata->what[n] == 's') {
+           SV *rv = (SV*)PL_regdata->data[n];
+           AV *av = (AV*)SvRV((SV*)rv);
+           SV **a;
+           
+           si = *av_fetch(av, 0, FALSE);
+           a  =  av_fetch(av, 1, FALSE);
+           
+           if (a)
+               sw = *a;
+           else if (si && doinit) {
+               sw = swash_init("utf8", "", si, 1, 0);
+               (void)av_store(av, 1, sw);
+           }
        }
     }
+       
+    if (initsvp)
+       *initsvp = si;
 
-    return (flags & ANYOF_INVERT) ? !match : match;
+    return sw;
 }
 
+/*
+ - reginclass - determine if a character falls into a character class
+ */
+
 STATIC bool
-S_reginclassutf8(pTHX_ regnode *f, U8 *p)
-{                                           
-    dTHR;
-    char flags = ARG1(f);
+S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
+{
+    char flags = ANYOF_FLAGS(n);
     bool match = FALSE;
-    SV *sv = (SV*)PL_regdata->data[ARG2(f)];
+    UV c;
+    STRLEN len;
 
-    if (swash_fetch(sv, p))
-       match = TRUE;
-    else if (flags & ANYOF_FOLD) {
-       U8 tmpbuf[UTF8_MAXLEN];
-       if (flags & ANYOF_LOCALE) {
-           PL_reg_flags |= RF_tainted;
-           uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
+    if (do_utf8)
+       c = utf8_to_uv_simple(p, &len);
+    else
+       c = *p;
+
+    if (do_utf8 || (flags & ANYOF_UNICODE)) {
+       if (do_utf8 && !ANYOF_RUNTIME(n)) {
+           if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
+               match = TRUE;
        }
-       else
-           uv_to_utf8(tmpbuf, toLOWER_utf8(p));
-       if (swash_fetch(sv, tmpbuf))
+       if (do_utf8 && flags & ANYOF_UNICODE_ALL && c >= 256)
            match = TRUE;
+       if (!match) {
+           SV *sw = regclass_swash(n, TRUE, 0);
+       
+           if (sw) {
+               if (swash_fetch(sw, p))
+                   match = TRUE;
+               else if (flags & ANYOF_FOLD) {
+                   U8 tmpbuf[UTF8_MAXLEN+1];
+                   
+                   if (flags & ANYOF_LOCALE) {
+                       PL_reg_flags |= RF_tainted;
+                       uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
+                   }
+                   else
+                       uv_to_utf8(tmpbuf, toLOWER_utf8(p));
+                   if (swash_fetch(sw, tmpbuf))
+                       match = TRUE;
+               }
+           }
+       }
     }
+    if (!match && c < 256) {
+       if (ANYOF_BITMAP_TEST(n, c))
+           match = TRUE;
+       else if (flags & ANYOF_FOLD) {
+           I32 f;
 
-    /* UTF8 combined with ANYOF_CLASS is ill-defined. */
+           if (flags & ANYOF_LOCALE) {
+               PL_reg_flags |= RF_tainted;
+               f = PL_fold_locale[c];
+           }
+           else
+               f = PL_fold[c];
+           if (f != c && ANYOF_BITMAP_TEST(n, f))
+               match = TRUE;
+       }
+       
+       if (!match && (flags & ANYOF_CLASS)) {
+           PL_reg_flags |= RF_tainted;
+           if (
+               (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
+               (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
+               (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
+               (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
+               (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
+               (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
+               (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
+               ) /* How's that for a conditional? */
+           {
+               match = TRUE;
+           }
+       }
+    }
 
     return (flags & ANYOF_INVERT) ? !match : match;
 }
@@ -3671,19 +3941,27 @@ S_reginclassutf8(pTHX_ regnode *f, U8 *p)
 STATIC U8 *
 S_reghop(pTHX_ U8 *s, I32 off)
 {                               
-    dTHR;
+    return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
+}
+
+STATIC U8 *
+S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
+{                               
     if (off >= 0) {
-       while (off-- && s < (U8*)PL_regeol)
+       while (off-- && s < lim) {
+           /* XXX could check well-formedness here */
            s += UTF8SKIP(s);
+       }
     }
     else {
        while (off++) {
-           if (s > (U8*)PL_bostr) {
+           if (s > lim) {
                s--;
-               if (*s & 0x80) {
-                   while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80)
+               if (UTF8_IS_CONTINUED(*s)) {
+                   while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
                        s--;
-               }               /* XXX could check well-formedness here */
+               }
+               /* XXX could check well-formedness here */
            }
        }
     }
@@ -3691,23 +3969,31 @@ S_reghop(pTHX_ U8 *s, I32 off)
 }
 
 STATIC U8 *
-S_reghopmaybe(pTHX_ U8* s, I32 off)
+S_reghopmaybe(pTHX_ U8 *s, I32 off)
+{                               
+    return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
+}
+
+STATIC U8 *
+S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
 {
-    dTHR;
     if (off >= 0) {
-       while (off-- && s < (U8*)PL_regeol)
+       while (off-- && s < lim) {
+           /* XXX could check well-formedness here */
            s += UTF8SKIP(s);
+       }
        if (off >= 0)
            return 0;
     }
     else {
        while (off++) {
-           if (s > (U8*)PL_bostr) {
+           if (s > lim) {
                s--;
-               if (*s & 0x80) {
-                   while (s > (U8*)PL_bostr && (*s & 0xc0) == 0x80)
+               if (UTF8_IS_CONTINUED(*s)) {
+                   while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
                        s--;
-               }               /* XXX could check well-formedness here */
+               }
+               /* XXX could check well-formedness here */
            }
            else
                break;
@@ -3725,7 +4011,6 @@ S_reghopmaybe(pTHX_ U8* s, I32 off)
 static void
 restore_pos(pTHXo_ void *arg)
 {
-    dTHR;
     if (PL_reg_eval_set) {
        if (PL_reg_oldsaved) {
            PL_reg_re->subbeg = PL_reg_oldsaved;
index ca0e9ed..3c71060 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -19,6 +19,8 @@ typedef struct regnode regnode;
 
 struct reg_substr_data;
 
+struct reg_data;
+
 typedef struct regexp {
        I32 *startp;
        I32 *endp;
index 89c78e6..00dc0ec 100644 (file)
 #define        MEOL    7       /*  0x7 Same, assuming multiline. */
 #define        SEOL    8       /*  0x8 Same, assuming singleline. */
 #define        BOUND   9       /*  0x9 Match "" at any word boundary */
-#define        BOUNDUTF8       10      /*  0xa Match "" at any word boundary */
-#define        BOUNDL  11      /*  0xb Match "" at any word boundary */
-#define        BOUNDLUTF8      12      /*  0xc Match "" at any word boundary */
-#define        NBOUND  13      /*  0xd Match "" at any word non-boundary */
-#define        NBOUNDUTF8      14      /*  0xe Match "" at any word non-boundary */
-#define        NBOUNDL 15      /*  0xf Match "" at any word non-boundary */
-#define        NBOUNDLUTF8     16      /* 0x10 Match "" at any word non-boundary */
-#define        GPOS    17      /* 0x11 Matches where last m//g left off. */
-#define        REG_ANY 18      /* 0x12 Match any one character (except newline). */
-#define        ANYUTF8 19      /* 0x13 Match any one Unicode character (except newline). */
-#define        SANY    20      /* 0x14 Match any one character. */
-#define        SANYUTF8        21      /* 0x15 Match any one Unicode character. */
-#define        ANYOF   22      /* 0x16 Match character in (or not in) this class. */
-#define        ANYOFUTF8       23      /* 0x17 Match character in (or not in) this class. */
-#define        ALNUM   24      /* 0x18 Match any alphanumeric character */
-#define        ALNUMUTF8       25      /* 0x19 Match any alphanumeric character in utf8 */
-#define        ALNUML  26      /* 0x1a Match any alphanumeric char in locale */
-#define        ALNUMLUTF8      27      /* 0x1b Match any alphanumeric char in locale+utf8 */
-#define        NALNUM  28      /* 0x1c Match any non-alphanumeric character */
-#define        NALNUMUTF8      29      /* 0x1d Match any non-alphanumeric character in utf8 */
-#define        NALNUML 30      /* 0x1e Match any non-alphanumeric char in locale */
-#define        NALNUMLUTF8     31      /* 0x1f Match any non-alphanumeric char in locale+utf8 */
-#define        SPACE   32      /* 0x20 Match any whitespace character */
-#define        SPACEUTF8       33      /* 0x21 Match any whitespace character in utf8 */
-#define        SPACEL  34      /* 0x22 Match any whitespace char in locale */
-#define        SPACELUTF8      35      /* 0x23 Match any whitespace char in locale+utf8 */
-#define        NSPACE  36      /* 0x24 Match any non-whitespace character */
-#define        NSPACEUTF8      37      /* 0x25 Match any non-whitespace character in utf8 */
-#define        NSPACEL 38      /* 0x26 Match any non-whitespace char in locale */
-#define        NSPACELUTF8     39      /* 0x27 Match any non-whitespace char in locale+utf8 */
-#define        DIGIT   40      /* 0x28 Match any numeric character */
-#define        DIGITUTF8       41      /* 0x29 Match any numeric character in utf8 */
-#define        DIGITL  42      /* 0x2a Match any numeric character in locale */
-#define        DIGITLUTF8      43      /* 0x2b Match any numeric character in locale+utf8 */
-#define        NDIGIT  44      /* 0x2c Match any non-numeric character */
-#define        NDIGITUTF8      45      /* 0x2d Match any non-numeric character in utf8 */
-#define        NDIGITL 46      /* 0x2e Match any non-numeric character in locale */
-#define        NDIGITLUTF8     47      /* 0x2f Match any non-numeric character in locale+utf8 */
-#define        CLUMP   48      /* 0x30 Match any combining character sequence */
-#define        BRANCH  49      /* 0x31 Match this alternative, or the next... */
-#define        BACK    50      /* 0x32 Match "", "next" ptr points backward. */
-#define        EXACT   51      /* 0x33 Match this string (preceded by length). */
-#define        EXACTF  52      /* 0x34 Match this string, folded (prec. by length). */
-#define        EXACTFL 53      /* 0x35 Match this string, folded in locale (w/len). */
-#define        NOTHING 54      /* 0x36 Match empty string. */
-#define        TAIL    55      /* 0x37 Match empty string. Can jump here from outside. */
-#define        STAR    56      /* 0x38 Match this (simple) thing 0 or more times. */
-#define        PLUS    57      /* 0x39 Match this (simple) thing 1 or more times. */
-#define        CURLY   58      /* 0x3a Match this simple thing {n,m} times. */
-#define        CURLYN  59      /* 0x3b Match next-after-this simple thing  */
-#define        CURLYM  60      /* 0x3c Match this medium-complex thing {n,m} times. */
-#define        CURLYX  61      /* 0x3d Match this complex thing {n,m} times. */
-#define        WHILEM  62      /* 0x3e Do curly processing and see if rest matches. */
-#define        OPEN    63      /* 0x3f Mark this point in input as start of #n. */
-#define        CLOSE   64      /* 0x40 Analogous to OPEN. */
-#define        REF     65      /* 0x41 Match some already matched string */
-#define        REFF    66      /* 0x42 Match already matched string, folded */
-#define        REFFL   67      /* 0x43 Match already matched string, folded in loc. */
-#define        IFMATCH 68      /* 0x44 Succeeds if the following matches. */
-#define        UNLESSM 69      /* 0x45 Fails if the following matches. */
-#define        SUSPEND 70      /* 0x46 "Independent" sub-RE. */
-#define        IFTHEN  71      /* 0x47 Switch, should be preceeded by switcher . */
-#define        GROUPP  72      /* 0x48 Whether the group matched. */
-#define        LONGJMP 73      /* 0x49 Jump far away. */
-#define        BRANCHJ 74      /* 0x4a BRANCH with long offset. */
-#define        EVAL    75      /* 0x4b Execute some Perl code. */
-#define        MINMOD  76      /* 0x4c Next operator is not greedy. */
-#define        LOGICAL 77      /* 0x4d Next opcode should set the flag only. */
-#define        RENUM   78      /* 0x4e Group with independently numbered parens. */
-#define        OPTIMIZED       79      /* 0x4f Placeholder for dump. */
+#define        BOUNDL  10      /*  0xa Match "" at any word boundary */
+#define        NBOUND  11      /*  0xb Match "" at any word non-boundary */
+#define        NBOUNDL 12      /*  0xc Match "" at any word non-boundary */
+#define        GPOS    13      /*  0xd Matches where last m//g left off. */
+#define        REG_ANY 14      /*  0xe Match any one character (except newline). */
+#define        SANY    15      /*  0xf Match any one character. */
+#define        ANYOF   16      /* 0x10 Match character in (or not in) this class. */
+#define        ALNUM   17      /* 0x11 Match any alphanumeric character */
+#define        ALNUML  18      /* 0x12 Match any alphanumeric char in locale */
+#define        NALNUM  19      /* 0x13 Match any non-alphanumeric character */
+#define        NALNUML 20      /* 0x14 Match any non-alphanumeric char in locale */
+#define        SPACE   21      /* 0x15 Match any whitespace character */
+#define        SPACEL  22      /* 0x16 Match any whitespace char in locale */
+#define        NSPACE  23      /* 0x17 Match any non-whitespace character */
+#define        NSPACEL 24      /* 0x18 Match any non-whitespace char in locale */
+#define        DIGIT   25      /* 0x19 Match any numeric character */
+#define        DIGITL  26      /* 0x1a Match any numeric character in locale */
+#define        NDIGIT  27      /* 0x1b Match any non-numeric character */
+#define        NDIGITL 28      /* 0x1c Match any non-numeric character in locale */
+#define        CLUMP   29      /* 0x1d Match any combining character sequence */
+#define        BRANCH  30      /* 0x1e Match this alternative, or the next... */
+#define        BACK    31      /* 0x1f Match "", "next" ptr points backward. */
+#define        EXACT   32      /* 0x20 Match this string (preceded by length). */
+#define        EXACTF  33      /* 0x21 Match this string, folded (prec. by length). */
+#define        EXACTFL 34      /* 0x22 Match this string, folded in locale (w/len). */
+#define        NOTHING 35      /* 0x23 Match empty string. */
+#define        TAIL    36      /* 0x24 Match empty string. Can jump here from outside. */
+#define        STAR    37      /* 0x25 Match this (simple) thing 0 or more times. */
+#define        PLUS    38      /* 0x26 Match this (simple) thing 1 or more times. */
+#define        CURLY   39      /* 0x27 Match this simple thing {n,m} times. */
+#define        CURLYN  40      /* 0x28 Match next-after-this simple thing  */
+#define        CURLYM  41      /* 0x29 Match this medium-complex thing {n,m} times. */
+#define        CURLYX  42      /* 0x2a Match this complex thing {n,m} times. */
+#define        WHILEM  43      /* 0x2b Do curly processing and see if rest matches. */
+#define        OPEN    44      /* 0x2c Mark this point in input as start of #n. */
+#define        CLOSE   45      /* 0x2d Analogous to OPEN. */
+#define        REF     46      /* 0x2e Match some already matched string */
+#define        REFF    47      /* 0x2f Match already matched string, folded */
+#define        REFFL   48      /* 0x30 Match already matched string, folded in loc. */
+#define        IFMATCH 49      /* 0x31 Succeeds if the following matches. */
+#define        UNLESSM 50      /* 0x32 Fails if the following matches. */
+#define        SUSPEND 51      /* 0x33 "Independent" sub-RE. */
+#define        IFTHEN  52      /* 0x34 Switch, should be preceeded by switcher . */
+#define        GROUPP  53      /* 0x35 Whether the group matched. */
+#define        LONGJMP 54      /* 0x36 Jump far away. */
+#define        BRANCHJ 55      /* 0x37 BRANCH with long offset. */
+#define        EVAL    56      /* 0x38 Execute some Perl code. */
+#define        MINMOD  57      /* 0x39 Next operator is not greedy. */
+#define        LOGICAL 58      /* 0x3a Next opcode should set the flag only. */
+#define        RENUM   59      /* 0x3b Group with independently numbered parens. */
+#define        OPTIMIZED       60      /* 0x3c Placeholder for dump. */
 
 #ifndef DOINIT
 EXTCONST U8 PL_regkind[];
@@ -98,44 +79,25 @@ EXTCONST U8 PL_regkind[] = {
        EOL,            /* MEOL */
        EOL,            /* SEOL */
        BOUND,          /* BOUND */
-       BOUND,          /* BOUNDUTF8 */
        BOUND,          /* BOUNDL */
-       BOUND,          /* BOUNDLUTF8 */
        NBOUND,         /* NBOUND */
-       NBOUND,         /* NBOUNDUTF8 */
        NBOUND,         /* NBOUNDL */
-       NBOUND,         /* NBOUNDLUTF8 */
        GPOS,           /* GPOS */
        REG_ANY,                /* REG_ANY */
-       REG_ANY,                /* ANYUTF8 */
        REG_ANY,                /* SANY */
-       REG_ANY,                /* SANYUTF8 */
        ANYOF,          /* ANYOF */
-       ANYOF,          /* ANYOFUTF8 */
        ALNUM,          /* ALNUM */
-       ALNUM,          /* ALNUMUTF8 */
        ALNUM,          /* ALNUML */
-       ALNUM,          /* ALNUMLUTF8 */
        NALNUM,         /* NALNUM */
-       NALNUM,         /* NALNUMUTF8 */
        NALNUM,         /* NALNUML */
-       NALNUM,         /* NALNUMLUTF8 */
        SPACE,          /* SPACE */
-       SPACE,          /* SPACEUTF8 */
        SPACE,          /* SPACEL */
-       SPACE,          /* SPACELUTF8 */
        NSPACE,         /* NSPACE */
-       NSPACE,         /* NSPACEUTF8 */
        NSPACE,         /* NSPACEL */
-       NSPACE,         /* NSPACELUTF8 */
        DIGIT,          /* DIGIT */
-       DIGIT,          /* DIGITUTF8 */
        DIGIT,          /* DIGITL */
-       DIGIT,          /* DIGITLUTF8 */
        NDIGIT,         /* NDIGIT */
-       NDIGIT,         /* NDIGITUTF8 */
        NDIGIT,         /* NDIGITL */
-       NDIGIT,         /* NDIGITLUTF8 */
        CLUMP,          /* CLUMP */
        BRANCH,         /* BRANCH */
        BACK,           /* BACK */
@@ -184,44 +146,25 @@ static const U8 regarglen[] = {
        0,              /* MEOL */
        0,              /* SEOL */
        0,              /* BOUND */
-       0,              /* BOUNDUTF8 */
        0,              /* BOUNDL */
-       0,              /* BOUNDLUTF8 */
        0,              /* NBOUND */
-       0,              /* NBOUNDUTF8 */
        0,              /* NBOUNDL */
-       0,              /* NBOUNDLUTF8 */
        0,              /* GPOS */
        0,              /* REG_ANY */
-       0,              /* ANYUTF8 */
        0,              /* SANY */
-       0,              /* SANYUTF8 */
        0,              /* ANYOF */
-       EXTRA_SIZE(struct regnode_1),           /* ANYOFUTF8 */
        0,              /* ALNUM */
-       0,              /* ALNUMUTF8 */
        0,              /* ALNUML */
-       0,              /* ALNUMLUTF8 */
        0,              /* NALNUM */
-       0,              /* NALNUMUTF8 */
        0,              /* NALNUML */
-       0,              /* NALNUMLUTF8 */
        0,              /* SPACE */
-       0,              /* SPACEUTF8 */
        0,              /* SPACEL */
-       0,              /* SPACELUTF8 */
        0,              /* NSPACE */
-       0,              /* NSPACEUTF8 */
        0,              /* NSPACEL */
-       0,              /* NSPACELUTF8 */
        0,              /* DIGIT */
-       0,              /* DIGITUTF8 */
        0,              /* DIGITL */
-       0,              /* DIGITLUTF8 */
        0,              /* NDIGIT */
-       0,              /* NDIGITUTF8 */
        0,              /* NDIGITL */
-       0,              /* NDIGITLUTF8 */
        0,              /* CLUMP */
        0,              /* BRANCH */
        0,              /* BACK */
@@ -267,44 +210,25 @@ static const char reg_off_by_arg[] = {
        0,              /* MEOL */
        0,              /* SEOL */
        0,              /* BOUND */
-       0,              /* BOUNDUTF8 */
        0,              /* BOUNDL */
-       0,              /* BOUNDLUTF8 */
        0,              /* NBOUND */
-       0,              /* NBOUNDUTF8 */
        0,              /* NBOUNDL */
-       0,              /* NBOUNDLUTF8 */
        0,              /* GPOS */
        0,              /* REG_ANY */
-       0,              /* ANYUTF8 */
        0,              /* SANY */
-       0,              /* SANYUTF8 */
        0,              /* ANYOF */
-       0,              /* ANYOFUTF8 */
        0,              /* ALNUM */
-       0,              /* ALNUMUTF8 */
        0,              /* ALNUML */
-       0,              /* ALNUMLUTF8 */
        0,              /* NALNUM */
-       0,              /* NALNUMUTF8 */
        0,              /* NALNUML */
-       0,              /* NALNUMLUTF8 */
        0,              /* SPACE */
-       0,              /* SPACEUTF8 */
        0,              /* SPACEL */
-       0,              /* SPACELUTF8 */
        0,              /* NSPACE */
-       0,              /* NSPACEUTF8 */
        0,              /* NSPACEL */
-       0,              /* NSPACELUTF8 */
        0,              /* DIGIT */
-       0,              /* DIGITUTF8 */
        0,              /* DIGITL */
-       0,              /* DIGITLUTF8 */
        0,              /* NDIGIT */
-       0,              /* NDIGITUTF8 */
        0,              /* NDIGITL */
-       0,              /* NDIGITLUTF8 */
        0,              /* CLUMP */
        0,              /* BRANCH */
        0,              /* BACK */
@@ -351,79 +275,60 @@ static const char * const reg_name[] = {
        "MEOL",         /*  0x7 */
        "SEOL",         /*  0x8 */
        "BOUND",                /*  0x9 */
-       "BOUNDUTF8",            /*  0xa */
-       "BOUNDL",               /*  0xb */
-       "BOUNDLUTF8",           /*  0xc */
-       "NBOUND",               /*  0xd */
-       "NBOUNDUTF8",           /*  0xe */
-       "NBOUNDL",              /*  0xf */
-       "NBOUNDLUTF8",          /* 0x10 */
-       "GPOS",         /* 0x11 */
-       "REG_ANY",              /* 0x12 */
-       "ANYUTF8",              /* 0x13 */
-       "SANY",         /* 0x14 */
-       "SANYUTF8",             /* 0x15 */
-       "ANYOF",                /* 0x16 */
-       "ANYOFUTF8",            /* 0x17 */
-       "ALNUM",                /* 0x18 */
-       "ALNUMUTF8",            /* 0x19 */
-       "ALNUML",               /* 0x1a */
-       "ALNUMLUTF8",           /* 0x1b */
-       "NALNUM",               /* 0x1c */
-       "NALNUMUTF8",           /* 0x1d */
-       "NALNUML",              /* 0x1e */
-       "NALNUMLUTF8",          /* 0x1f */
-       "SPACE",                /* 0x20 */
-       "SPACEUTF8",            /* 0x21 */
-       "SPACEL",               /* 0x22 */
-       "SPACELUTF8",           /* 0x23 */
-       "NSPACE",               /* 0x24 */
-       "NSPACEUTF8",           /* 0x25 */
-       "NSPACEL",              /* 0x26 */
-       "NSPACELUTF8",          /* 0x27 */
-       "DIGIT",                /* 0x28 */
-       "DIGITUTF8",            /* 0x29 */
-       "DIGITL",               /* 0x2a */
-       "DIGITLUTF8",           /* 0x2b */
-       "NDIGIT",               /* 0x2c */
-       "NDIGITUTF8",           /* 0x2d */
-       "NDIGITL",              /* 0x2e */
-       "NDIGITLUTF8",          /* 0x2f */
-       "CLUMP",                /* 0x30 */
-       "BRANCH",               /* 0x31 */
-       "BACK",         /* 0x32 */
-       "EXACT",                /* 0x33 */
-       "EXACTF",               /* 0x34 */
-       "EXACTFL",              /* 0x35 */
-       "NOTHING",              /* 0x36 */
-       "TAIL",         /* 0x37 */
-       "STAR",         /* 0x38 */
-       "PLUS",         /* 0x39 */
-       "CURLY",                /* 0x3a */
-       "CURLYN",               /* 0x3b */
-       "CURLYM",               /* 0x3c */
-       "CURLYX",               /* 0x3d */
-       "WHILEM",               /* 0x3e */
-       "OPEN",         /* 0x3f */
-       "CLOSE",                /* 0x40 */
-       "REF",          /* 0x41 */
-       "REFF",         /* 0x42 */
-       "REFFL",                /* 0x43 */
-       "IFMATCH",              /* 0x44 */
-       "UNLESSM",              /* 0x45 */
-       "SUSPEND",              /* 0x46 */
-       "IFTHEN",               /* 0x47 */
-       "GROUPP",               /* 0x48 */
-       "LONGJMP",              /* 0x49 */
-       "BRANCHJ",              /* 0x4a */
-       "EVAL",         /* 0x4b */
-       "MINMOD",               /* 0x4c */
-       "LOGICAL",              /* 0x4d */
-       "RENUM",                /* 0x4e */
-       "OPTIMIZED",            /* 0x4f */
+       "BOUNDL",               /*  0xa */
+       "NBOUND",               /*  0xb */
+       "NBOUNDL",              /*  0xc */
+       "GPOS",         /*  0xd */
+       "REG_ANY",              /*  0xe */
+       "SANY",         /*  0xf */
+       "ANYOF",                /* 0x10 */
+       "ALNUM",                /* 0x11 */
+       "ALNUML",               /* 0x12 */
+       "NALNUM",               /* 0x13 */
+       "NALNUML",              /* 0x14 */
+       "SPACE",                /* 0x15 */
+       "SPACEL",               /* 0x16 */
+       "NSPACE",               /* 0x17 */
+       "NSPACEL",              /* 0x18 */
+       "DIGIT",                /* 0x19 */
+       "DIGITL",               /* 0x1a */
+       "NDIGIT",               /* 0x1b */
+       "NDIGITL",              /* 0x1c */
+       "CLUMP",                /* 0x1d */
+       "BRANCH",               /* 0x1e */
+       "BACK",         /* 0x1f */
+       "EXACT",                /* 0x20 */
+       "EXACTF",               /* 0x21 */
+       "EXACTFL",              /* 0x22 */
+       "NOTHING",              /* 0x23 */
+       "TAIL",         /* 0x24 */
+       "STAR",         /* 0x25 */
+       "PLUS",         /* 0x26 */
+       "CURLY",                /* 0x27 */
+       "CURLYN",               /* 0x28 */
+       "CURLYM",               /* 0x29 */
+       "CURLYX",               /* 0x2a */
+       "WHILEM",               /* 0x2b */
+       "OPEN",         /* 0x2c */
+       "CLOSE",                /* 0x2d */
+       "REF",          /* 0x2e */
+       "REFF",         /* 0x2f */
+       "REFFL",                /* 0x30 */
+       "IFMATCH",              /* 0x31 */
+       "UNLESSM",              /* 0x32 */
+       "SUSPEND",              /* 0x33 */
+       "IFTHEN",               /* 0x34 */
+       "GROUPP",               /* 0x35 */
+       "LONGJMP",              /* 0x36 */
+       "BRANCHJ",              /* 0x37 */
+       "EVAL",         /* 0x38 */
+       "MINMOD",               /* 0x39 */
+       "LOGICAL",              /* 0x3a */
+       "RENUM",                /* 0x3b */
+       "OPTIMIZED",            /* 0x3c */
 };
 
-static const int reg_num = 80;
+static const int reg_num = 61;
 
 #endif /* DEBUGGING */
 #endif /* REG_COMP_C */
diff --git a/run.c b/run.c
index 728b761..06dc3f2 100644 (file)
--- a/run.c
+++ b/run.c
@@ -1,6 +1,6 @@
 /*    run.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -20,8 +20,6 @@
 int
 Perl_runops_standard(pTHX)
 {
-    dTHR;
-
     while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
        PERL_ASYNC_CHECK();
     }
@@ -34,7 +32,6 @@ int
 Perl_runops_debug(pTHX)
 {
 #ifdef DEBUGGING
-    dTHR;
     if (!PL_op) {
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
@@ -96,7 +93,6 @@ void
 Perl_watch(pTHX_ char **addr)
 {
 #ifdef DEBUGGING
-    dTHR;
     PL_watchaddr = addr;
     PL_watchok = *addr;
     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
diff --git a/scope.c b/scope.c
index 0544b89..27b522f 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1,6 +1,6 @@
 /*    scope.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -33,7 +33,6 @@ void *
 Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
                      protect_body_t body, va_list *args)
 {
-    dTHR;
     int ex;
     void *ret;
 
@@ -51,7 +50,6 @@ Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
 SV**
 Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
 {
-    dTHR;
 #if defined(DEBUGGING) && !defined(USE_THREADS)
     static int growing = 0;
     if (growing++)
@@ -97,7 +95,6 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
 I32
 Perl_cxinc(pTHX)
 {
-    dTHR;
     cxstack_max = GROW(cxstack_max);
     Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);     /* XXX should fix CXINC macro */
     return cxstack_ix + 1;
@@ -106,7 +103,6 @@ Perl_cxinc(pTHX)
 void
 Perl_push_return(pTHX_ OP *retop)
 {
-    dTHR;
     if (PL_retstack_ix == PL_retstack_max) {
        PL_retstack_max = GROW(PL_retstack_max);
        Renew(PL_retstack, PL_retstack_max, OP*);
@@ -117,7 +113,6 @@ Perl_push_return(pTHX_ OP *retop)
 OP *
 Perl_pop_return(pTHX)
 {
-    dTHR;
     if (PL_retstack_ix > 0)
        return PL_retstack[--PL_retstack_ix];
     else
@@ -127,7 +122,6 @@ Perl_pop_return(pTHX)
 void
 Perl_push_scope(pTHX)
 {
-    dTHR;
     if (PL_scopestack_ix == PL_scopestack_max) {
        PL_scopestack_max = GROW(PL_scopestack_max);
        Renew(PL_scopestack, PL_scopestack_max, I32);
@@ -139,7 +133,6 @@ Perl_push_scope(pTHX)
 void
 Perl_pop_scope(pTHX)
 {
-    dTHR;
     I32 oldsave = PL_scopestack[--PL_scopestack_ix];
     LEAVE_SCOPE(oldsave);
 }
@@ -147,7 +140,6 @@ Perl_pop_scope(pTHX)
 void
 Perl_markstack_grow(pTHX)
 {
-    dTHR;
     I32 oldmax = PL_markstack_max - PL_markstack;
     I32 newmax = GROW(oldmax);
 
@@ -159,7 +151,6 @@ Perl_markstack_grow(pTHX)
 void
 Perl_savestack_grow(pTHX)
 {
-    dTHR;
     PL_savestack_max = GROW(PL_savestack_max) + 4; 
     Renew(PL_savestack, PL_savestack_max, ANY);
 }
@@ -169,7 +160,6 @@ Perl_savestack_grow(pTHX)
 void
 Perl_tmps_grow(pTHX_ I32 n)
 {
-    dTHR;
 #ifndef STRESS_REALLOC
     if (n < 128)
        n = (PL_tmps_max < 512) ? 128 : 512;
@@ -182,7 +172,6 @@ Perl_tmps_grow(pTHX_ I32 n)
 void
 Perl_free_tmps(pTHX)
 {
-    dTHR;
     /* XXX should tmps_floor live in cxstack? */
     I32 myfloor = PL_tmps_floor;
     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
@@ -198,7 +187,6 @@ Perl_free_tmps(pTHX)
 STATIC SV *
 S_save_scalar_at(pTHX_ SV **sptr)
 {
-    dTHR;
     register SV *sv;
     SV *osv = *sptr;
 
@@ -229,7 +217,6 @@ S_save_scalar_at(pTHX_ SV **sptr)
 SV *
 Perl_save_scalar(pTHX_ GV *gv)
 {
-    dTHR;
     SV **sptr = &GvSV(gv);
     SSCHECK(3);
     SSPUSHPTR(SvREFCNT_inc(gv));
@@ -241,7 +228,6 @@ Perl_save_scalar(pTHX_ GV *gv)
 SV*
 Perl_save_svref(pTHX_ SV **sptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(sptr);
     SSPUSHPTR(SvREFCNT_inc(*sptr));
@@ -254,7 +240,6 @@ Perl_save_svref(pTHX_ SV **sptr)
 void
 Perl_save_generic_svref(pTHX_ SV **sptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(sptr);
     SSPUSHPTR(SvREFCNT_inc(*sptr));
@@ -267,7 +252,6 @@ Perl_save_generic_svref(pTHX_ SV **sptr)
 void
 Perl_save_generic_pvref(pTHX_ char **str)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(str);
     SSPUSHPTR(*str);
@@ -277,7 +261,6 @@ Perl_save_generic_pvref(pTHX_ char **str)
 void
 Perl_save_gp(pTHX_ GV *gv, I32 empty)
 {
-    dTHR;
     SSCHECK(6);
     SSPUSHIV((IV)SvLEN(gv));
     SvLEN(gv) = 0; /* forget that anything was allocated here */
@@ -302,6 +285,7 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
        GvGP(gv) = gp_ref(gp);
        GvSV(gv) = NEWSV(72,0);
        GvLINE(gv) = CopLINE(PL_curcop);
+       GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
        GvEGV(gv) = gv;
     }
     else {
@@ -313,7 +297,6 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 AV *
 Perl_save_ary(pTHX_ GV *gv)
 {
-    dTHR;
     AV *oav = GvAVn(gv);
     AV *av;
 
@@ -341,7 +324,6 @@ Perl_save_ary(pTHX_ GV *gv)
 HV *
 Perl_save_hash(pTHX_ GV *gv)
 {
-    dTHR;
     HV *ohv, *hv;
 
     SSCHECK(3);
@@ -366,7 +348,6 @@ Perl_save_hash(pTHX_ GV *gv)
 void
 Perl_save_item(pTHX_ register SV *item)
 {
-    dTHR;
     register SV *sv = NEWSV(0,0);
 
     sv_setsv(sv,item);
@@ -379,7 +360,6 @@ Perl_save_item(pTHX_ register SV *item)
 void
 Perl_save_int(pTHX_ int *intp)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHINT(*intp);
     SSPUSHPTR(intp);
@@ -389,7 +369,6 @@ Perl_save_int(pTHX_ int *intp)
 void
 Perl_save_long(pTHX_ long int *longp)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHLONG(*longp);
     SSPUSHPTR(longp);
@@ -399,7 +378,6 @@ Perl_save_long(pTHX_ long int *longp)
 void
 Perl_save_I32(pTHX_ I32 *intp)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHINT(*intp);
     SSPUSHPTR(intp);
@@ -409,7 +387,6 @@ Perl_save_I32(pTHX_ I32 *intp)
 void
 Perl_save_I16(pTHX_ I16 *intp)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHINT(*intp);
     SSPUSHPTR(intp);
@@ -419,7 +396,6 @@ Perl_save_I16(pTHX_ I16 *intp)
 void
 Perl_save_I8(pTHX_ I8 *bytep)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHINT(*bytep);
     SSPUSHPTR(bytep);
@@ -429,7 +405,6 @@ Perl_save_I8(pTHX_ I8 *bytep)
 void
 Perl_save_iv(pTHX_ IV *ivp)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHIV(*ivp);
     SSPUSHPTR(ivp);
@@ -442,7 +417,6 @@ Perl_save_iv(pTHX_ IV *ivp)
 void
 Perl_save_pptr(pTHX_ char **pptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(*pptr);
     SSPUSHPTR(pptr);
@@ -452,7 +426,6 @@ Perl_save_pptr(pTHX_ char **pptr)
 void
 Perl_save_vptr(pTHX_ void *ptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(*(char**)ptr);
     SSPUSHPTR(ptr);
@@ -462,18 +435,26 @@ Perl_save_vptr(pTHX_ void *ptr)
 void
 Perl_save_sptr(pTHX_ SV **sptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(*sptr);
     SSPUSHPTR(sptr);
     SSPUSHINT(SAVEt_SPTR);
 }
 
+void
+Perl_save_padsv(pTHX_ PADOFFSET off)
+{
+    SSCHECK(4);
+    SSPUSHPTR(PL_curpad[off]);
+    SSPUSHPTR(PL_curpad);
+    SSPUSHLONG((long)off);
+    SSPUSHINT(SAVEt_PADSV);
+}
+
 SV **
 Perl_save_threadsv(pTHX_ PADOFFSET i)
 {
 #ifdef USE_THREADS
-    dTHR;
     SV **svp = &THREADSV(i);   /* XXX Change to save by offset */
     DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
                          (UV)i, svp, *svp, SvPEEK(*svp)));
@@ -488,7 +469,6 @@ Perl_save_threadsv(pTHX_ PADOFFSET i)
 void
 Perl_save_nogv(pTHX_ GV *gv)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHPTR(gv);
     SSPUSHINT(SAVEt_NSTAB);
@@ -497,7 +477,6 @@ Perl_save_nogv(pTHX_ GV *gv)
 void
 Perl_save_hptr(pTHX_ HV **hptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(*hptr);
     SSPUSHPTR(hptr);
@@ -507,7 +486,6 @@ Perl_save_hptr(pTHX_ HV **hptr)
 void
 Perl_save_aptr(pTHX_ AV **aptr)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHPTR(*aptr);
     SSPUSHPTR(aptr);
@@ -517,7 +495,6 @@ Perl_save_aptr(pTHX_ AV **aptr)
 void
 Perl_save_freesv(pTHX_ SV *sv)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHPTR(sv);
     SSPUSHINT(SAVEt_FREESV);
@@ -526,7 +503,6 @@ Perl_save_freesv(pTHX_ SV *sv)
 void
 Perl_save_freeop(pTHX_ OP *o)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHPTR(o);
     SSPUSHINT(SAVEt_FREEOP);
@@ -535,7 +511,6 @@ Perl_save_freeop(pTHX_ OP *o)
 void
 Perl_save_freepv(pTHX_ char *pv)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHPTR(pv);
     SSPUSHINT(SAVEt_FREEPV);
@@ -544,7 +519,6 @@ Perl_save_freepv(pTHX_ char *pv)
 void
 Perl_save_clearsv(pTHX_ SV **svp)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHLONG((long)(svp-PL_curpad));
     SSPUSHINT(SAVEt_CLEARSV);
@@ -553,7 +527,6 @@ Perl_save_clearsv(pTHX_ SV **svp)
 void
 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 {
-    dTHR;
     SSCHECK(4);
     SSPUSHINT(klen);
     SSPUSHPTR(key);
@@ -564,7 +537,6 @@ Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
 void
 Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
 {
-    dTHR;
     register SV *sv;
     register I32 i;
 
@@ -581,7 +553,6 @@ Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
 void
 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHDPTR(f);
     SSPUSHPTR(p);
@@ -591,7 +562,6 @@ Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
 void
 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 {
-    dTHR;
     SSCHECK(3);
     SSPUSHDXPTR(f);
     SSPUSHPTR(p);
@@ -601,7 +571,6 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 void
 Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
 {
-    dTHR;
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(av));
     SSPUSHINT(idx);
@@ -613,7 +582,6 @@ Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
 void
 Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
 {
-    dTHR;
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(hv));
     SSPUSHPTR(SvREFCNT_inc(key));
@@ -625,7 +593,6 @@ Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
 void
 Perl_save_op(pTHX)
 {
-    dTHR;
     SSCHECK(2);
     SSPUSHPTR(PL_op);
     SSPUSHINT(SAVEt_OP);
@@ -634,7 +601,6 @@ Perl_save_op(pTHX)
 I32
 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 {
-    dTHR;
     register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
                                 - (char*)PL_savestack);
     register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
@@ -652,7 +618,6 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad)
 void
 Perl_leave_scope(pTHX_ I32 base)
 {
-    dTHR;
     register SV *sv;
     register SV *value;
     register GV *gv;
@@ -844,7 +809,7 @@ Perl_leave_scope(pTHX_ I32 base)
            /* Can clear pad variable in place? */
            if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
                if (SvTHINKFIRST(sv))
-                   sv_force_normal(sv);
+                   sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
                if (SvMAGICAL(sv))
                    mg_free(sv);
 
@@ -887,7 +852,6 @@ Perl_leave_scope(pTHX_ I32 base)
            ptr = SSPOPPTR;
            (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
            SvREFCNT_dec(hv);
-           Safefree(ptr);
            break;
        case SAVEt_DESTRUCTOR:
            ptr = SSPOPPTR;
@@ -960,6 +924,14 @@ Perl_leave_scope(pTHX_ I32 base)
            else
                PL_curpad = Null(SV**);
            break;
+       case SAVEt_PADSV:
+           {
+               PADOFFSET off = (PADOFFSET)SSPOPLONG;
+               ptr = SSPOPPTR;
+               if (ptr)
+                   ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+           }
+           break;
        default:
            Perl_croak(aTHX_ "panic: leave_scope inconsistency");
        }
@@ -970,7 +942,6 @@ void
 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 {
 #ifdef DEBUGGING
-    dTHR;
     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
     if (CxTYPE(cx) != CXt_SUBST) {
        PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
diff --git a/scope.h b/scope.h
index e6a4209..3e05962 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -33,6 +33,7 @@
 #define SAVEt_I8               32
 #define SAVEt_COMPPAD          33
 #define SAVEt_GENERIC_PVREF    34
+#define SAVEt_PADSV            35
 
 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
 #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
@@ -101,6 +102,7 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 #define SAVESPTR(s)    save_sptr((SV**)&(s))
 #define SAVEPPTR(s)    save_pptr(SOFT_CAST(char**)&(s))
 #define SAVEVPTR(s)    save_vptr((void*)&(s))
+#define SAVEPADSV(s)   save_padsv(s)
 #define SAVEFREESV(s)  save_freesv((SV*)(s))
 #define SAVEFREEOP(o)  save_freeop(SOFT_CAST(OP*)(o))
 #define SAVEFREEPV(p)  save_freepv(SOFT_CAST(char*)(p))
@@ -173,11 +175,14 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
  * SSPTR() converts the index returned by SSNEW/SSNEWa() into a pointer.
  */
 
-#define SSNEW(size)             save_alloc(size, 0)
-#define SSNEWa(size,align)     save_alloc(size, \
+#define SSNEW(size)             Perl_save_alloc(aTHX_ (size), 0)
+#define SSNEWt(n,t)             SSNEW((n)*sizeof(t))
+#define SSNEWa(size,align)     Perl_save_alloc(aTHX_ (size), \
     (align - ((int)((caddr_t)&PL_savestack[PL_savestack_ix]) % align)) % align)
+#define SSNEWat(n,t,align)     SSNEWa((n)*sizeof(t), align)
 
-#define SSPTR(off,type)         ((type) ((char*)PL_savestack + off))
+#define SSPTR(off,type)         ((type)  ((char*)PL_savestack + off))
+#define SSPTRt(off,type)        ((type*) ((char*)PL_savestack + off))
 
 /* A jmpenv packages the state required to perform a proper non-local jump.
  * Note that there is a start_env initialized when perl starts, and top_env
@@ -286,7 +291,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
        OP_REG_TO_MEM;                                  \
     } STMT_END
 
-#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC) 
+#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC)
 
 #define JMPENV_POST_CATCH_ENV(ce) \
     STMT_START {                                       \
@@ -311,7 +316,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
        (v) = EXCEPT_GET_ENV(ce);                               \
     } STMT_END
 
-#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) 
+#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v)
 
 #define JMPENV_POP_ENV(ce) \
     STMT_START {                                               \
@@ -319,7 +324,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env,
            PL_top_env = (ce).je_prev;                          \
     } STMT_END
 
-#define JMPENV_POP  JMPENV_POP_ENV(*(JMPENV*)pcur_env) 
+#define JMPENV_POP  JMPENV_POP_ENV(*(JMPENV*)pcur_env)
 
 #define JMPENV_JUMP(v) \
     STMT_START {                                               \
diff --git a/sv.c b/sv.c
index b795b29..0da17e1 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1,6 +1,6 @@
 /*    sv.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -1285,11 +1285,8 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i)
     case SVt_PVCV:
     case SVt_PVFM:
     case SVt_PVIO:
-       {
-           dTHR;
-           Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
-                 PL_op_desc[PL_op->op_type]);
-       }
+       Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+                  PL_op_desc[PL_op->op_type]);
     }
     (void)SvIOK_only(sv);                      /* validate number */
     SvIVX(sv) = i;
@@ -1323,6 +1320,18 @@ See C<sv_setuv_mg>.
 void
 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
 {
+    /* With these two if statements:
+       u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
+       
+       without
+       u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
+       
+       If you wish to remove them, please benchmark to see what the effect is
+    */
+    if (u <= (UV)IV_MAX) {
+       sv_setiv(sv, (IV)u);
+       return;
+    }
     sv_setiv(sv, 0);
     SvIsUV_on(sv);
     SvUVX(sv) = u;
@@ -1339,7 +1348,21 @@ Like C<sv_setuv>, but also handles 'set' magic.
 void
 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
 {
-    sv_setuv(sv,u);
+    /* With these two if statements:
+       u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
+       
+       without
+       u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
+       
+       If you wish to remove them, please benchmark to see what the effect is
+    */
+    if (u <= (UV)IV_MAX) {
+       sv_setiv(sv, (IV)u);
+    } else {
+       sv_setiv(sv, 0);
+       SvIsUV_on(sv);
+       sv_setuv(sv,u);
+    }
     SvSETMAGIC(sv);
 }
 
@@ -1373,11 +1396,8 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num)
     case SVt_PVCV:
     case SVt_PVFM:
     case SVt_PVIO:
-       {
-           dTHR;
-           Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
-                 PL_op_name[PL_op->op_type]);
-       }
+       Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+                  PL_op_name[PL_op->op_type]);
     }
     SvNVX(sv) = num;
     (void)SvNOK_only(sv);                      /* validate number */
@@ -1402,7 +1422,6 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
 STATIC void
 S_not_a_number(pTHX_ SV *sv)
 {
-    dTHR;
     char tmpbuf[64];
     char *d = tmpbuf;
     char *s;
@@ -1456,16 +1475,225 @@ S_not_a_number(pTHX_ SV *sv)
                    "Argument \"%s\" isn't numeric", tmpbuf);
 }
 
-/* the number can be converted to integer with atol() or atoll() */
-#define IS_NUMBER_TO_INT_BY_ATOL 0x01
-#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
-#define IS_NUMBER_NOT_IV        0x04 /* (IV)atof() may be != atof() */
-#define IS_NUMBER_NEG           0x08 /* not good to cache UV */
-#define IS_NUMBER_INFINITY      0x10 /* this is big */
+/* the number can be converted to integer with atol() or atoll() although */
+#define IS_NUMBER_TO_INT_BY_ATOL     0x01 /* integer (may have decimals) */
+#define IS_NUMBER_TO_INT_BY_STRTOL   0x02 /* it may exceed IV_MAX */
+#define IS_NUMBER_TO_INT_BY_ATOF     0x04 /* seen something like 123e4 */
+#define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
+#define IS_NUMBER_AS_LONG_AS_IV_MAX  0x10 /* may(be not) larger than IV_MAX */
+#define IS_NUMBER_NOT_INT           0x20 /* seen a decimal point or e */
+#define IS_NUMBER_NEG               0x40 /* seen a leading - */
+#define IS_NUMBER_INFINITY          0x80 /* /^\s*-?Infinity\s*$/i */
 
 /* Actually, ISO C leaves conversion of UV to IV undefined, but
    until proven guilty, assume that things are not that bad... */
 
+/* As 64 bit platforms often have an NV that doesn't preserve all bits of
+   an IV (an assumption perl has been based on to date) it becomes necessary
+   to remove the assumption that the NV always carries enough precision to
+   recreate the IV whenever needed, and that the NV is the canonical form.
+   Instead, IV/UV and NV need to be given equal rights. So as to not lose
+   precision as an side effect of conversion (which would lead to insanity
+   and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
+   1) to distinguish between IV/UV/NV slots that have cached a valid
+      conversion where precision was lost and IV/UV/NV slots that have a
+      valid conversion which has lost no precision
+   2) to ensure that if a numeric conversion to one form is request that
+      would lose precision, the precise conversion (or differently
+      imprecise conversion) is also performed and cached, to prevent
+      requests for different numeric formats on the same SV causing
+      lossy conversion chains. (lossless conversion chains are perfectly
+      acceptable (still))
+
+
+   flags are used:
+   SvIOKp is true if the IV slot contains a valid value
+   SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
+   SvNOKp is true if the NV slot contains a valid value
+   SvNOK  is true only if the NV value is accurate
+
+   so
+   while converting from PV to NV check to see if converting that NV to an
+   IV(or UV) would lose accuracy over a direct conversion from PV to
+   IV(or UV). If it would, cache both conversions, return NV, but mark
+   SV as IOK NOKp (ie not NOK).
+
+   while converting from PV to IV check to see if converting that IV to an
+   NV would lose accuracy over a direct conversion from PV to NV. If it
+   would, cache both conversions, flag similarly.
+
+   Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
+   correctly because if IV & NV were set NV *always* overruled.
+   Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
+   changes - now IV and NV together means that the two are interchangeable
+   SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
+   
+   The benefit of this is operations such as pp_add know that if SvIOK is
+   true for both left and right operands, then integer addition can be
+   used instead of floating point. (for cases where the result won't
+   overflow) Before, floating point was always used, which could lead to
+   loss of precision compared with integer addition.
+
+   * making IV and NV equal status should make maths accurate on 64 bit
+     platforms
+   * may speed up maths somewhat if pp_add and friends start to use
+     integers when possible instead of fp. (hopefully the overhead in
+     looking for SvIOK and checking for overflow will not outweigh the
+     fp to integer speedup)
+   * will slow down integer operations (callers of SvIV) on "inaccurate"
+     values, as the change from SvIOK to SvIOKp will cause a call into
+     sv_2iv each time rather than a macro access direct to the IV slot
+   * should speed up number->string conversion on integers as IV is
+     favoured when IV and NV equally accurate
+
+   ####################################################################
+   You had better be using SvIOK_notUV if you want an IV for arithmetic
+   SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
+   SvUOK is true iff UV.
+   ####################################################################
+
+   Your mileage will vary depending your CPUs relative fp to integer
+   performance ratio.
+*/
+
+#ifndef NV_PRESERVES_UV
+#define IS_NUMBER_UNDERFLOW_IV 1
+#define IS_NUMBER_UNDERFLOW_UV 2
+#define IS_NUMBER_IV_AND_UV 2
+#define IS_NUMBER_OVERFLOW_IV 4
+#define IS_NUMBER_OVERFLOW_UV 5
+/* Hopefully your optimiser will consider inlining these two functions.  */
+STATIC int
+S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
+    NV nv = SvNVX(sv);         /* Code simpler and had compiler problems if */
+    UV nv_as_uv = U_V(nv);     /*  these are not in simple variables.   */
+    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
+    if (nv_as_uv <= (UV)IV_MAX) {
+       (void)SvIOKp_on(sv);
+       (void)SvNOKp_on(sv);
+       /* Within suitable range to fit in an IV,  atol won't overflow */
+       /* XXX quite sure? Is that your final answer? not really, I'm
+          trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
+       SvIVX(sv) = (IV)Atol(SvPVX(sv));
+       if (numtype & IS_NUMBER_NOT_INT) {
+           /* I believe that even if the original PV had decimals, they
+              are lost beyond the limit of the FP precision.
+              However, neither is canonical, so both only get p flags.
+              NWC, 2000/11/25 */
+           /* Both already have p flags, so do nothing */
+       } else if (SvIVX(sv) == I_V(nv)) {
+           SvNOK_on(sv);
+           SvIOK_on(sv);
+       } else {
+           SvIOK_on(sv);
+           /* It had no "." so it must be integer.  assert (get in here from
+              sv_2iv and sv_2uv only for ndef HAS_STRTOL and
+              IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
+              conversion routines need audit.  */
+       }
+       return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+    }
+    /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
+    (void)SvIOKp_on(sv);
+    (void)SvNOKp_on(sv);
+#ifdef HAS_STRTOUL
+    {
+       int save_errno = errno;
+       errno = 0;
+       SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
+       if (errno == 0) {
+           if (numtype & IS_NUMBER_NOT_INT) {
+               /* UV and NV both imprecise.  */
+               SvIsUV_on(sv);
+           } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
+               SvNOK_on(sv);
+               SvIOK_on(sv);
+               SvIsUV_on(sv);
+           } else {
+               SvIOK_on(sv);
+               SvIsUV_on(sv);
+           }
+           errno = save_errno;
+           return IS_NUMBER_OVERFLOW_IV;
+       }
+       errno = save_errno;
+       SvNOK_on(sv);
+       /* Must have just overflowed UV, but not enough that an NV could spot
+          this.. */
+       return IS_NUMBER_OVERFLOW_UV;
+    }
+#else
+    /* We've just lost integer precision, nothing we could do. */
+    SvUVX(sv) = nv_as_uv;
+    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
+    /* UV and NV slots equally valid only if we have casting symmetry. */
+    if (numtype & IS_NUMBER_NOT_INT) {
+       SvIsUV_on(sv);
+    } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
+       /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
+          UV_MAX ought to be 0xFF...FFF which won't preserve (We only
+          get to this point if NVs don't preserve UVs) */
+       SvNOK_on(sv);
+       SvIOK_on(sv);
+       SvIsUV_on(sv);
+    } else {
+       /* As above, I believe UV at least as good as NV */
+       SvIsUV_on(sv);
+    }
+#endif /* HAS_STRTOUL */
+    return IS_NUMBER_OVERFLOW_IV;
+}
+
+/* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
+STATIC int
+S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
+{
+    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
+    if (SvNVX(sv) < (NV)IV_MIN) {
+       (void)SvIOKp_on(sv);
+       (void)SvNOK_on(sv);
+       SvIVX(sv) = IV_MIN;
+       return IS_NUMBER_UNDERFLOW_IV;
+    }
+    if (SvNVX(sv) > (NV)UV_MAX) {
+       (void)SvIOKp_on(sv);
+       (void)SvNOK_on(sv);
+       SvIsUV_on(sv);
+       SvUVX(sv) = UV_MAX;
+       return IS_NUMBER_OVERFLOW_UV;
+    }
+    if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
+       (void)SvIOKp_on(sv);
+       (void)SvNOK_on(sv);
+       /* Can't use strtol etc to convert this string */
+       if (SvNVX(sv) <= (UV)IV_MAX) {
+           SvIVX(sv) = I_V(SvNVX(sv));
+           if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+               SvIOK_on(sv); /* Integer is precise. NOK, IOK */
+           } else {
+               /* Integer is imprecise. NOK, IOKp */
+           }
+           return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+       }
+       SvIsUV_on(sv);
+       SvUVX(sv) = U_V(SvNVX(sv));
+       if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+           if (SvUVX(sv) == UV_MAX) {
+               /* As we know that NVs don't preserve UVs, UV_MAX cannot
+                  possibly be preserved by NV. Hence, it must be overflow.
+                  NOK, IOKp */
+               return IS_NUMBER_OVERFLOW_UV;
+           }
+           SvIOK_on(sv); /* Integer is precise. NOK, UOK */
+       } else {
+           /* Integer is imprecise. NOK, IOKp */
+       }
+       return IS_NUMBER_OVERFLOW_IV;
+    }
+    return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
+}
+#endif /* NV_PRESERVES_UV*/
+
 IV
 Perl_sv_2iv(pTHX_ register SV *sv)
 {
@@ -1482,7 +1710,6 @@ Perl_sv_2iv(pTHX_ register SV *sv)
            return asIV(sv);
        if (!SvROK(sv)) {
            if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-               dTHR;
                if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
                    report_uninit();
            }
@@ -1497,8 +1724,10 @@ Perl_sv_2iv(pTHX_ register SV *sv)
              return SvIV(tmpstr);
          return PTR2IV(SvRV(sv));
        }
+       if (SvREADONLY(sv) && SvFAKE(sv)) {
+           sv_force_normal(sv);
+       }
        if (SvREADONLY(sv) && !SvOK(sv)) {
-           dTHR;
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit();
            return 0;
@@ -1513,19 +1742,71 @@ Perl_sv_2iv(pTHX_ register SV *sv)
        }
     }
     if (SvNOKp(sv)) {
-       /* We can cache the IV/UV value even if it not good enough
-        * to reconstruct NV, since the conversion to PV will prefer
-        * NV over IV/UV.
-        */
+       /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+        * without also getting a cached IV/UV from it at the same time
+        * (ie PV->NV conversion should detect loss of accuracy and cache
+        * IV or UV at same time to avoid this.  NWC */
 
        if (SvTYPE(sv) == SVt_NV)
            sv_upgrade(sv, SVt_PVNV);
 
-       (void)SvIOK_on(sv);
-       if (SvNVX(sv) < (NV)IV_MAX + 0.5)
+       (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
+       /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
+          certainly cast into the IV range at IV_MAX, whereas the correct
+          answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
+          cases go to UV */
+       if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
            SvIVX(sv) = I_V(SvNVX(sv));
+           if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+               && (((UV)1 << NV_PRESERVES_UV_BITS) >
+                   (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+               /* Don't flag it as "accurately an integer" if the number
+                  came from a (by definition imprecise) NV operation, and
+                  we're outside the range of NV integer precision */
+#endif
+               ) {
+               SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
+               DEBUG_c(PerlIO_printf(Perl_debug_log,
+                                     "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
+                                     PTR2UV(sv),
+                                     SvNVX(sv),
+                                     SvIVX(sv)));
+
+           } else {
+               /* IV not precise.  No need to convert from PV, as NV
+                  conversion would already have cached IV if it detected
+                  that PV->IV would be better than PV->NV->IV
+                  flags already correct - don't set public IOK.  */
+               DEBUG_c(PerlIO_printf(Perl_debug_log,
+                                     "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
+                                     PTR2UV(sv),
+                                     SvNVX(sv),
+                                     SvIVX(sv)));
+           }
+           /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+              but the cast (NV)IV_MIN rounds to a the value less (more
+              negative) than IV_MIN which happens to be equal to SvNVX ??
+              Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+              NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+              (NV)UVX == NVX are both true, but the values differ. :-(
+              Hopefully for 2s complement IV_MIN is something like
+              0x8000000000000000 which will be exact. NWC */
+       } 
        else {
            SvUVX(sv) = U_V(SvNVX(sv));
+           if (
+               (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef  NV_PRESERVES_UV
+               /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+               /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+               && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+               /* Don't flag it as "accurately an integer" if the number
+                  came from a (by definition imprecise) NV operation, and
+                  we're outside the range of NV integer precision */
+#endif
+               )
+               SvIOK_on(sv);
            SvIsUV_on(sv);
          ret_iv_max:
            DEBUG_c(PerlIO_printf(Perl_debug_log,
@@ -1545,47 +1826,117 @@ Perl_sv_2iv(pTHX_ register SV *sv)
        
           This means that if we cache such an IV, we need to cache the
           NV as well.  Moreover, we trade speed for space, and do not
-          cache the NV if not needed.
+          cache the NV if we are sure it's not needed.
         */
-       if (numtype & IS_NUMBER_NOT_IV) {
-           /* May be not an integer.  Need to cache NV if we cache IV
-            * - otherwise future conversion to NV will be wrong.  */
-           NV d;
-
-           d = Atof(SvPVX(sv));
 
-           if (SvTYPE(sv) < SVt_PVNV)
-               sv_upgrade(sv, SVt_PVNV);
-           SvNVX(sv) = d;
-           (void)SvNOK_on(sv);
+       if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
+           /* The NV may be reconstructed from IV - safe to cache IV,
+               which may be calculated by atol(). */
+           if (SvTYPE(sv) < SVt_PVIV)
+               sv_upgrade(sv, SVt_PVIV);
            (void)SvIOK_on(sv);
+           SvIVX(sv) = Atol(SvPVX(sv));
+       } else {
+#ifdef HAS_STRTOL
+           IV i;
+           int save_errno = errno;
+           /* Is it an integer that we could convert with strtol?
+              So try it, and if it doesn't set errno then it's pukka.
+              This should be faster than going atof and then thinking.  */
+           if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
+                 == IS_NUMBER_TO_INT_BY_STRTOL)
+               /* && is a sequence point. Without it not sure if I'm trying
+                  to do too much between sequence points and hence going
+                  undefined */
+               && ((errno = 0), 1) /* , 1 so always true */
+               && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
+               && (errno == 0)) {
+               if (SvTYPE(sv) < SVt_PVIV)
+                   sv_upgrade(sv, SVt_PVIV);
+               (void)SvIOK_on(sv);
+               SvIVX(sv) = i;
+               errno = save_errno;
+           } else
+#endif
+           {
+               NV d;
+#ifdef HAS_STRTOL
+               /* Hopefully trace flow will optimise this away where possible
+                */
+               errno = save_errno;
+#endif
+               /* It wasn't an integer, or it overflowed, or we don't have
+                  strtol. Do things the slow way - check if it's a UV etc. */
+               d = Atof(SvPVX(sv));
+
+               if (SvTYPE(sv) < SVt_PVNV)
+                   sv_upgrade(sv, SVt_PVNV);
+               SvNVX(sv) = d;
+
+               if (! numtype && ckWARN(WARN_NUMERIC))
+                   not_a_number(sv);
+
 #if defined(USE_LONG_DOUBLE)
-           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
-                                 PTR2UV(sv), SvNVX(sv)));
+               DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
+                                     PTR2UV(sv), SvNVX(sv)));
 #else
-           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
-                                 PTR2UV(sv), SvNVX(sv)));
+               DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+                                     PTR2UV(sv), SvNVX(sv)));
 #endif
-           if (SvNVX(sv) < (NV)IV_MAX + 0.5)
-               SvIVX(sv) = I_V(SvNVX(sv));
-           else {
-               SvUVX(sv) = U_V(SvNVX(sv));
-               SvIsUV_on(sv);
-               goto ret_iv_max;
+
+
+#ifdef NV_PRESERVES_UV
+               (void)SvIOKp_on(sv);
+               (void)SvNOK_on(sv);
+               if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+                   SvIVX(sv) = I_V(SvNVX(sv));
+                   if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+                       SvIOK_on(sv);
+                   } else {
+                       /* Integer is imprecise. NOK, IOKp */
+                   }
+                   /* UV will not work better than IV */
+               } else {
+                   if (SvNVX(sv) > (NV)UV_MAX) {
+                       SvIsUV_on(sv);
+                       /* Integer is inaccurate. NOK, IOKp, is UV */
+                       SvUVX(sv) = UV_MAX;
+                       SvIsUV_on(sv);
+                   } else {
+                       SvUVX(sv) = U_V(SvNVX(sv));
+                       /* 0xFFFFFFFFFFFFFFFF not an issue in here */
+                       if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+                           SvIOK_on(sv);
+                           SvIsUV_on(sv);
+                       } else {
+                           /* Integer is imprecise. NOK, IOKp, is UV */
+                           SvIsUV_on(sv);
+                       }
+                   }
+                   goto ret_iv_max;
+               }
+#else /* NV_PRESERVES_UV */
+               if (((UV)1 << NV_PRESERVES_UV_BITS) >
+                   U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+                   /* Small enough to preserve all bits. */
+                   (void)SvIOKp_on(sv);
+                   SvNOK_on(sv);
+                   SvIVX(sv) = I_V(SvNVX(sv));
+                   if ((NV)(SvIVX(sv)) == SvNVX(sv))
+                       SvIOK_on(sv);
+                   /* Assumption: first non-preserved integer is < IV_MAX,
+                      this NV is in the preserved range, therefore: */
+                   if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+                         < (UV)IV_MAX)) {
+                       Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+                   }
+               } else if (sv_2iuv_non_preserve (sv, numtype)
+                          >= IS_NUMBER_OVERFLOW_IV)
+                   goto ret_iv_max;
+#endif /* NV_PRESERVES_UV */
            }
        }
-       else {  /* The NV may be reconstructed from IV - safe to cache IV,
-                  which may be calculated by atol(). */
-           if (SvTYPE(sv) < SVt_PVIV)
-               sv_upgrade(sv, SVt_PVIV);
-           (void)SvIOK_on(sv);
-           SvIVX(sv) = Atol(SvPVX(sv));
-           if (! numtype && ckWARN(WARN_NUMERIC))
-               not_a_number(sv);
-       }
-    }
-    else  {
-       dTHR;
+    } else  {
        if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
            report_uninit();
        if (SvTYPE(sv) < SVt_IV)
@@ -1613,7 +1964,6 @@ Perl_sv_2uv(pTHX_ register SV *sv)
            return asUV(sv);
        if (!SvROK(sv)) {
            if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-               dTHR;
                if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
                    report_uninit();
            }
@@ -1628,8 +1978,10 @@ Perl_sv_2uv(pTHX_ register SV *sv)
              return SvUV(tmpstr);
          return PTR2UV(SvRV(sv));
        }
+       if (SvREADONLY(sv) && SvFAKE(sv)) {
+           sv_force_normal(sv);
+       }
        if (SvREADONLY(sv) && !SvOK(sv)) {
-           dTHR;
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit();
            return 0;
@@ -1644,26 +1996,74 @@ Perl_sv_2uv(pTHX_ register SV *sv)
        }
     }
     if (SvNOKp(sv)) {
-       /* We can cache the IV/UV value even if it not good enough
-        * to reconstruct NV, since the conversion to PV will prefer
-        * NV over IV/UV.
-        */
+       /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+        * without also getting a cached IV/UV from it at the same time
+        * (ie PV->NV conversion should detect loss of accuracy and cache
+        * IV or UV at same time to avoid this. */
+       /* IV-over-UV optimisation - choose to cache IV if possible */
+
        if (SvTYPE(sv) == SVt_NV)
            sv_upgrade(sv, SVt_PVNV);
-       (void)SvIOK_on(sv);
-       if (SvNVX(sv) >= -0.5) {
-           SvIsUV_on(sv);
-           SvUVX(sv) = U_V(SvNVX(sv));
-       }
-       else {
+
+       (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
+       if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
            SvIVX(sv) = I_V(SvNVX(sv));
-         ret_zero:
+           if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+               && (((UV)1 << NV_PRESERVES_UV_BITS) >
+                   (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+               /* Don't flag it as "accurately an integer" if the number
+                  came from a (by definition imprecise) NV operation, and
+                  we're outside the range of NV integer precision */
+#endif
+               ) {
+               SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
+               DEBUG_c(PerlIO_printf(Perl_debug_log,
+                                     "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
+                                     PTR2UV(sv),
+                                     SvNVX(sv),
+                                     SvIVX(sv)));
+
+           } else {
+               /* IV not precise.  No need to convert from PV, as NV
+                  conversion would already have cached IV if it detected
+                  that PV->IV would be better than PV->NV->IV
+                  flags already correct - don't set public IOK.  */
+               DEBUG_c(PerlIO_printf(Perl_debug_log,
+                                     "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
+                                     PTR2UV(sv),
+                                     SvNVX(sv),
+                                     SvIVX(sv)));
+           }
+           /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+              but the cast (NV)IV_MIN rounds to a the value less (more
+              negative) than IV_MIN which happens to be equal to SvNVX ??
+              Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+              NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+              (NV)UVX == NVX are both true, but the values differ. :-(
+              Hopefully for 2s complement IV_MIN is something like
+              0x8000000000000000 which will be exact. NWC */
+       } 
+       else {
+           SvUVX(sv) = U_V(SvNVX(sv));
+           if (
+               (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef  NV_PRESERVES_UV
+               /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+               /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+               && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+               /* Don't flag it as "accurately an integer" if the number
+                  came from a (by definition imprecise) NV operation, and
+                  we're outside the range of NV integer precision */
+#endif
+               )
+               SvIOK_on(sv);
+           SvIsUV_on(sv);
            DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
+                                 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
                                  PTR2UV(sv),
-                                 SvIVX(sv),
-                                 (IV)(UV)SvIVX(sv)));
-           return (UV)SvIVX(sv);
+                                 SvUVX(sv),
+                                 SvUVX(sv)));
        }
     }
     else if (SvPOKp(sv) && SvLEN(sv)) {
@@ -1677,73 +2077,141 @@ Perl_sv_2uv(pTHX_ register SV *sv)
           NV as well.  Moreover, we trade speed for space, and do not
           cache the NV if not needed.
         */
-       if (numtype & IS_NUMBER_NOT_IV) {
-           /* May be not an integer.  Need to cache NV if we cache IV
-            * - otherwise future conversion to NV will be wrong.  */
-           NV d;
 
-           d = Atof(SvPVX(sv));
-
-           if (SvTYPE(sv) < SVt_PVNV)
-               sv_upgrade(sv, SVt_PVNV);
-           SvNVX(sv) = d;
-           (void)SvNOK_on(sv);
-           (void)SvIOK_on(sv);
-#if defined(USE_LONG_DOUBLE)
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
-                                 PTR2UV(sv), SvNVX(sv)));
-#else
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                 "0x%"UVxf" 2nv(%g)\n",
-                                 PTR2UV(sv), SvNVX(sv)));
-#endif
-           if (SvNVX(sv) < -0.5) {
-               SvIVX(sv) = I_V(SvNVX(sv));
-               goto ret_zero;
-           } else {
-               SvUVX(sv) = U_V(SvNVX(sv));
-               SvIsUV_on(sv);
-           }
-       }
-       else if (numtype & IS_NUMBER_NEG) {
+       if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
            /* The NV may be reconstructed from IV - safe to cache IV,
-              which may be calculated by atol(). */
-           if (SvTYPE(sv) == SVt_PV)
-               sv_upgrade(sv, SVt_PVIV);
-           (void)SvIOK_on(sv);
-           SvIVX(sv) = (IV)Atol(SvPVX(sv));
-       }
-       else if (numtype) {             /* Non-negative */
-           /* The NV may be reconstructed from UV - safe to cache UV,
-              which may be calculated by strtoul()/atol. */
-           if (SvTYPE(sv) == SVt_PV)
+               which may be calculated by atol(). */
+           if (SvTYPE(sv) < SVt_PVIV)
                sv_upgrade(sv, SVt_PVIV);
            (void)SvIOK_on(sv);
-           (void)SvIsUV_on(sv);
+           SvIVX(sv) = Atol(SvPVX(sv));
+       } else {
+#ifdef HAS_STRTOUL
+           UV u;
+           char *num_begin = SvPVX(sv);
+           int save_errno = errno;
+           
+           /* seems that strtoul taking numbers that start with - is
+              implementation dependant, and can't be relied upon.  */
+           if (numtype & IS_NUMBER_NEG) {
+               /* Not totally defensive. assumine that looks_like_num
+                  didn't lie about a - sign */
+               while (isSPACE(*num_begin))
+                   num_begin++;
+               if (*num_begin == '-')
+                   num_begin++;
+           }
+    
+           /* Is it an integer that we could convert with strtoul?
+              So try it, and if it doesn't set errno then it's pukka.
+              This should be faster than going atof and then thinking.  */
+           if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
+                == IS_NUMBER_TO_INT_BY_STRTOL)
+               && ((errno = 0), 1) /* always true */
+               && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
+               && (errno == 0)
+               /* If known to be negative, check it didn't undeflow IV 
+                  XXX possibly we should put more negative values as NVs
+                  direct rather than go via atof below */
+               && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
+               errno = save_errno;
+
+               if (SvTYPE(sv) < SVt_PVIV)
+                   sv_upgrade(sv, SVt_PVIV);
+               (void)SvIOK_on(sv);
+
+               /* If it's negative must use IV.
+                  IV-over-UV optimisation */
+               if (numtype & IS_NUMBER_NEG) {
+                   SvIVX(sv) = -(IV)u;
+               } else if (u <= (UV) IV_MAX) {
+                   SvIVX(sv) = (IV)u;
+               } else {
+                   /* it didn't overflow, and it was positive. */
+                   SvUVX(sv) = u;
+                   SvIsUV_on(sv);
+               }
+           } else
+#endif
+           {
+               NV d;
 #ifdef HAS_STRTOUL
-           SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
-#else                  /* no atou(), but we know the number fits into IV... */
-                       /* The only problem may be if it is negative... */
-           SvUVX(sv) = (UV)Atol(SvPVX(sv));
+               /* Hopefully trace flow will optimise this away where possible
+                */
+               errno = save_errno;
 #endif
-       }
-       else {                          /* Not a number.  Cache 0. */
-           dTHR;
+               /* It wasn't an integer, or it overflowed, or we don't have
+                  strtol. Do things the slow way - check if it's a IV etc. */
+               d = Atof(SvPVX(sv));
 
-           if (SvTYPE(sv) < SVt_PVIV)
-               sv_upgrade(sv, SVt_PVIV);
-           (void)SvIOK_on(sv);
-           (void)SvIsUV_on(sv);
-           SvUVX(sv) = 0;              /* We assume that 0s have the
-                                          same bitmap in IV and UV. */
-           if (ckWARN(WARN_NUMERIC))
-               not_a_number(sv);
+               if (SvTYPE(sv) < SVt_PVNV)
+                   sv_upgrade(sv, SVt_PVNV);
+               SvNVX(sv) = d;
+
+               if (! numtype && ckWARN(WARN_NUMERIC))
+                   not_a_number(sv);
+
+#if defined(USE_LONG_DOUBLE)
+               DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
+                                     PTR2UV(sv), SvNVX(sv)));
+#else
+               DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+                                     PTR2UV(sv), SvNVX(sv)));
+#endif
+
+#ifdef NV_PRESERVES_UV
+               (void)SvIOKp_on(sv);
+               (void)SvNOK_on(sv);
+               if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+                   SvIVX(sv) = I_V(SvNVX(sv));
+                   if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+                       SvIOK_on(sv);
+                   } else {
+                       /* Integer is imprecise. NOK, IOKp */
+                   }
+                   /* UV will not work better than IV */
+               } else {
+                   if (SvNVX(sv) > (NV)UV_MAX) {
+                       SvIsUV_on(sv);
+                       /* Integer is inaccurate. NOK, IOKp, is UV */
+                       SvUVX(sv) = UV_MAX;
+                       SvIsUV_on(sv);
+                   } else {
+                       SvUVX(sv) = U_V(SvNVX(sv));
+                       /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
+                          NV preservse UV so can do correct comparison.  */
+                       if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+                           SvIOK_on(sv);
+                           SvIsUV_on(sv);
+                       } else {
+                           /* Integer is imprecise. NOK, IOKp, is UV */
+                           SvIsUV_on(sv);
+                       }
+                   }
+               }
+#else /* NV_PRESERVES_UV */
+               if (((UV)1 << NV_PRESERVES_UV_BITS) >
+                   U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+                   /* Small enough to preserve all bits. */
+                   (void)SvIOKp_on(sv);
+                   SvNOK_on(sv);
+                   SvIVX(sv) = I_V(SvNVX(sv));
+                   if ((NV)(SvIVX(sv)) == SvNVX(sv))
+                       SvIOK_on(sv);
+                   /* Assumption: first non-preserved integer is < IV_MAX,
+                      this NV is in the preserved range, therefore: */
+                   if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+                         < (UV)IV_MAX)) {
+                       Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+                   }
+               } else
+                   sv_2iuv_non_preserve (sv, numtype);
+#endif /* NV_PRESERVES_UV */
+           }
        }
     }
     else  {
        if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-           dTHR;
            if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
                report_uninit();
        }
@@ -1768,7 +2236,6 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        if (SvNOKp(sv))
            return SvNVX(sv);
        if (SvPOKp(sv) && SvLEN(sv)) {
-           dTHR;
            if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
                not_a_number(sv);
            return Atof(SvPVX(sv));
@@ -1781,7 +2248,6 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        }       
         if (!SvROK(sv)) {
            if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-               dTHR;
                if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
                    report_uninit();
            }
@@ -1796,8 +2262,10 @@ Perl_sv_2nv(pTHX_ register SV *sv)
              return SvNV(tmpstr);
          return PTR2NV(SvRV(sv));
        }
+       if (SvREADONLY(sv) && SvFAKE(sv)) {
+           sv_force_normal(sv);
+       }
        if (SvREADONLY(sv) && !SvOK(sv)) {
-           dTHR;
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit();
            return 0.0;
@@ -1831,23 +2299,63 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
     {
        SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
+#ifdef NV_PRESERVES_UV
+       SvNOK_on(sv);
+#else
+       /* Only set the public NV OK flag if this NV preserves the IV  */
+       /* Check it's not 0xFFFFFFFFFFFFFFFF */
+       if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
+                      : (SvIVX(sv) == I_V(SvNVX(sv))))
+           SvNOK_on(sv);
+       else
+           SvNOKp_on(sv);
+#endif
     }
     else if (SvPOKp(sv) && SvLEN(sv)) {
-       dTHR;
        if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
            not_a_number(sv);
        SvNVX(sv) = Atof(SvPVX(sv));
+#ifdef NV_PRESERVES_UV
+       SvNOK_on(sv);
+#else
+       /* Only set the public NV OK flag if this NV preserves the value in
+          the PV at least as well as an IV/UV would.
+          Not sure how to do this 100% reliably. */
+       /* if that shift count is out of range then Configure's test is
+          wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+          UV_BITS */
+       if (((UV)1 << NV_PRESERVES_UV_BITS) >
+           U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
+           SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+       else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
+               /* Definitely too large/small to fit in an integer, so no loss
+                  of precision going to integer in the future via NV */
+           SvNOK_on(sv);
+       } else {
+           /* Is it something we can run through strtol etc (ie no
+              trailing exponent part)? */
+           int numtype = looks_like_number(sv);
+           /* XXX probably should cache this if called above */
+
+           if (!(numtype &
+                 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
+               /* Can't use strtol etc to convert this string, so don't try */
+               SvNOK_on(sv);
+           } else
+               sv_2inuv_non_preserve (sv, numtype);
+       }
+#endif /* NV_PRESERVES_UV */
     }
     else  {
-       dTHR;
        if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
            report_uninit();
        if (SvTYPE(sv) < SVt_NV)
            /* Typically the caller expects that sv_any is not NULL now.  */
+           /* XXX Ilya implies that this is a bug in callers that assume this
+              and ideally should be fixed.  */
            sv_upgrade(sv, SVt_NV);
        return 0.0;
     }
-    SvNOK_on(sv);
 #if defined(USE_LONG_DOUBLE)
     DEBUG_c({
        STORE_NUMERIC_LOCAL_SET_STANDARD();
@@ -1875,7 +2383,6 @@ S_asIV(pTHX_ SV *sv)
     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
        return Atol(SvPVX(sv));
     if (!numtype) {
-       dTHR;
        if (ckWARN(WARN_NUMERIC))
            not_a_number(sv);
     }
@@ -1893,7 +2400,6 @@ S_asUV(pTHX_ SV *sv)
        return Strtoul(SvPVX(sv), Null(char**), 10);
 #endif
     if (!numtype) {
-       dTHR;
        if (ckWARN(WARN_NUMERIC))
            not_a_number(sv);
     }
@@ -1902,23 +2408,32 @@ S_asUV(pTHX_ SV *sv)
 
 /*
  * Returns a combination of (advisory only - can get false negatives)
- *     IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
- *     IS_NUMBER_NEG
+ * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
+ * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
+ * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
  * 0 if does not look like number.
  *
- * In fact possible values are 0 and
- * IS_NUMBER_TO_INT_BY_ATOL                            123
- * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV         123.1
- * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV         123e0
+ * (atol and strtol stop when they hit a decimal point. strtol will return
+ * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
+ * do this, and vendors have had 11 years to get it right.
+ * However, will try to make it still work with only atol
+ *  
+ * IS_NUMBER_TO_INT_BY_ATOL    123456789 or 123456789.3  definitely < IV_MAX
+ * IS_NUMBER_TO_INT_BY_STRTOL  123456789 or 123456789.3  if digits = IV_MAX
+ * IS_NUMBER_TO_INT_BY_ATOF    123456789e0               or >> IV_MAX
+ * IS_NUMBER_LONGER_THAN_IV_MAX          lots of digits, don't bother with atol
+ * IS_NUMBER_AS_LONG_AS_IV_MAX   atol might hit LONG_MAX, might not.
+ * IS_NUMBER_NOT_INT           saw "." or "e"
+ * IS_NUMBER_NEG
  * IS_NUMBER_INFINITY
- * with a possible addition of IS_NUMBER_NEG.
  */
 
 /*
 =for apidoc looks_like_number
 
 Test if an the content of an SV looks like a number (or is a
-number).
+number). C<Inf> and C<Infinity> are treated as numbers (so will not
+issue a non-numeric warning), even if your atof() doesn't grok them.
 
 =cut
 */
@@ -1956,9 +2471,10 @@ Perl_looks_like_number(pTHX_ SV *sv)
 
     nbegin = s;
     /*
-     * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
-     * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
-     * (int)atof().
+     * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to 
+     * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
+     * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
+     * will need (int)atof().
      */
 
     /* next must be digit or the radix separator or beginning of infinity */
@@ -1967,10 +2483,34 @@ Perl_looks_like_number(pTHX_ SV *sv)
            s++;
         } while (isDIGIT(*s));
 
-       if (s - nbegin >= TYPE_DIGITS(IV))      /* Cannot cache ato[ul]() */
-           numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
-       else
+       /* Aaargh. long long really is irritating.
+          In the gospel according to ANSI 1989, it is an axiom that "long"
+          is the longest integer type, and that if you don't know how long
+          something is you can cast it to long, and nothing will be lost
+          (except possibly speed of execution if long is slower than the
+          type is was).
+          Now, one can't be sure if the old rules apply, or long long
+          (or some other newfangled thing) is actually longer than the
+          (formerly) longest thing.
+       */
+       /* This lot will work for 64 bit  *as long as* either
+          either long is 64 bit
+          or     we can find both strtol/strtoq and strtoul/strtouq
+          If not, we really should refuse to let the user use 64 bit IVs
+          By "64 bit" I really mean IVs that don't get preserved by NVs
+          It also should work for 128 bit IVs. Can any lend me a machine to
+          test this?
+       */
+       if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
+           numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
+       else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
+                                         ? sizeof(long) : sizeof (IV))*8-1))
            numtype |= IS_NUMBER_TO_INT_BY_ATOL;
+       else
+           /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
+              digit less (IV_MAX=  9223372036854775807,
+                          UV_MAX= 18446744073709551615) so be cautious  */
+           numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
 
         if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
@@ -1978,7 +2518,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
 #endif
            ) {
            s++;
-           numtype |= IS_NUMBER_NOT_IV;
+           numtype |= IS_NUMBER_NOT_INT;
             while (isDIGIT(*s))  /* optional digits after the radix */
                 s++;
         }
@@ -1989,7 +2529,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
 #endif
            ) {
         s++;
-       numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
+       numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
         /* no digits before the radix means we need digits after it */
         if (isDIGIT(*s)) {
            do {
@@ -2007,6 +2547,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
            s++; if (*s != 'I' && *s != 'i') return 0;
            s++; if (*s != 'T' && *s != 't') return 0;
            s++; if (*s != 'Y' && *s != 'y') return 0;
+           s++;
        }
        sawinf = 1;
     }
@@ -2014,12 +2555,13 @@ Perl_looks_like_number(pTHX_ SV *sv)
         return 0;
 
     if (sawinf)
-       numtype = IS_NUMBER_INFINITY;
+       numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign  */
+         | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
     else {
        /* we can have an optional exponent part */
        if (*s == 'e' || *s == 'E') {
-           numtype &= ~IS_NUMBER_NEG;
-           numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
+           numtype &= IS_NUMBER_NEG;
+           numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
            s++;
            if (*s == '+' || *s == '-')
                s++;
@@ -2108,7 +2650,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
        }
         if (!SvROK(sv)) {
            if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-               dTHR;
                if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
                    report_uninit();
            }
@@ -2135,7 +2676,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
                          == (SVs_OBJECT|SVs_RMG))
                         && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
                         && (mg = mg_find(sv, 'r'))) {
-                       dTHR;
                        regexp *re = (regexp *)mg->mg_obj;
 
                        if (!mg->mg_ptr) {
@@ -2206,18 +2746,39 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            return s;
        }
        if (SvREADONLY(sv) && !SvOK(sv)) {
-           dTHR;
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit();
            *lp = 0;
            return "";
        }
     }
-    if (SvNOKp(sv)) {                  /* See note in sv_2uv() */
-       /* XXXX 64-bit?  IV may have better precision... */
-       /* I tried changing this to be 64-bit-aware and
-        * the t/op/numconvert.t became very, very, angry.
-        * --jhi Sep 1999 */
+    if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+       /* I'm assuming that if both IV and NV are equally valid then
+          converting the IV is going to be more efficient */
+       U32 isIOK = SvIOK(sv);
+       U32 isUIOK = SvIsUV(sv);
+       char buf[TYPE_CHARS(UV)];
+       char *ebuf, *ptr;
+
+       if (SvTYPE(sv) < SVt_PVIV)
+           sv_upgrade(sv, SVt_PVIV);
+       if (isUIOK)
+           ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+       else
+           ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+       SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
+       Move(ptr,SvPVX(sv),ebuf - ptr,char);
+       SvCUR_set(sv, ebuf - ptr);
+       s = SvEND(sv);
+       *s = '\0';
+       if (isIOK)
+           SvIOK_on(sv);
+       else
+           SvIOKp_on(sv);
+       if (isUIOK)
+           SvIsUV_on(sv);
+    }
+    else if (SvNOKp(sv)) {
        if (SvTYPE(sv) < SVt_PVNV)
            sv_upgrade(sv, SVt_PVNV);
        /* The +20 is pure guesswork.  Configure test needed. --jhi */
@@ -2243,38 +2804,10 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            *--s = '\0';
 #endif
     }
-    else if (SvIOKp(sv)) {
-       U32 isIOK = SvIOK(sv);
-       U32 isUIOK = SvIsUV(sv);
-       char buf[TYPE_CHARS(UV)];
-       char *ebuf, *ptr;
-
-       if (SvTYPE(sv) < SVt_PVIV)
-           sv_upgrade(sv, SVt_PVIV);
-       if (isUIOK)
-           ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
-       else
-           ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
-       SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
-       Move(ptr,SvPVX(sv),ebuf - ptr,char);
-       SvCUR_set(sv, ebuf - ptr);
-       s = SvEND(sv);
-       *s = '\0';
-       if (isIOK)
-           SvIOK_on(sv);
-       else
-           SvIOKp_on(sv);
-       if (isUIOK)
-           SvIsUV_on(sv);
-       SvPOK_on(sv);
-    }
     else {
-       dTHR;
        if (ckWARN(WARN_UNINITIALIZED)
            && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
-       {
            report_uninit();
-       }
        *lp = 0;
        if (SvTYPE(sv) < SVt_PV)
            /* Typically the caller expects that sv_any is not NULL now.  */
@@ -2352,7 +2885,7 @@ char *
 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
 {
     sv_utf8_upgrade(sv);
-    return sv_2pv(sv,lp);
+    return SvPV(sv,*lp);
 }
 
 /* This function is only called on magical items */
@@ -2365,7 +2898,6 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     if (!SvOK(sv))
        return 0;
     if (SvROK(sv)) {
-       dTHR;
        SV* tmpsv;
         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
                 (SvRV(tmpsv) != SvRV(sv)))
@@ -2405,26 +2937,37 @@ Convert the PV of an SV to its UTF8-encoded form.
 void
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
-    char *s, *t;
-    bool hibit;
+    char *s, *t, *e;
+    int  hibit = 0;
 
     if (!sv || !SvPOK(sv) || SvUTF8(sv))
        return;
 
     /* This function could be much more efficient if we had a FLAG in SVs
      * to signal if there are any hibit chars in the PV.
+     * Given that there isn't make loop fast as possible
      */
-    for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
-       if (*t & 0x80)
-           hibit = TRUE;
+    s = SvPVX(sv);
+    e = SvEND(sv);
+    t = s;
+    while (t < e) {
+       if ((hibit = UTF8_IS_CONTINUED(*t++)))
+           break;
+    }
 
     if (hibit) {
-       STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+       STRLEN len;
+       if (SvREADONLY(sv) && SvFAKE(sv)) {
+           sv_force_normal(sv);
+           s = SvPVX(sv);
+       }
+       len = SvCUR(sv) + 1; /* Plus the \0 */
        SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
        SvCUR(sv) = len - 1;
+       if (SvLEN(sv) != 0)
+           Safefree(s); /* No longer using what was there before. */
        SvLEN(sv) = len; /* No longer know the real size. */
        SvUTF8_on(sv);
-       Safefree(s); /* No longer using what was there before. */
     }
 }
 
@@ -2443,22 +2986,26 @@ bool
 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
     if (SvPOK(sv) && SvUTF8(sv)) {
-        char *c = SvPVX(sv);
-       STRLEN len = SvCUR(sv) + 1;     /* include trailing NUL */
-        if (!utf8_to_bytes((U8*)c, &len)) {
-           if (fail_ok)
-               return FALSE;
-           else {
-               if (PL_op)
-                   Perl_croak(aTHX_ "Wide character in %s",
-                              PL_op_desc[PL_op->op_type]);
-               else
-                   Perl_croak(aTHX_ "Wide character");
+        if (SvCUR(sv)) {
+           char *c = SvPVX(sv);
+           STRLEN len = SvCUR(sv);
+
+           if (!utf8_to_bytes((U8*)c, &len)) {
+               if (fail_ok)
+                   return FALSE;
+               else {
+                   if (PL_op)
+                       Perl_croak(aTHX_ "Wide character in %s",
+                                  PL_op_desc[PL_op->op_type]);
+                   else
+                       Perl_croak(aTHX_ "Wide character");
+               }
            }
+           SvCUR(sv) = len;
        }
-       SvCUR(sv) = len - 1;
        SvUTF8_off(sv);
     }
+
     return TRUE;
 }
 
@@ -2483,6 +3030,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
 {
     if (SvPOK(sv)) {
         char *c;
+        char *e;
         bool has_utf = FALSE;
         if (!sv_utf8_downgrade(sv, TRUE))
            return FALSE;
@@ -2493,9 +3041,9 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
         c = SvPVX(sv);
        if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
            return FALSE;
-
-        while (c < SvEND(sv)) {
-            if (*c++ & 0x80) {
+        e = SvEND(sv);
+        while (c < e) {
+            if (UTF8_IS_CONTINUED(*c++)) {
                SvUTF8_on(sv);
                break;
            }
@@ -2524,7 +3072,6 @@ C<sv_setsv_mg>.
 void
 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 {
-    dTHR;
     register U32 sflags;
     register int dtype;
     register int stype;
@@ -2567,7 +3114,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            SvIVX(dstr) = SvIVX(sstr);
            if (SvIsUV(sstr))
                SvIsUV_on(dstr);
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            return;
        }
        goto undef_sstr;
@@ -2587,7 +3135,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            }
            SvNVX(dstr) = SvNVX(sstr);
            (void)SvNOK_only(dstr);
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            return;
        }
        goto undef_sstr;
@@ -2656,7 +3205,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            GvINTRO_off(dstr);          /* one-shot flag */
            gp_free((GV*)dstr);
            GvGP(dstr) = gp_ref(GvGP(sstr));
-           SvTAINT(dstr);
+           if (SvTAINTED(sstr))
+               SvTAINT(dstr);
            if (GvIMPORTED(dstr) != GVf_IMPORTED
                && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
            {
@@ -2745,12 +3295,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                            if (!GvCVGEN((GV*)dstr) &&
                                (CvROOT(cv) || CvXSUB(cv)))
                            {
-                               SV *const_sv = cv_const_sv(cv);
-                               bool const_changed = TRUE;
-                               if(const_sv)
-                                   const_changed = sv_cmp(const_sv,
-                                          op_const_sv(CvSTART((CV*)sref),
-                                                      (CV*)sref));
+                               SV *const_sv;
                                /* ahem, death to those who redefine
                                 * active sort subs */
                                if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -2758,11 +3303,20 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                                    Perl_croak(aTHX_
                                    "Can't redefine active sort subroutine %s",
                                          GvENAME((GV*)dstr));
-                               if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
-                                   Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
-                                            "Constant subroutine %s redefined"
-                                            : "Subroutine %s redefined",
-                                            GvENAME((GV*)dstr));
+                               /* Redefining a sub - warning is mandatory if
+                                  it was a const and its value changed. */
+                               if (ckWARN(WARN_REDEFINE)
+                                   || (CvCONST(cv)
+                                       && (!CvCONST((CV*)sref)
+                                           || sv_cmp(cv_const_sv(cv),
+                                                     cv_const_sv((CV*)sref)))))
+                               {
+                                   Perl_warner(aTHX_ WARN_REDEFINE,
+                                       CvCONST(cv)
+                                       ? "Constant subroutine %s redefined"
+                                       : "Subroutine %s redefined",
+                                       GvENAME((GV*)dstr));
+                               }
                            }
                            cv_ckproto(cv, (GV*)dstr,
                                       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -2809,7 +3363,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                    SvREFCNT_dec(dref);
                if (intro)
                    SAVEFREESV(sref);
-               SvTAINT(dstr);
+               if (SvTAINTED(sstr))
+                   SvTAINT(dstr);
                return;
            }
            if (SvPVX(dstr)) {
@@ -2848,7 +3403,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        if (SvTEMP(sstr) &&             /* slated for free anyway? */
            SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
            !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
-           SvLEN(sstr))                        /* and really is a string */
+           SvLEN(sstr)         &&      /* and really is a string */
+           !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
        {
            if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
                if (SvOOK(dstr)) {
@@ -2918,7 +3474,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
        else
            (void)SvOK_off(dstr);
     }
-    SvTAINT(dstr);
+    if (SvTAINTED(sstr))
+       SvTAINT(dstr);
 }
 
 /*
@@ -2949,8 +3506,11 @@ void
 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 {
     register char *dptr;
-    assert(len >= 0);  /* STRLEN is probably unsigned, so this may
-                         elicit a warning, but it won't hurt. */
+    {
+        /* len is STRLEN which is unsigned, need to copy to signed */
+       IV iv = len;
+       assert(iv >= 0);
+    }
     SV_CHECK_THINKFIRST(sv);
     if (!ptr) {
        (void)SvOK_off(sv);
@@ -2963,7 +3523,7 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN
     Move(ptr,dptr,len,char);
     dptr[len] = '\0';
     SvCUR_set(sv, len);
-    (void)SvPOK_only(sv);              /* validate pointer */
+    (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
 }
 
@@ -3007,7 +3567,7 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
     SvGROW(sv, len + 1);
     Move(ptr,SvPVX(sv),len+1,char);
     SvCUR_set(sv, len);
-    (void)SvPOK_only(sv);              /* validate pointer */
+    (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
 }
 
@@ -3057,7 +3617,7 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
     SvCUR_set(sv, len);
     SvLEN_set(sv, len+1);
     *SvEND(sv) = '\0';
-    (void)SvPOK_only(sv);              /* validate pointer */
+    (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
 }
 
@@ -3077,10 +3637,9 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len
 }
 
 void
-Perl_sv_force_normal(pTHX_ register SV *sv)
+Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
 {
     if (SvREADONLY(sv)) {
-       dTHR;
        if (SvFAKE(sv)) {
            char *pvx = SvPVX(sv);
            STRLEN len = SvCUR(sv);
@@ -3090,17 +3649,23 @@ Perl_sv_force_normal(pTHX_ register SV *sv)
            *SvEND(sv) = '\0';
            SvFAKE_off(sv);
            SvREADONLY_off(sv);
-           unsharepvn(pvx,len,hash);
+           unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
        }
        else if (PL_curcop != &PL_compiling)
            Perl_croak(aTHX_ PL_no_modify);
     }
     if (SvROK(sv))
-       sv_unref(sv);
+       sv_unref_flags(sv, flags);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
        sv_unglob(sv);
 }
 
+void
+Perl_sv_force_normal(pTHX_ register SV *sv)
+{
+    sv_force_normal_flags(sv, 0);
+}
+
 /*
 =for apidoc sv_chop
 
@@ -3189,27 +3754,42 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL
 /*
 =for apidoc sv_catsv
 
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
+not 'set' magic.  See C<sv_catsv_mg>.
 
-=cut
-*/
+=cut */
 
 void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
 {
-    char *s;
-    STRLEN len;
-    if (!sstr)
+    char *spv;
+    STRLEN slen;
+    if (!ssv)
        return;
-    if ((s = SvPV(sstr, len))) {
-       if (DO_UTF8(sstr)) {
-           sv_utf8_upgrade(dstr);
-           sv_catpvn(dstr,s,len);
-           SvUTF8_on(dstr);
+    if ((spv = SvPV(ssv, slen))) {
+       bool dutf8 = DO_UTF8(dsv);
+       bool sutf8 = DO_UTF8(ssv);
+
+       if (dutf8 == sutf8)
+           sv_catpvn(dsv,spv,slen);
+       else {
+           if (dutf8) {
+               /* Not modifying source SV, so taking a temporary copy. */
+               SV* csv = sv_2mortal(newSVsv(ssv));
+               char *cpv;
+               STRLEN clen;
+
+               sv_utf8_upgrade(csv);
+               cpv = SvPV(csv,clen);
+               sv_catpvn(dsv,cpv,clen);
+           }
+           else {
+               sv_utf8_upgrade(dsv);
+               sv_catpvn(dsv,spv,slen);
+               SvUTF8_on(dsv); /* If dsv has no wide characters. */
+           }
        }
-       else
-           sv_catpvn(dstr,s,len);
     }
 }
 
@@ -3222,10 +3802,10 @@ Like C<sv_catsv>, but also handles 'set' magic.
 */
 
 void
-Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
 {
-    sv_catsv(dstr,sstr);
-    SvSETMAGIC(dstr);
+    sv_catsv(dsv,ssv);
+    SvSETMAGIC(dsv);
 }
 
 /*
@@ -3301,7 +3881,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     MAGIC* mg;
 
     if (SvREADONLY(sv)) {
-       dTHR;
        if (PL_curcop != &PL_compiling && !strchr("gBf", how))
            Perl_croak(aTHX_ PL_no_modify);
     }
@@ -3322,7 +3901,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     if (!obj || obj == sv || how == '#' || how == 'r')
        mg->mg_obj = obj;
     else {
-       dTHR;
        mg->mg_obj = SvREFCNT_inc(obj);
        mg->mg_flags |= MGf_REFCOUNTED;
     }
@@ -3511,7 +4089,6 @@ Perl_sv_rvweaken(pTHX_ SV *sv)
     if (!SvROK(sv))
        Perl_croak(aTHX_ "Can't weaken a nonreference");
     else if (SvWEAKREF(sv)) {
-       dTHR;
        if (ckWARN(WARN_MISC))
            Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
        return sv;
@@ -3664,7 +4241,6 @@ Make the first argument a copy of the second, then delete the original.
 void
 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
 {
-    dTHR;
     U32 refcnt = SvREFCNT(sv);
     SV_CHECK_THINKFIRST(sv);
     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
@@ -3705,10 +4281,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
     assert(SvREFCNT(sv) == 0);
 
     if (SvOBJECT(sv)) {
-       dTHR;
        if (PL_defstash) {              /* Still have a symbol table? */
            djSP;
-           GV* destructor;
+           CV* destructor;
            SV tmpref;
 
            Zero(&tmpref, 1, SV);
@@ -3717,9 +4292,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
            SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
            SvREFCNT(&tmpref) = 1;
 
-           do {
+           do {            
                stash = SvSTASH(sv);
-               destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+               destructor = StashHANDLER(stash,DESTROY);
                if (destructor) {
                    ENTER;
                    PUSHSTACKi(PERLSI_DESTROY);
@@ -3728,8 +4303,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
                    PUSHMARK(SP);
                    PUSHs(&tmpref);
                    PUTBACK;
-                   call_sv((SV*)GvCV(destructor),
-                           G_DISCARD|G_EVAL|G_KEEPERR);
+                   call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
                    SvREFCNT(sv)--;
                    POPSTACK;
                    SPAGAIN;
@@ -3815,7 +4389,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
        else if (SvPVX(sv) && SvLEN(sv))
            Safefree(SvPVX(sv));
        else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
-           unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
+           unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
            SvFAKE_off(sv);
        }
        break;
@@ -3905,7 +4479,6 @@ Free the memory used by an SV.
 void
 Perl_sv_free(pTHX_ SV *sv)
 {
-    dTHR;
     int refcount_is_zero;
 
     if (!sv)
@@ -3982,26 +4555,18 @@ UTF8 bytes as a single character.
 STRLEN
 Perl_sv_len_utf8(pTHX_ register SV *sv)
 {
-    U8 *s;
-    U8 *send;
-    STRLEN len;
-
     if (!sv)
        return 0;
 
-#ifdef NOTYET
     if (SvGMAGICAL(sv))
-       len = mg_length(sv);
+       return mg_length(sv);
     else
-#endif
-       s = (U8*)SvPV(sv, len);
-    send = s + len;
-    len = 0;
-    while (s < send) {
-       s += UTF8SKIP(s);
-       len++;
+    {
+       STRLEN len;
+       U8 *s = (U8*)SvPV(sv, len);
+
+       return Perl_utf8_length(aTHX_ s, s + len);
     }
-    return len;
 }
 
 void
@@ -4047,18 +4612,18 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
 
     s = (U8*)SvPV(sv, len);
     if (len < *offsetp)
-       Perl_croak(aTHX_ "panic: bad byte offset");
+       Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
     send = s + *offsetp;
     len = 0;
     while (s < send) {
-       s += UTF8SKIP(s);
-       ++len;
-    }
-    if (s != send) {
-        dTHR;
-       if (ckWARN_d(WARN_UTF8))
-           Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
-       --len;
+       STRLEN n;
+
+       if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
+           s += n;
+           len++;
+       }
+       else
+           break;
     }
     *offsetp = len;
     return;
@@ -4100,13 +4665,30 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 
     /* do not utf8ize the comparands as a side-effect */
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+       if (PL_hints & HINT_UTF8_DISTINCT)
+           return FALSE;
+
        if (SvUTF8(sv1)) {
-           pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
-           pv2tmp = TRUE;
+           (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
+           {
+               IV scur1 = cur1;
+               if (scur1 < 0) {
+                   Safefree(pv1);
+                   return 0;
+               }
+           }
+           pv1tmp = TRUE;
        }
        else {
-           pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
-           pv1tmp = TRUE;
+           (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
+           {
+               IV scur2 = cur2;
+               if (scur2 < 0) {
+                   Safefree(pv2);
+                   return 0;
+               }
+           }
+           pv2tmp = TRUE;
        }
     }
 
@@ -4156,6 +4738,9 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
 
     /* do not utf8ize the comparands as a side-effect */
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+       if (PL_hints & HINT_UTF8_DISTINCT)
+           return SvUTF8(sv1) ? 1 : -1;
+
        if (SvUTF8(sv1)) {
            pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
            pv2tmp = TRUE;
@@ -4312,7 +4897,6 @@ appending to the currently-stored string.
 char *
 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 {
-    dTHR;
     char *rsptr;
     STRLEN rslen;
     register STDCHAR rslast;
@@ -4348,14 +4932,31 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 #endif
       SvCUR_set(sv, bytesread);
       buffer[bytesread] = '\0';
+      if (PerlIO_isutf8(fp))
+       SvUTF8_on(sv);
+      else
+       SvUTF8_off(sv);
       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
     }
     else if (RsPARA(PL_rs)) {
        rsptr = "\n\n";
        rslen = 2;
     }
-    else
-       rsptr = SvPV(PL_rs, rslen);
+    else {
+       /* Get $/ i.e. PL_rs into same encoding as stream wants */
+       if (PerlIO_isutf8(fp)) {
+           rsptr = SvPVutf8(PL_rs, rslen);
+       }
+       else {
+           if (SvUTF8(PL_rs)) {
+               if (!sv_utf8_downgrade(PL_rs, TRUE)) {
+                   Perl_croak(aTHX_ "Wide character in $/");
+               }
+           }
+           rsptr = SvPV(PL_rs, rslen);
+       }
+    }
+
     rslast = rslen ? rsptr[rslen - 1] : '\0';
 
     if (RsPARA(PL_rs)) {               /* have to do this both before and after */
@@ -4574,6 +5175,11 @@ screamer2:
        }
     }
 
+    if (PerlIO_isutf8(fp))
+       SvUTF8_on(sv);
+    else
+       SvUTF8_off(sv);
+
     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
 }
 
@@ -4598,7 +5204,6 @@ Perl_sv_inc(pTHX_ register SV *sv)
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
        if (SvREADONLY(sv)) {
-           dTHR;
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);
        }
@@ -4612,12 +5217,15 @@ Perl_sv_inc(pTHX_ register SV *sv)
        }
     }
     flags = SvFLAGS(sv);
-    if (flags & SVp_NOK) {
-       (void)SvNOK_only(sv);
-       SvNVX(sv) += 1.0;
-       return;
-    }
-    if (flags & SVp_IOK) {
+    if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
+       /* It's (privately or publicly) a float, but not tested as an
+          integer, so test it to see. */
+       (void) SvIV(sv); 
+       flags = SvFLAGS(sv);
+    }
+    if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+       /* It's publicly an integer, or privately an integer-not-float */
+      oops_its_int:
        if (SvIsUV(sv)) {
            if (SvUVX(sv) == UV_MAX)
                sv_setnv(sv, (NV)UV_MAX + 1.0);
@@ -4626,7 +5234,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
                ++SvUVX(sv);
        } else {
            if (SvIVX(sv) == IV_MAX)
-               sv_setnv(sv, (NV)IV_MAX + 1.0);
+               sv_setuv(sv, (UV)IV_MAX + 1);
            else {
                (void)SvIOK_only(sv);
                ++SvIVX(sv);
@@ -4634,18 +5242,59 @@ Perl_sv_inc(pTHX_ register SV *sv)
        }
        return;
     }
-    if (!(flags & SVp_POK) || !*SvPVX(sv)) {
-       if ((flags & SVTYPEMASK) < SVt_PVNV)
-           sv_upgrade(sv, SVt_NV);
-       SvNVX(sv) = 1.0;
+    if (flags & SVp_NOK) {
        (void)SvNOK_only(sv);
+       SvNVX(sv) += 1.0;
+       return;
+    }
+
+    if (!(flags & SVp_POK) || !*SvPVX(sv)) {
+       if ((flags & SVTYPEMASK) < SVt_PVIV)
+           sv_upgrade(sv, SVt_IV);
+       (void)SvIOK_only(sv);
+       SvIVX(sv) = 1;
        return;
     }
     d = SvPVX(sv);
     while (isALPHA(*d)) d++;
     while (isDIGIT(*d)) d++;
     if (*d) {
-       sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
+#ifdef PERL_PRESERVE_IVUV
+       /* Got to punt this an an integer if needs be, but we don't issue
+          warnings. Probably ought to make the sv_iv_please() that does
+          the conversion if possible, and silently.  */
+       I32 numtype = looks_like_number(sv);
+       if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+           /* Need to try really hard to see if it's an integer.
+              9.22337203685478e+18 is an integer.
+              but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+              so $a="9.22337203685478e+18"; $a+0; $a++
+              needs to be the same as $a="9.22337203685478e+18"; $a++
+              or we go insane. */
+           
+           (void) sv_2iv(sv);
+           if (SvIOK(sv))
+               goto oops_its_int;
+
+           /* sv_2iv *should* have made this an NV */
+           if (flags & SVp_NOK) {
+               (void)SvNOK_only(sv);
+               SvNVX(sv) += 1.0;
+               return;
+           }
+           /* I don't think we can get here. Maybe I should assert this
+              And if we do get here I suspect that sv_setnv will croak. NWC
+              Fall through. */
+#if defined(USE_LONG_DOUBLE)
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+                                 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+                                 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+       }
+#endif /* PERL_PRESERVE_IVUV */
+       sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
        return;
     }
     d--;
@@ -4706,7 +5355,6 @@ Perl_sv_dec(pTHX_ register SV *sv)
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
        if (SvREADONLY(sv)) {
-           dTHR;
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);
        }
@@ -4719,13 +5367,12 @@ Perl_sv_dec(pTHX_ register SV *sv)
            sv_setiv(sv, i);
        }
     }
+    /* Unlike sv_inc we don't have to worry about string-never-numbers
+       and keeping them magic. But we mustn't warn on punting */
     flags = SvFLAGS(sv);
-    if (flags & SVp_NOK) {
-       SvNVX(sv) -= 1.0;
-       (void)SvNOK_only(sv);
-       return;
-    }
-    if (flags & SVp_IOK) {
+    if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+       /* It's publicly an integer, or privately an integer-not-float */
+      oops_its_int:
        if (SvIsUV(sv)) {
            if (SvUVX(sv) == 0) {
                (void)SvIOK_only(sv);
@@ -4745,6 +5392,11 @@ Perl_sv_dec(pTHX_ register SV *sv)
        }
        return;
     }
+    if (flags & SVp_NOK) {
+       SvNVX(sv) -= 1.0;
+       (void)SvNOK_only(sv);
+       return;
+    }
     if (!(flags & SVp_POK)) {
        if ((flags & SVTYPEMASK) < SVt_PVNV)
            sv_upgrade(sv, SVt_NV);
@@ -4752,6 +5404,40 @@ Perl_sv_dec(pTHX_ register SV *sv)
        (void)SvNOK_only(sv);
        return;
     }
+#ifdef PERL_PRESERVE_IVUV
+    {
+       I32 numtype = looks_like_number(sv);
+       if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+           /* Need to try really hard to see if it's an integer.
+              9.22337203685478e+18 is an integer.
+              but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+              so $a="9.22337203685478e+18"; $a+0; $a--
+              needs to be the same as $a="9.22337203685478e+18"; $a--
+              or we go insane. */
+           
+           (void) sv_2iv(sv);
+           if (SvIOK(sv))
+               goto oops_its_int;
+
+           /* sv_2iv *should* have made this an NV */
+           if (flags & SVp_NOK) {
+               (void)SvNOK_only(sv);
+               SvNVX(sv) -= 1.0;
+               return;
+           }
+           /* I don't think we can get here. Maybe I should assert this
+              And if we do get here I suspect that sv_setnv will croak. NWC
+              Fall through. */
+#if defined(USE_LONG_DOUBLE)
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+                                 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+                                 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+       }
+    }
+#endif /* PERL_PRESERVE_IVUV */
     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0);        /* punt */
 }
 
@@ -4772,7 +5458,6 @@ as mortal.
 SV *
 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
 {
-    dTHR;
     register SV *sv;
 
     new_SV(sv);
@@ -4794,7 +5479,6 @@ Creates a new SV which is mortal.  The reference count of the SV is set to 1.
 SV *
 Perl_sv_newmortal(pTHX)
 {
-    dTHR;
     register SV *sv;
 
     new_SV(sv);
@@ -4818,7 +5502,6 @@ ends.
 SV *
 Perl_sv_2mortal(pTHX_ register SV *sv)
 {
-    dTHR;
     if (!sv)
        return sv;
     if (SvREADONLY(sv) && SvIMMORTAL(sv))
@@ -4885,20 +5568,27 @@ will avoid string compare.
 */
 
 SV *
-Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
+Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
 {
     register SV *sv;
+    bool is_utf8 = FALSE;
+    if (len < 0) {
+        len = -len;
+        is_utf8 = TRUE;
+    }
     if (!hash)
        PERL_HASH(hash, src, len);
     new_SV(sv);
     sv_upgrade(sv, SVt_PVIV);
-    SvPVX(sv) = sharepvn(src, len, hash);
+    SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
     SvCUR(sv) = len;
     SvUVX(sv) = hash;
     SvLEN(sv) = 0;
     SvREADONLY_on(sv);
     SvFAKE_on(sv);
     SvPOK_on(sv);
+    if (is_utf8)
+        SvUTF8_on(sv);
     return sv;
 }
 
@@ -5014,7 +5704,6 @@ SV is B<not> incremented.
 SV *
 Perl_newRV_noinc(pTHX_ SV *tmpRef)
 {
-    dTHR;
     register SV *sv;
 
     new_SV(sv);
@@ -5045,7 +5734,6 @@ Creates a new SV which is an exact duplicate of the original SV.
 SV *
 Perl_newSVsv(pTHX_ register SV *old)
 {
-    dTHR;
     register SV *sv;
 
     if (!old)
@@ -5128,7 +5816,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash)
                }
                if (GvHV(gv) && !HvNAME(GvHV(gv))) {
                    hv_clear(GvHV(gv));
-#if !defined( VMS) && !defined(EPOC)  /* VMS has no environ array */
+#ifdef USE_ENVIRON_ARRAY
                    if (gv == PL_envgv)
                        environ[0] = Nullch;
 #endif
@@ -5200,7 +5888,6 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
        if (SvGMAGICAL(sv))
            mg_get(sv);
        if (SvROK(sv)) {
-           dTHR;
            SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
            tryAMAGICunDEREF(to_cv);
 
@@ -5256,7 +5943,6 @@ Returns true if the SV has a true value by Perl's rules.
 I32
 Perl_sv_true(pTHX_ register SV *sv)
 {
-    dTHR;
     if (!sv)
        return 0;
     if (SvPOK(sv)) {
@@ -5352,7 +6038,6 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
     }
     else {
        if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
-           dTHR;
            Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
                PL_op_name[PL_op->op_type]);
        }
@@ -5532,7 +6217,6 @@ reference count is 1.
 SV*
 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
 {
-    dTHR;
     SV *sv;
 
     new_SV(sv);
@@ -5672,7 +6356,6 @@ of the SV is unaffected.
 SV*
 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
 {
-    dTHR;
     SV *tmpRef;
     if (!SvROK(sv))
         Perl_croak(aTHX_ "Can't bless non-reference value");
@@ -5728,17 +6411,21 @@ S_sv_unglob(pTHX_ SV *sv)
 }
 
 /*
-=for apidoc sv_unref
+=for apidoc sv_unref_flags
 
 Unsets the RV status of the SV, and decrements the reference count of
 whatever was being referenced by the RV.  This can almost be thought of
-as a reversal of C<newSVrv>.  See C<SvROK_off>.
+as a reversal of C<newSVrv>.  The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.
 
 =cut
 */
 
 void
-Perl_sv_unref(pTHX_ SV *sv)
+Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
 {
     SV* rv = SvRV(sv);
 
@@ -5750,12 +6437,29 @@ Perl_sv_unref(pTHX_ SV *sv)
     }
     SvRV(sv) = 0;
     SvROK_off(sv);
-    if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+    if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
        SvREFCNT_dec(rv);
-    else
+    else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
        sv_2mortal(rv);         /* Schedule for freeing later */
 }
 
+/*
+=for apidoc sv_unref
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV.  This can almost be thought of
+as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
+being zero.  See C<SvROK_off>.
+
+=cut
+*/
+
+void
+Perl_sv_unref(pTHX_ SV *sv)
+{
+    sv_unref_flags(sv, 0);
+}
+
 void
 Perl_sv_taint(pTHX_ SV *sv)
 {
@@ -5995,7 +6699,6 @@ locales).
 void
 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
 {
-    dTHR;
     char *p;
     char *q;
     char *patend;
@@ -6050,9 +6753,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        bool has_precis = FALSE;
        STRLEN precis = 0;
        bool is_utf = FALSE;
-
+       
        char esignbuf[4];
-       U8 utf8buf[UTF8_MAXLEN];
+       U8 utf8buf[UTF8_MAXLEN+1];
        STRLEN esignlen = 0;
 
        char *eptr = Nullch;
@@ -6078,6 +6781,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN gap;
        char *dotstr = ".";
        STRLEN dotstrlen = 1;
+       I32 epix = 0; /* explicit parameter index */
+       I32 ewix = 0; /* explicit width index */
+       bool asterisk = FALSE;
 
        for (q = p; q < patend && *q != '%'; ++q) ;
        if (q > p) {
@@ -6138,6 +6844,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        /* WIDTH */
 
+    scanwidth:
+
+       if (*q == '*') {
+           if (asterisk)
+               goto unknown;
+           asterisk = TRUE;
+           q++;
+       }
+
        switch (*q) {
        case '1': case '2': case '3':
        case '4': case '5': case '6':
@@ -6145,17 +6860,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            width = 0;
            while (isDIGIT(*q))
                width = width * 10 + (*q++ - '0');
-           break;
+           if (*q == '$') {
+               if (asterisk && ewix == 0) {
+                   ewix  = width;
+                   width = 0;
+                   q++;
+                   goto scanwidth;
+               } else if (epix == 0) {
+                   epix  = width;
+                   width = 0;
+                   q++;
+                   goto scanwidth;
+               } else
+                   goto unknown;
+           }
+       }
 
-       case '*':
+       if (asterisk) {
            if (args)
                i = va_arg(*args, int);
            else
-               i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               i = (ewix ? ewix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
            left |= (i < 0);
            width = (i < 0) ? -i : i;
-           q++;
-           break;
        }
 
        /* PRECISION */
@@ -6166,7 +6894,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                if (args)
                    i = va_arg(*args, int);
                else
-                   i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+                   i = (ewix ? ewix <= svmax : svix < svmax)
+                       ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
                precis = (i < 0) ? 0 : i;
                q++;
            }
@@ -6184,8 +6913,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                vecstr = (U8*)SvPVx(vecsv,veclen);
                utf = DO_UTF8(vecsv);
            }
-           else if (svix < svmax) {
-               vecsv = svargs[svix++];
+           else if (epix ? epix <= svmax : svix < svmax) {
+               vecsv = svargs[epix ? epix-1 : svix++];
                vecstr = (U8*)SvPVx(vecsv,veclen);
                utf = DO_UTF8(vecsv);
            }
@@ -6239,7 +6968,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                uv = va_arg(*args, int);
            else
-               uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
            if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
                eptr = (char*)utf8buf;
                elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
@@ -6268,8 +6998,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    elen = sizeof nullstr - 1;
                }
            }
-           else if (svix < svmax) {
-               argsv = svargs[svix++];
+           else if (epix ? epix <= svmax : svix < svmax) {
+               argsv = svargs[epix ? epix-1 : svix++];
                eptr = SvPVx(argsv, elen);
                if (DO_UTF8(argsv)) {
                    if (has_precis && precis < elen) {
@@ -6312,7 +7042,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                uv = PTR2UV(va_arg(*args, void*));
            else
-               uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
            base = 16;
            goto integer;
 
@@ -6326,13 +7057,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        case 'd':
        case 'i':
            if (vectorize) {
-               I32 ulen;
+               STRLEN ulen;
                if (!veclen) {
                    vectorize = FALSE;
                    break;
                }
                if (utf)
-                   iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
+                   iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    iv = *vecstr;
                    ulen = 1;
@@ -6352,7 +7083,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               iv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
                switch (intsize) {
                case 'h':       iv = (short)iv; break;
                default:        break;
@@ -6407,14 +7139,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        uns_integer:
            if (vectorize) {
-               I32 ulen;
+               STRLEN ulen;
        vector:
                if (!veclen) {
                    vectorize = FALSE;
                    break;
                }
                if (utf)
-                   uv = utf8_to_uv_chk(vecstr, &ulen, 0);
+                   uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -6434,7 +7166,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else {
-               uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+               uv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
                switch (intsize) {
                case 'h':       uv = (unsigned short)uv; break;
                default:        break;
@@ -6526,7 +7259,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            if (args)
                nv = va_arg(*args, NV);
            else
-               nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+               nv = (epix ? epix <= svmax : svix < svmax) ?
+                   SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
 
            need = 0;
            if (c != 'e' && c != 'E') {
@@ -6581,15 +7315,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *--eptr = '#';
            *--eptr = '%';
 
-           {
-               STORE_NUMERIC_STANDARD_SET_LOCAL();
-#ifdef USE_LOCALE_NUMERIC
-               if (!was_standard && maybe_tainted)
-                   *maybe_tainted = TRUE;
-#endif
-               (void)sprintf(PL_efloatbuf, eptr, nv);
-               RESTORE_NUMERIC_STANDARD();
-           }
+           /* No taint.  Otherwise we are in the strange situation
+            * where printf() taints but print($float) doesn't.
+            * --jhi */
+           (void)sprintf(PL_efloatbuf, eptr, nv);
 
            eptr = PL_efloatbuf;
            elen = strlen(PL_efloatbuf);
@@ -6611,8 +7340,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
                }
            }
-           else if (svix < svmax)
-               sv_setuv_mg(svargs[svix++], (UV)i);
+           else if (epix ? epix <= svmax : svix < svmax)
+               sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
            continue;   /* not "break" */
 
            /* UNKNOWN */
@@ -6748,7 +7477,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type)
        return ret;
 
     /* create anew and remember what it is */
-    ret = PerlIO_fdupopen(fp);
+    ret = PerlIO_fdupopen(aTHX_ fp);
     ptr_table_store(PL_ptr_table, fp, ret);
     return ret;
 }
@@ -7624,6 +8353,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
            av = (AV*)POPPTR(ss,ix);
            TOPPTR(nss,ix) = av_dup(av);
            break;
+       case SAVEt_PADSV:
+           longval = (long)POPLONG(ss,ix);
+           TOPLONG(nss,ix) = longval;
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+           sv = (SV*)POPPTR(ss,ix);
+           TOPPTR(nss,ix) = sv_dup(sv);
+           break;
        default:
            Perl_croak(aTHX_ "panic: ss_dup inconsistency");
        }
@@ -7797,6 +8534,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
     if (!specialWARN(PL_compiling.cop_warnings))
        PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
+    if (!specialCopIO(PL_compiling.cop_io))
+       PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
     PL_curcop          = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
 
     /* pseudo environmental stuff */
@@ -7922,8 +8661,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_laststype       = proto_perl->Ilaststype;
     PL_mess_sv         = Nullsv;
 
-    PL_orslen          = proto_perl->Iorslen;
-    PL_ors             = SAVEPVN(proto_perl->Iors, PL_orslen);
+    PL_ors_sv          = sv_dup_inc(proto_perl->Iors_sv);
     PL_ofmt            = SAVEPV(proto_perl->Iofmt);
 
     /* interpreter atexit processing */
@@ -8206,8 +8944,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_nrs             = sv_dup_inc(proto_perl->Tnrs);
     PL_rs              = sv_dup_inc(proto_perl->Trs);
     PL_last_in_gv      = gv_dup(proto_perl->Tlast_in_gv);
-    PL_ofslen          = proto_perl->Tofslen;
-    PL_ofs             = SAVEPVN(proto_perl->Tofs, PL_ofslen);
+    PL_ofs_sv          = sv_dup_inc(proto_perl->Tofs_sv);
     PL_defoutgv                = gv_dup_inc(proto_perl->Tdefoutgv);
     PL_chopset         = proto_perl->Tchopset; /* XXX never deallocated */
     PL_toptarget       = sv_dup_inc(proto_perl->Ttoptarget);
diff --git a/sv.h b/sv.h
index 425acc3..0ab87e9 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1,6 +1,6 @@
 /*    sv.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -448,6 +448,9 @@ Tells and SV that it is an unsigned integer and disables all other OK bits.
 =for apidoc Am|void|SvIOK_UV|SV* sv
 Returns a boolean indicating whether the SV contains an unsigned integer.
 
+=for apidoc Am|void|SvUOK|SV* sv
+Returns a boolean indicating whether the SV contains an unsigned integer.
+
 =for apidoc Am|void|SvIOK_notUV|SV* sv
 Returns a boolean indicating whether the SV contains an signed integer.
 
@@ -562,6 +565,7 @@ Set the length of the string which is in the SV.  See C<SvCUR>.
 
 #define SvIOK_UV(sv)           ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV))   \
                                 == (SVf_IOK|SVf_IVisUV))
+#define SvUOK(sv)              SvIOK_UV(sv)
 #define SvIOK_notUV(sv)                ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV))   \
                                 == SVf_IOK)
 
@@ -714,6 +718,12 @@ and disables all other OK bits.
 #define SvMAGIC(sv)    ((XPVMG*)  SvANY(sv))->xmg_magic
 #define SvSTASH(sv)    ((XPVMG*)  SvANY(sv))->xmg_stash
 
+/* Ask a scalar nicely to try to become an IV, if possible.
+   Not guaranteed to stay returning void */
+/* Macro won't actually call sv_2iv if already IOK */
+#define SvIV_please(sv) \
+       STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
+               (void) SvIV(sv); } STMT_END
 #define SvIV_set(sv, val) \
        STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
                (((XPVIV*)  SvANY(sv))->xiv_iv = val); } STMT_END
@@ -801,7 +811,6 @@ Taints an SV if tainting is enabled
 #define SvTAINT(sv)                    \
     STMT_START {                       \
        if (PL_tainting) {              \
-           dTHR;                       \
            if (PL_tainted)             \
                SvTAINTED_on(sv);       \
        }                               \
@@ -1097,3 +1106,4 @@ Returns a pointer to the character buffer.
 #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
 #define Sv_Grow sv_grow
 
+#define SV_IMMEDIATE_UNREF     1
index 0953026..7cff553 100644 (file)
--- a/t/README
+++ b/t/README
@@ -1,4 +1,4 @@
-This is the perl test library.  To run all the tests, just type 'TEST'.
+This is the perl test library.  To run all the tests, just type './TEST'.
 
 To add new tests, just look at the current tests and do likewise.
 
@@ -14,3 +14,8 @@ will fail, you may want to use Test::Harness thusly:
 This method pinpoints failed tests automatically.
 
 If you come up with new tests, please send them to perlbug@perl.org.
+
+Tests in the base/ directory ought to be runnable with plain miniperl.
+That is, they should not require Config.pm nor should they require any
+extensions to have been built.  TEST will abort if any tests in the
+base/ directory fail.
diff --git a/t/TEST b/t/TEST
index ef3d312..cfee26c 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -114,6 +114,9 @@ EOT
                    $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
                    if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) {
                        $next = $next + 1;
+                    }
+                    elsif (/^Bail out!\s*(.*)/i) { # magic words
+                        die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
                    }
                    else {
                        $ok = 0;
diff --git a/t/UTEST b/t/UTEST
index 9c1dfc0..1be1a5b 100755 (executable)
--- a/t/UTEST
+++ b/t/UTEST
@@ -127,6 +127,9 @@ EOT
                    $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
                    if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) {
                        $next = $next + 1;
+                    }
+                    elsif (/^Bail out!\s*(.*)/i) { # magic words
+                        die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
                    }
                    else {
                        $ok = 0;
diff --git a/t/base/commonsense.t b/t/base/commonsense.t
new file mode 100644 (file)
index 0000000..6e31307
--- /dev/null
@@ -0,0 +1,25 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = '../lib';
+require Config; import Config;
+if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){
+  print "Bail out! Perl configured without DB_File or [A-Z]DBM_File\n";
+  exit 0;
+}
+if (($Config{'extensions'} !~ /\bFcntl\b/) ){
+  print "Bail out! Perl configured without Fcntl module\n";
+  exit 0;
+}
+if (($Config{'extensions'} !~ /\bIO\b/) ){
+  print "Bail out! Perl configured without IO module\n";
+  exit 0;
+}
+# hey, DOS users do not need this kind of common sense ;-)
+if ($^O ne 'dos' && ($Config{'extensions'} !~ /\bFile\/Glob\b/) ){
+  print "Bail out! Perl configured without File::Glob module\n";
+  exit 0;
+}
+
+print "1..1\nok 1\n";
+
index e96313d..49df11f 100755 (executable)
@@ -4,19 +4,16 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
 }
 
-use Config;
-
 print "1..7\n";
 
 # check "" interpretation
 
 $x = "\n";
 # 10 is ASCII/Iso Latin, 21 is EBCDIC.
-if ($x eq chr(10) ||
-    ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";}
+if ($x eq chr(10)) { print "ok 1\n";}
+elsif ($x eq chr(21)) { print "ok 1 # EBCDIC\n"; }
 else {print "not ok 1\n";}
 
 # check `` processing
index f9731ee..874ab44 100755 (executable)
@@ -9,6 +9,9 @@
 # we should test as many as we can.
 #
 
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
@@ -16,7 +19,7 @@ BEGIN {
 
 use strict;
 
-print "1..110\n";
+print "1..124\n";
 
 my $i = 1;
 
@@ -340,6 +343,7 @@ sub sub_array (&@) {
 
 @array = (qw(O K)," ", $i++);
 sub_array { lc shift } @array;
+sub_array { lc shift } ('O', 'K', ' ', $i++);
 print "\n";
 
 ##
@@ -485,3 +489,17 @@ sub sreftest (\$$) {
     sreftest($helem{$i}, $i++);
     sreftest $aelem[0], $i++;
 }
+
+# test prototypes when they are evaled and there is a syntax error
+#
+for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) {
+  no warnings 'redefine';
+  my $eval = "sub evaled_subroutine $p { &void *; }";
+  eval $eval;
+  print "# eval[$eval]\nnot " unless $@ && $@ =~ /syntax error/;
+  print "ok ", $i++, "\n";
+}
+
+# Not $$;$;$
+print "not " unless prototype "CORE::substr" eq '$$;$$';
+print "ok ", $i++, "\n";
index 07e978b..328b44d 100755 (executable)
@@ -11,7 +11,7 @@ sub ok ($$) {
     print $_[1] ? "ok " : "not ok ", $_[0], "\n";
 }
 
-print "1..18\n";
+print "1..20\n";
 
 my $NEWPROTO = 'Prototype mismatch:';
 
@@ -72,9 +72,15 @@ sub sub9 ($)  { 2 }
 ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s;
 ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s;
 
-ok 18, $_ eq '';
+BEGIN {
+    local $^W = 0;
+    eval qq(sub sub10 () {1} sub sub10 {1});
+}
 
-# If we got any errors that we were not expecting, then print them
-print $_ if length $_;
+ok 18, $warn =~ s/$NEWPROTO \Qsub main::sub10 () vs none\E[^\n]+\n//s;
+ok 19, $warn =~ s/Constant subroutine sub10 redefined[^\n]+\n//s;
 
+ok 20, $warn eq '';
 
+# If we got any errors that we were not expecting, then print them
+print $warn if length $warn;
index eaea3ad..e634532 100755 (executable)
@@ -21,6 +21,7 @@ sub write_file {
     my $f = shift;
     open(REQ,">$f") or die "Can't write '$f': $!";
     binmode REQ;
+    use bytes;
     print REQ @_;
     close REQ;
 }
@@ -132,7 +133,7 @@ $i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
 
 sub bytes_to_utf16 {
     my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
-    return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16; 
+    return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
 }
 
 $i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
index af13d4d..9b656ec 100755 (executable)
@@ -2,7 +2,7 @@
 
 # $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $
 
-print "1..6\n";
+print "1..8\n";
 
 print "ok 1\n";
 
@@ -17,14 +17,10 @@ select(STDOUT); $| = 1;
 
 print STDOUT "ok 2\n";
 print STDERR "ok 3\n";
-if ($^O eq 'MSWin32') {
     print `echo ok 4`;
     print `echo ok 5 1>&2`; # does this work?
-}
-else {
-    system 'echo ok 4';
-    system 'echo ok 5 1>&2';
-}
+    system 'echo ok 6';
+    system 'echo ok 7 1>&2';
 
 close(STDOUT);
 close(STDERR);
@@ -36,5 +32,5 @@ if ($^O eq 'MSWin32') { print `type Io.dup` }
 else                  { system 'cat Io.dup' }
 unlink 'Io.dup';
 
-print STDOUT "ok 6\n";
+print STDOUT "ok 8\n";
 
index 7182c24..8170b33 100755 (executable)
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -115,7 +115,15 @@ if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32')
     {print "ok 18 # skipped: granularity of the filetime\n";}
 elsif ($atime == 500000000 && $mtime == 500000000 + $delta)
     {print "ok 18\n";}
-else
+elsif ($^O =~ /\blinux\b/i) {
+    # Maybe stat() cannot get the correct atime, as happens via NFS on linux?
+    $foo = (utime 400000000,500000000 + 2*$delta,'b');
+    my ($new_atime, $new_mtime) = (stat('b'))[8,9];
+    if ($new_atime == $atime && $new_mtime - $mtime == $delta)
+       {print "ok 18 # accounted for possible NFS/glibc2.2 bug on linux\n";}
+    else
+       {print "not ok 18 $atime/$new_atime $mtime/$new_mtime\n";}
+} else
     {print "not ok 18 $atime $mtime\n";}
 
 if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
@@ -129,10 +137,15 @@ chdir $wd || die "Can't cd back to $wd";
 unlink 'c';
 if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) {
     # we have symbolic links
-    if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
-    $foo = `grep perl c`;
+    system("cp TEST TEST$$");
+    # we have to copy because e.g. GNU grep gets huffy if we have
+    # a symlink forest to another disk (it complains about too many
+    # levels of symbolic links, even if we have only two)
+    if (symlink("TEST$$","c")) {print "ok 21\n";} else {print "not ok 21\n";}
+    $foo = `grep perl c 2>&1`;
     if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
     unlink 'c';
+    unlink("TEST$$");
 }
 else {
     print "ok 21\nok 22\n";
index 0190281..0e2d57c 100755 (executable)
@@ -9,6 +9,7 @@ BEGIN {
 $|  = 1;
 use warnings;
 $Is_VMS = $^O eq 'VMS';
+$Is_Dos = $^O eq 'dos';
 
 print "1..66\n";
 
@@ -268,13 +269,21 @@ ok;
 {
     local *F;
     for (1..2) {
+        if ($Is_Dos) {
         open(F, "echo \\#foo|") or print "not ";
+        } else {
+            open(F, "echo #foo|") or print "not ";
+        }
        print <F>;
        close F;
     }
     ok;
     for (1..2) {
+        if ($Is_Dos) {
        open(F, "-|", "echo \\#foo") or print "not ";
+        } else {
+            open(F, "-|", "echo #foo") or print "not ";
+        }
        print <F>;
        close F;
     }
index 96935e3..5008325 100755 (executable)
@@ -11,7 +11,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..15\n";
+print "1..16\n";
 
 # External program 'tr' assumed.
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
@@ -99,12 +99,23 @@ else {
     local $SIG{PIPE} = 'IGNORE';
     open NIL, '|true'  or die "open failed: $!";
     sleep 5;
-    print NIL 'foo'    or die "print failed: $!";
-    if (close NIL) {
-       print "not ok 9\n";
+    if (print NIL 'foo') {
+       # If print was allowed we had better get an error on close
+       if (close NIL) {
+           print "not ok 9\n";
+       }
+       else {
+           print "ok 9\n";
+       }
     }
     else {
-       print "ok 9\n";
+       # If print failed, the close should be clean
+       if (close NIL) {
+           print "ok 9\n";
+       }
+       else {
+           print "not ok 9\n";
+       }
     }
 }
 
@@ -174,3 +185,20 @@ if ($? != 42) {
 }
 print "ok 15\n";
 $? = 0;
+
+# check that child is reaped if the piped program can't be executed
+{
+  open NIL, '/no_such_process |';
+  close NIL;
+
+  my $child = 0;
+  eval {
+    local $SIG{ALRM} = sub { die; };
+    alarm 2;
+    $child = wait;
+    alarm 0;
+  };
+
+  print "not " if $child != -1;
+  print "ok 16\n";
+}
index b89aefb..560836d 100755 (executable)
@@ -2,7 +2,7 @@
 
 # $RCSfile: tell.t,v $$Revision$$Date$
 
-print "1..21\n";
+print "1..23\n";
 
 $TST = 'tst';
 
@@ -82,3 +82,13 @@ if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; }
     tell other;
     if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; }
 }
+
+close(other);
+if (tell(other) == -1)  { print "ok 22\n"; } else { print "not ok 22\n"; }
+
+if (tell(ether) == -1)  { print "ok 23\n"; } else { print "not ok 23\n"; }
+
+# ftell(STDIN) (or any std streams) is undefined, it can return -1 or
+# something else.  ftell() on pipes, fifos, and sockets is defined to
+# return -1.
+
diff --git a/t/io/utf8.t b/t/io/utf8.t
new file mode 100755 (executable)
index 0000000..04554e7
--- /dev/null
@@ -0,0 +1,163 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+    unless ($Config{'useperlio'}) {
+       print "1..0 # Skip: not perlio\n";
+       exit 0;
+    }
+}
+
+$| = 1;
+print "1..25\n";
+
+open(F,"+>:utf8",'a');
+print F chr(0x100).'£';
+print '#'.tell(F)."\n";
+print "not " unless tell(F) == 4;
+print "ok 1\n";
+print F "\n";
+print '#'.tell(F)."\n";
+print "not " unless tell(F) >= 5;
+print "ok 2\n";
+seek(F,0,0);
+print "not " unless getc(F) eq chr(0x100);
+print "ok 3\n";
+print "not " unless getc(F) eq "£";
+print "ok 4\n";
+print "not " unless getc(F) eq "\n";
+print "ok 5\n";
+seek(F,0,0);
+binmode(F,":bytes");
+print "not " unless getc(F) eq chr(0xc4);
+print "ok 6\n";
+print "not " unless getc(F) eq chr(0x80);
+print "ok 7\n";
+print "not " unless getc(F) eq chr(0xc2);
+print "ok 8\n";
+print "not " unless getc(F) eq chr(0xa3);
+print "ok 9\n";
+print "not " unless getc(F) eq "\n";
+print "ok 10\n";
+seek(F,0,0);
+binmode(F,":utf8");
+print "not " unless scalar(<F>) eq "\x{100}£\n";
+print "ok 11\n";
+seek(F,0,0);
+$buf = chr(0x200);
+$count = read(F,$buf,2,1);
+print "not " unless $count == 2;
+print "ok 12\n";
+print "not " unless $buf eq "\x{200}\x{100}£";
+print "ok 13\n";
+close(F);
+
+{
+$a = chr(300); # This *is* UTF-encoded
+$b = chr(130); # This is not.
+
+open F, ">:utf8", 'a' or die $!;
+print F $a,"\n";
+close F;
+
+open F, "<:utf8", 'a' or die $!;
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(300);
+print "ok 14\n";
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(196).chr(172);
+print "ok 15\n";
+close F;
+
+open F, ">:utf8", 'a' or die $!;
+binmode(F);  # we write a "\n" and then tell() - avoid CRLF issues.
+print F $a;
+my $y;
+{ my $x = tell(F); 
+    { use bytes; $y = length($a);}
+    print "not " unless $x == $y;
+    print "ok 16\n";
+}
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 1;
+print "ok 17\n";
+}
+
+print F $b,"\n"; # This upgrades $b!
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 2;
+print "ok 18\n";
+}
+
+{ my $x = tell(F); 
+    { use bytes; $y += 3;}
+    print "not " unless $x == $y;
+    print "ok 19\n";
+}
+
+close F;
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq v196.172.194.130;
+print "ok 20\n";
+
+open F, "<:utf8", "a" or die $!;
+$x = <F>;
+chomp($x);
+close F;
+print "not " unless $x eq chr(300).chr(130);
+print "ok 21\n";
+
+# Now let's make it suffer.
+open F, ">", "a" or die $!;
+eval { print F $a; };
+print "not " unless $@ and $@ =~ /Wide character in print/i;
+print "ok 22\n";
+}
+
+# Hm. Time to get more evil.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+binmode(F, ":bytes");
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 23\n";
+
+# Right.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+close F;
+open F, ">>", "a" or die $!;
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 24\n";
+
+# Now we have a deformed file.
+open F, "<:utf8", "a" or die $!;
+$x = <F>; chomp $x;
+{ local $SIG{__WARN__} = sub { print "ok 25\n"; };
+eval { sprintf "%vd\n", $x; }
+}
+
+unlink('a');
+
index 440122c..18a02ab 100644 (file)
@@ -11,9 +11,12 @@ BEGIN {
     }
 }
 
+use warnings;
+no warnings qw(deprecated);     # else attrs cries.
+
 sub NTESTS () ;
 
-my $test, $ntests;
+my ($test, $ntests);
 BEGIN {$ntests=0}
 $test=0;
 my $failed = 0;
@@ -119,7 +122,7 @@ BEGIN {++$ntests}
 
 {
     my $w = "" ;
-    local $SIG{__WARN__} = sub {$w = @_[0]} ;
+    local $SIG{__WARN__} = sub {$w = shift} ;
     eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }';
     (print "not "), $failed=1 if $@;
     print "ok ",++$test,"\n";
index 2be4d10..4329d71 100755 (executable)
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -10,7 +10,7 @@ use warnings;
 use strict;
 use Config;
 
-print "1..13\n";
+print "1..17\n";
 
 my $test = 1;
 
@@ -53,6 +53,20 @@ print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }})
 ok;
 }
 
+print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
+ok;
+
+use constant 'c', 'stuff';
+print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
+ok;
+
+# XXX ToDo - constsub that returns a reference
+#use constant cr => ['hello'];
+#my $string = "sub " . $deparse->coderef2text(\&cr);
+#my $val = (eval $string)->();
+#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
+#ok;
+
 my $a;
 my $Is_VMS = $^O eq 'VMS';
 $a = `$^X "-I../lib" "-MO=Deparse" -anle 1 2>&1`;
@@ -62,26 +76,21 @@ $b = <<'EOF';
 LINE: while (defined($_ = <ARGV>)) {
     chomp $_;
     @F = split(/\s+/, $_, 0);
-    '???'
-}
-continue {
-    '???'
+    '???';
 }
 
 EOF
 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
 ok;
 
-#6
 $a = `$^X "-I../lib" "-MO=Debug" -e 1 2>&1`;
 print "not " unless $a =~
 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
 ok;
 
-#7
 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`;
 print "not " unless $a =~
-/\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s;
+/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s;
 ok;
 
 $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`;
@@ -114,12 +123,13 @@ ok;
 
 chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e1`);
 $a = join ',', sort split /,/, $a;
+$a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 $a =~ s/-uCwd,// if $^O eq 'cygwin';
 if ($Config{static_ext} eq ' ') {
   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
-     . '-umain,-uwarnings';
+     . '-umain,-ustrict,-uwarnings';
   print "# [$a] vs [$b]\nnot " if $a ne $b;
   ok;
 } else {
@@ -133,3 +143,14 @@ if ($is_thread) {
     print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 }
 ok;
+
+# Bug 20001204.07
+{
+my $foo = $deparse->coderef2text(sub { { 234; }});
+# Constants don't get optimised here.
+print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+ok;
+$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
+print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; 
+ok;
+}
index 2081694..b335d13 100755 (executable)
@@ -449,10 +449,10 @@ $Math::BigFloat::div_scale = 20
 $Math::BigFloat::div_scale = 40
 &fsqrt
 +0:0
--1:/^(?i:0|\?|NaNQ?)$
--2:/^(?i:0|\?|NaNQ?)$
--16:/^(?i:0|\?|NaNQ?)$
--123.456:/^(?i:0|\?|NaNQ?)$
+-1:/^(?i:0|\?|-?N\.?aNQ?)$
+-2:/^(?i:0|\?|-?N\.?aNQ?)$
+-16:/^(?i:0|\?|-?N\.?aNQ?)$
+-123.456:/^(?i:0|\?|-?N\.?aNQ?)$
 +1:1.
 +1.44:1.2
 +2:1.41421356237309504880168872420969807857
index 653c4e5..3b9722e 100755 (executable)
@@ -36,6 +36,11 @@ my $CRLF = "\015\012";
 
 if ($^O eq 'VMS') { $CRLF = "\n"; }
 
+# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII
+# translation hence CRLF is used as \r\n within CGI.pm on such machines.
+
+if (ord("\t") != 9) { $CRLF = "\r\n"; }
+
 # Set up a CGI environment
 $ENV{REQUEST_METHOD}='GET';
 $ENV{QUERY_STRING}  ='game=chess&game=checkers&weather=dull';
index 50c8408..3d3da10 100755 (executable)
@@ -82,7 +82,12 @@ test(19,end_h3 eq '</h3>');
 test(20,start_table({-border=>undef}) eq '<table border>');
 test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; &#139;right&#155;</h1>');
 charset('utf-8');
+if (ord("\t") == 9) {
 test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; Â‹right›</h1>');
+}
+else {
+test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is &lt;not&gt; Â»rightº</h1>');
+}
 test(23,i(p('hello there')) eq '<i><p>hello there</p></i>');
 my $q = new CGI;
 test(24,$q->h1('hi') eq '<h1>hi</h1>');
diff --git a/t/lib/class-struct.t b/t/lib/class-struct.t
new file mode 100644 (file)
index 0000000..26505ba
--- /dev/null
@@ -0,0 +1,66 @@
+#!./perl -w
+
+BEGIN {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+}
+
+print "1..8\n";
+
+package aClass;
+
+sub new { bless {}, shift }
+
+sub meth { 42 }
+
+package MyObj;
+
+use Class::Struct;
+use Class::Struct 'struct'; # test out both forms
+
+use Class::Struct SomeClass => { SomeElem => '$' };
+
+struct( s => '$', a => '@', h => '%', c => 'aClass' );
+
+my $obj = MyObj->new;
+
+$obj->s('foo');
+
+print "not " unless $obj->s() eq 'foo';
+print "ok 1\n";
+
+my $arf = $obj->a;
+
+print "not " unless ref $arf eq 'ARRAY';
+print "ok 2\n";
+
+$obj->a(2, 'secundus');
+
+print "not " unless $obj->a(2) eq 'secundus';
+print "ok 3\n";
+
+my $hrf = $obj->h;
+
+print "not " unless ref $hrf eq 'HASH';
+print "ok 4\n";
+
+$obj->h('x', 10);
+
+print "not " unless $obj->h('x') == 10;
+print "ok 5\n";
+
+my $orf = $obj->c;
+
+print "not " unless ref $orf eq 'aClass';
+print "ok 6\n";
+
+print "not " unless $obj->c->meth() == 42;
+print "ok 7\n";
+
+my $obk = SomeClass->new();
+
+$obk->SomeElem(123);
+
+print "not " unless $obk->SomeElem() == 123;
+print "ok 8\n";
+
index 75c661b..1822823 100755 (executable)
@@ -9,10 +9,12 @@ BEGIN {
     }
 }
 
+use warnings;
+use strict;
 use DB_File; 
 use Fcntl;
 
-print "1..155\n";
+print "1..157\n";
 
 sub ok
 {
@@ -82,7 +84,9 @@ sub docat_del
 }   
 
 
-$db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+my $db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
+                               || $DB_File::db_ver >= 3.1 );
 
 my $Dfile = "dbbtree.tmp";
 unlink $Dfile;
@@ -128,17 +132,19 @@ ok(16, $dbh->{prefix} == 1234 );
 # Check that an invalid entry is caught both for store & fetch
 eval '$dbh->{fred} = 1234' ;
 ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
-eval '$q = $dbh->{fred}' ;
+eval 'my $q = $dbh->{fred}' ;
 ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
 
 # Now check the interface to BTREE
 
+my ($X, %h) ;
 ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
    $blksize,$blocks) = stat($Dfile);
 ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
 
+my ($key, $value, $i);
 while (($key,$value) = each(%h)) {
     $i++;
 }
@@ -209,8 +215,8 @@ $h{'goner3'} = 'snork';
 delete $h{'goner1'};
 $X->DELETE('goner3');
 
-@keys = keys(%h);
-@values = values(%h);
+my @keys = keys(%h);
+my @values = values(%h);
 
 ok(27, $#keys == 29 && $#values == 29) ;
 
@@ -235,12 +241,19 @@ ok(30, ArrayCompare(\@b, \@c)) ;
 $h{'foo'} = '';
 ok(31, $h{'foo'} eq '' ) ;
 
-#$h{''} = 'bar';
-#ok(32, $h{''} eq 'bar' );
-ok(32,1) ;
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+    $h{''} = 'bar';
+    $result = ( $h{''} eq 'bar' );
+}
+else
+  { $result = 1 }
+ok(32, $result) ;
 
 # check cache overflow and numeric keys and contents
-$ok = 1;
+my $ok = 1;
 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 ok(33, $ok);
@@ -250,7 +263,7 @@ ok(33, $ok);
 ok(34, $size > 0 );
 
 @h{0..200} = 200..400;
-@foo = @h{0..200};
+my @foo = @h{0..200};
 ok(35, join(':',200..400) eq join(':',@foo) );
 
 # Now check all the non-tie specific stuff
@@ -259,7 +272,7 @@ ok(35, join(':',200..400) eq join(':',@foo) );
 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
 # an existing record.
  
-$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 ok(36, $status == 1 );
  
 # check that the value of the key 'x' has not been changed by the 
@@ -280,9 +293,12 @@ ok(40, $value eq 'value' );
 
 $status = $X->del('q') ;
 ok(41, $status == 0 );
-#$status = $X->del('') ;
-#ok(42, $status == 0 );
-ok(42,1) ;
+if ($null_keys_allowed) {
+    $status = $X->del('') ;
+} else {
+    $status = 0 ;
+}
+ok(42, $status == 0 );
 
 # Make sure that the key deleted, cannot be retrieved
 ok(43, ! defined $h{'q'}) ;
@@ -362,7 +378,7 @@ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
 
 $status = $X->seq($key, $value, R_FIRST) ;
 ok(66, $status == 0 );
-$previous = $key ;
+my $previous = $key ;
 
 $ok = 1 ;
 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
@@ -411,6 +427,7 @@ untie %h ;
 unlink $Dfile;
 
 # Now try an in memory file
+my $Y;
 ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
 
 # fd with an in memory file should return failure
@@ -424,6 +441,7 @@ untie %h ;
 # Duplicate keys
 my $bt = new DB_File::BTREEINFO ;
 $bt->{flags} = R_DUP ;
+my ($YY, %hh);
 ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
 
 $hh{'Wall'} = 'Larry' ;
@@ -469,34 +487,38 @@ unlink $Dfile;
 
 
 # test multiple callbacks
-$Dfile1 = "btree1" ;
-$Dfile2 = "btree2" ;
-$Dfile3 = "btree3" ;
+my $Dfile1 = "btree1" ;
+my $Dfile2 = "btree2" ;
+my $Dfile3 = "btree3" ;
  
-$dbh1 = new DB_File::BTREEINFO ;
-{ local $^W = 0 ;
-  $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; }
+my $dbh1 = new DB_File::BTREEINFO ;
+$dbh1->{compare} = sub { 
+       no warnings 'numeric' ;
+       $_[0] <=> $_[1] } ; 
  
-$dbh2 = new DB_File::BTREEINFO ;
+my $dbh2 = new DB_File::BTREEINFO ;
 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
  
-$dbh3 = new DB_File::BTREEINFO ;
+my $dbh3 = new DB_File::BTREEINFO ;
 $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
  
  
-tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
+my (%g, %k);
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; 
 tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
 tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
  
-@Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
-{ local $^W = 0 ;
-  @srt_1 = sort { $a <=> $b } @Keys ; }
+my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
+my (@srt_1, @srt_2, @srt_3);
+{ 
+  no warnings 'numeric' ;
+  @srt_1 = sort { $a <=> $b } @Keys ; 
+}
 @srt_2 = sort { $a cmp $b } @Keys ;
 @srt_3 = sort { length $a <=> length $b } @Keys ;
  
 foreach (@Keys) {
-    { local $^W = 0 ; 
-      $h{$_} = 1 ; }
+    $h{$_} = 1 ;
     $g{$_} = 1 ;
     $k{$_} = 1 ;
 }
@@ -566,6 +588,7 @@ unlink $Dfile1 ;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -573,6 +596,7 @@ unlink $Dfile1 ;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -656,6 +680,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -762,6 +787,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (%h, $db) ;
 
@@ -824,6 +850,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    unlink $Dfile;
@@ -852,6 +879,7 @@ EOM
     # BTREE example 1
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
 
@@ -904,6 +932,7 @@ EOM
     # BTREE example 2
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
 
@@ -955,6 +984,7 @@ EOM
     # BTREE example 3
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1010,6 +1040,7 @@ EOM
     # BTREE example 4
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1058,6 +1089,7 @@ EOM
     # BTREE example 5
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1092,6 +1124,7 @@ EOM
     # BTREE example 6
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
  
@@ -1126,6 +1159,7 @@ EOM
     # BTREE example 7
     ###
 
+    use warnings FATAL => qw(all) ;
     use strict ;
     use DB_File ;
     use Fcntl ;
@@ -1217,4 +1251,46 @@ EOM
 #   unlink $Dfile;
 #}
 
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+       or die "Can't open file: $!\n" ;
+    $h{ABC} = undef;
+    ok(156, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
+       or die "Can't open file: $!\n" ;
+    %h = (); ;
+    ok(157, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
 exit ;
index b701874..effc60b 100755 (executable)
@@ -9,10 +9,12 @@ BEGIN {
     }
 }
 
+use strict;
+use warnings;
 use DB_File; 
 use Fcntl;
 
-print "1..109\n";
+print "1..111\n";
 
 sub ok
 {
@@ -57,6 +59,9 @@ sub docat_del
 }   
 
 my $Dfile = "dbhash.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
+                               || $DB_File::db_ver >= 3.1 );
+
 unlink $Dfile;
 
 umask(0);
@@ -98,13 +103,14 @@ ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
 
 
 # Now check the interface to HASH
-
+my ($X, %h);
 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
    $blksize,$blocks) = stat($Dfile);
 ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
 
+my ($key, $value, $i);
 while (($key,$value) = each(%h)) {
     $i++;
 }
@@ -176,8 +182,8 @@ $h{'goner3'} = 'snork';
 delete $h{'goner1'};
 $X->DELETE('goner3');
 
-@keys = keys(%h);
-@values = values(%h);
+my @keys = keys(%h);
+my @values = values(%h);
 
 ok(23, $#keys == 29 && $#values == 29) ;
 
@@ -197,14 +203,19 @@ ok(25, $#keys == 31) ;
 $h{'foo'} = '';
 ok(26, $h{'foo'} eq '' );
 
-# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
-# This feature will be reenabled in a future version of Berkeley DB.
-#$h{''} = 'bar';
-#ok(27, $h{''} eq 'bar' );
-ok(27,1) ;
+# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
+# This feature was reenabled in version 3.1 of Berkeley DB.
+my $result = 0 ;
+if ($null_keys_allowed) {
+    $h{''} = 'bar';
+    $result = ( $h{''} eq 'bar' );
+}
+else
+  { $result = 1 }
+ok(27, $result) ;
 
 # check cache overflow and numeric keys and contents
-$ok = 1;
+my $ok = 1;
 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 ok(28, $ok );
@@ -214,7 +225,7 @@ ok(28, $ok );
 ok(29, $size > 0 );
 
 @h{0..200} = 200..400;
-@foo = @h{0..200};
+my @foo = @h{0..200};
 ok(30, join(':',200..400) eq join(':',@foo) );
 
 
@@ -223,7 +234,7 @@ ok(30, join(':',200..400) eq join(':',@foo) );
 # Check NOOVERWRITE will make put fail when attempting to overwrite
 # an existing record.
  
-$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 ok(31, $status == 1 );
  
 # check that the value of the key 'x' has not been changed by the 
@@ -246,9 +257,10 @@ $status = $X->del('q') ;
 ok(36, $status == 0 );
 
 # Make sure that the key deleted, cannot be retrieved
-$^W = 0 ;
-ok(37, $h{'q'} eq undef );
-$^W = 1 ;
+{
+    no warnings 'uninitialized' ;
+    ok(37, $h{'q'} eq undef );
+}
 
 # Attempting to delete a non-existant key should fail
 
@@ -361,6 +373,7 @@ untie %h ;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -368,6 +381,7 @@ untie %h ;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -451,6 +465,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -557,6 +572,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (%h, $db) ;
 
@@ -619,6 +635,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (%h, $db) ;
    unlink $Dfile;
@@ -643,6 +660,7 @@ EOM
   {
     my $redirect = new Redirect $file ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use DB_File ;
     use vars qw( %h $k $v ) ;
@@ -682,4 +700,44 @@ EOM
    
 }
 
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+    $h{ABC} = undef;
+    ok(110, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
+    %h = (); ;
+    ok(111, $a eq "") ;
+    untie %h ;
+    unlink $Dfile;
+}
+
 exit ;
index 18fb45b..8b5a88c 100755 (executable)
@@ -12,6 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 use strict ;
+use warnings;
 use vars qw($dbh $Dfile $bad_ones $FA) ;
 
 # full tied array support started in Perl 5.004_57
@@ -99,7 +100,7 @@ sub bad_one
 EOM
 }
 
-print "1..126\n";
+print "1..128\n";
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -340,6 +341,7 @@ unlink $Dfile;
 
    package Another ;
 
+   use warnings ;
    use strict ;
 
    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
@@ -347,6 +349,7 @@ unlink $Dfile;
 
    package SubDB ;
 
+   use warnings ;
    use strict ;
    use vars qw( @ISA @EXPORT) ;
 
@@ -487,6 +490,7 @@ EOM
 
 {
    # DBM Filter tests
+   use warnings ;
    use strict ;
    my (@h, $db) ;
    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
@@ -593,6 +597,7 @@ EOM
 {    
     # DBM Filter with a closure
 
+    use warnings ;
     use strict ;
     my (@h, $db) ;
 
@@ -655,6 +660,7 @@ EOM
 
 {
    # DBM Filter recursion detection
+   use warnings ;
    use strict ;
    my (@h, $db) ;
    unlink $Dfile;
@@ -679,6 +685,7 @@ EOM
   {
     my $redirect = new Redirect $file ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use DB_File ;
 
@@ -734,6 +741,7 @@ EOM
   {
     my $redirect = new Redirect $save_output ;
 
+    use warnings FATAL => qw(all);
     use strict ;
     use vars qw(@h $H $file $i) ;
     use DB_File ;
@@ -836,4 +844,46 @@ EOM
    
 }
 
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use DB_File ;
+
+    unlink $Dfile;
+    my @h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
+       or die "Can't open file: $!\n" ;
+    $h[0] = undef;
+    ok(127, $a eq "") ;
+    untie @h ;
+    unlink $Dfile;
+}
+
+{
+    # test that %hash = () doesn't produce the warning
+    #     Argument "" isn't numeric in entersub
+    use warnings ;
+    use strict ;
+    use DB_File ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+    unlink $Dfile;
+    my @h ;
+    
+    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
+       or die "Can't open file: $!\n" ;
+    @h = (); ;
+    ok(128, $a eq "") ;
+    untie @h ;
+    unlink $Dfile;
+}
+
 exit ;
index 10c9b0f..be711f1 100755 (executable)
@@ -11,7 +11,8 @@ BEGIN {
 }
 
 END {
-    unlink 'tmon.out', 'err';
+    while(-e 'tmon.out' && unlink 'tmon.out') {}
+    while(-e 'err' && unlink 'err') {}
 }
 
 use Benchmark qw( timediff timestr );
@@ -22,7 +23,7 @@ getopts('vI:p:');
 # -I   Add to @INC
 # -p   Name of perl binary
 
-@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>;  # glob-sort, for OS/2
+@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>);  # glob-sort, for OS/2
 
 $path_sep = $Config{path_sep} || ':';
 $perl5lib = $opt_I || join( $path_sep, @INC );
@@ -46,7 +47,7 @@ sub profile {
        my $opt_d = '-d:DProf';
 
        my $t_start = new Benchmark;
-       open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n";
+        open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
        @results = <R>;
        close R;
        my $t_total = timediff( new Benchmark, $t_start );
@@ -56,15 +57,17 @@ sub profile {
                print @results
        }
 
-       print timestr( $t_total, 'nop' ), "\n";
+        print '# ',timestr( $t_total, 'nop' ), "\n";
 }
 
 
 sub verify {
        my $test = shift;
 
-       system $perl, '-I../lib', '-I./lib/dprof', $test,
-               $opt_v?'-v':'', '-p', $perl;
+       my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test;
+       $command .= ' -v' if $opt_v;
+       $command .= ' -p '. $perl;
+       system $command;
 }
 
 
@@ -72,6 +75,7 @@ $| = 1;
 print "1..18\n";
 while( @tests ){
        $test = shift @tests;
+        $test =~ s/\.$// if $^O eq 'VMS';
        if( $test =~ /_t$/i ){
                print "# $test" . '.' x (20 - length $test);
                profile $test;
index 7e34da5..cbdeca4 100644 (file)
@@ -13,6 +13,7 @@ $num = 0;
 $results = $expected = '';
 $perl = $opt_p || $^X;
 $dpp = $opt_d || '../utils/dprofpp';
+$dpp .= '.com' if $^O eq 'VMS';
 
 print "\nperl: $perl\n" if $opt_v;
 if( ! -f $perl ){ die "Where's Perl?" }
@@ -21,7 +22,7 @@ if( ! -f $dpp ){ die "Where's dprofpp?" }
 sub dprofpp {
        my $switches = shift;
 
-       open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n";
+        open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n";
        @results = <D>;
        close D;
 
index 568efd3..280c2d0 100644 (file)
@@ -12,7 +12,11 @@ use Encode qw(from_to);
 use charnames qw(greek);
 my @encodings = grep(/iso8859/,Encode::encodings());
 my $n = 2;
-plan test => 13+$n*@encodings;
+my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
+my @source = qw(ascii iso8859-1 cp1250);
+my @destiny = qw(cp1047 cp37 posix-bc);
+my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
+plan test => 21+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256;
 my $str = join('',map(chr($_),0x20..0x7E));
 my $cpy = $str;
 ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
@@ -27,7 +31,7 @@ ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
 
 my $sym = Encode->getEncoding('symbol');
 my $uni = $sym->toUnicode('a');
-ok("\N{alpha}",substr($uni,0,1),"alpha does not map so symbol 'a'");
+ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'");
 $str = $sym->fromUnicode("\N{Beta}");
 ok("B",substr($str,0,1),"Symbol 'B' does not map to Beta");
 
@@ -41,3 +45,58 @@ foreach my $enc (qw(symbol dingbats ascii),@encodings)
   ok($cpy,$str,"$enc mangled translating to Unicode and back");
  }
 
+# On ASCII based machines see if we can map several codepoints from
+# three distinct ASCII sets to three distinct EBCDIC coded character sets.
+# On EBCDIC machines see if we can map from three EBCDIC sets to three
+# distinct ASCII sets.
+
+my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
+if (ord('A') != 65) {
+    my @temp = @destiny;
+    @destiny = @source;
+    @source = @temp;
+    undef(@temp);
+    @expectation = (48..57, 65..90, 97..122);
+}
+
+foreach my $to (@destiny)
+ {
+  foreach my $from (@source)
+   {
+    my @expected = @expectation;
+    foreach my $chr (@character_set)
+     {
+      my $native_chr = $chr;
+      my $cpy = $chr;
+      my $rc = from_to($cpy,$from,$to);
+      ok(1,$rc,"Could not translate from $from to $to");
+      ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to");
+     }
+   }
+ }
+
+# On either ASCII or EBCDIC machines ensure we can take the full one
+# byte repetoire to EBCDIC sets and back.
+
+my $enc_as = 'iso8859-1';
+foreach my $enc_eb (@ebcdic_sets)
+ {
+  foreach my $ord (0..255)
+   {
+    $str = chr($ord);
+    my $rc = from_to($str,$enc_as,$enc_eb);
+    $rc += from_to($str,$enc_eb,$enc_as);
+    ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained");
+    ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back");
+   }
+ }
+
+for $i (256,128,129,256)
+ {
+  my $c = chr($i);
+  my $s = "$c\n".sprintf("%02X",$i);
+  ok(Encode::valid_utf8($s),1,"concat of $i botched");
+  Encode::utf8_upgrade($s);
+  ok(Encode::valid_utf8($s),1,"concat of $i botched");
+ }
+
diff --git a/t/lib/filter-util.pl b/t/lib/filter-util.pl
new file mode 100644 (file)
index 0000000..9b29c5e
--- /dev/null
@@ -0,0 +1,48 @@
+sub readFile
+{
+    my ($filename) = @_ ;
+    my ($string) = '' ;
+
+    open (F, "<$filename") 
+       or die "Cannot open $filename: $!\n" ;
+    while (<F>)
+      { $string .= $_ }
+    close F ;
+    $string ;
+}
+
+sub writeFile
+{
+    my($filename, @strings) = @_ ;
+    open (F, ">$filename") 
+       or die "Cannot open $filename: $!\n" ;
+    binmode(F) if $filename =~ /bin$/i;
+    foreach (@strings)
+      { print F }
+    close F ;
+}
+
+sub ok
+{
+    my($number, $result, $note) = @_ ;
+    $note = "" if ! defined $note ;
+    if ($note) {
+        $note = "# $note" if $note !~ /^\s*#/ ;
+        $note =~ s/^\s*/ / ;
+    }
+
+    print "not " if !$result ;
+    print "ok ${number}${note}\n";
+}
+
+$Inc = '' ;
+foreach (@INC)
+ { $Inc .= "\"-I$_\" " }
+
+$Perl = '' ;
+$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
+
+$Perl = "$Perl -w" ;
+
+1;
diff --git a/t/lib/filter-util.t b/t/lib/filter-util.t
new file mode 100644 (file)
index 0000000..80c8f56
--- /dev/null
@@ -0,0 +1,791 @@
+BEGIN {
+    chdir('t') if -d 't';    
+    @INC = '.'; 
+    push @INC, '../lib';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) {
+        print "1..0 # Skip: Filter::Util::Call was not built\n";
+        exit 0;
+    }
+    require 'lib/filter-util.pl';
+}
+
+print "1..28\n" ;
+
+$Perl = "$Perl -w" ;
+
+use Cwd ;
+$here = getcwd ;
+
+use vars qw($Inc $Perl);
+
+$filename = "call.tst" ;
+$filenamebin = "call.bin" ;
+$module   = "MyTest" ;
+$module2  = "MyTest2" ;
+$module3  = "MyTest3" ;
+$module4  = "MyTest4" ;
+$module5  = "MyTest5" ;
+$nested   = "nested" ;
+$block   = "block" ;
+
+# Test error cases
+##################
+
+# no filter function in module 
+###############################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+sub import { filter_add(bless []) }
+
+1 ;
+EOM
+$a = `$Perl "-I." $Inc -e "use ${module} ;"  2>&1` ;
+ok(1, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ;
+ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ;
+# no reference parameter in filter_add
+######################################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+use Filter::Util::Call ;
+sub import { filter_add() }
+1 ;
+EOM
+$a = `$Perl "-I." $Inc -e "use ${module} ;"  2>&1` ;
+ok(3, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ;
+#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ;
+ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ;
+
+
+
+# non-error cases
+#################
+
+
+# a simple filter, using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+EOM
+use Filter::Util::Call ;
+sub import { 
+    filter_add(
+       sub {
+           my ($status) ;
+           if (($status = filter_read()) > 0) {
+               s/ABC/DEF/g 
+           }
+           $status ;
+       } ) ;
+}
+
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(5, ($? >>8) == 0) ;
+ok(6, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+# a simple filter, not using a closure
+#################
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+EOM
+use Filter::Util::Call ;
+sub import { filter_add(bless []) }
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read()) > 0) {
+        s/ABC/DEF/g
+    }
+    $status ;
+}
+
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $module ;
+EOM
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(7, ($? >>8) == 0) ;
+ok(8, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+
+# nested filters
+################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+EOM
+sub import { filter_add(bless []) }
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read()) > 0) {
+        s/XYZ/PQR/g
+    }
+    $status ;
+}
+1 ;
+EOM
+writeFile("${module3}.pm", <<EOM, <<'EOM') ;
+package ${module3} ;
+use Filter::Util::Call ;
+EOM
+sub import { filter_add(
+    sub 
+    {
+        my ($status) ;
+     
+        if (($status = filter_read()) > 0) {
+            s/Fred/Joe/g
+        }
+        $status ;
+    } ) ;
+}
+1 ;
+EOM
+writeFile("${module4}.pm", <<EOM) ;
+package ${module4} ;
+use $module5 ;
+
+print "I'm feeling used!\n" ;
+print "Fred Joe ABC DEF PQR XYZ\n" ;
+print "See you Today\n" ;
+1;
+EOM
+
+writeFile("${module5}.pm", <<EOM, <<'EOM') ;
+package ${module5} ;
+use Filter::Util::Call ;
+EOM
+sub import { filter_add(bless []) }
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read()) > 0) {
+        s/Today/Tomorrow/g
+    }
+    $status ;
+}
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+# two filters for this file
+use $module ;
+use $module2 ;
+require "$nested" ;
+use $module4 ;
+EOM
+print "some letters ABCXYZ\n" ;
+$y = "ABCDEFXYZ" ;
+print <<EOF ;
+Fred likes Alphabetti Spagetti ($y)
+EOF
+EOM
+writeFile($nested, <<EOM, <<'EOM') ;
+use $module3 ;
+EOM
+print "This is another file XYZ\n" ;
+print <<EOF ;
+Where is Fred?
+EOF
+EOM
+
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(9, ($? >>8) == 0) ;
+ok(10, $a eq <<EOM) ;
+I'm feeling used!
+Fred Joe ABC DEF PQR XYZ
+See you Tomorrow
+This is another file XYZ
+Where is Joe?
+some letters DEFPQR
+Fred likes Alphabetti Spagetti (DEFDEFPQR)
+EOM
+
+# using the module context (with a closure)
+###########################################
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{
+    my ($type) = shift ;
+    my (@strings) = @_ ;
+    filter_add (
+       sub 
+       {
+           my ($status) ;
+           my ($pattern) ;
+            
+           if (($status = filter_read()) > 0) {
+                foreach $pattern (@strings)
+                   { s/$pattern/PQR/g }
+           }
+            
+           $status ;
+       }
+       )
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(11, ($? >>8) == 0) ;
+ok(12, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+
+# using the module context (without a closure)
+##############################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+EOM
+sub import 
+{ 
+    my ($type) = shift ;
+    my (@strings) = @_ ;
+
+  
+    filter_add (bless [@strings]) 
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    my ($pattern) ;
+    if (($status = filter_read()) > 0) {
+       foreach $pattern (@$self)
+          { s/$pattern/PQR/g }
+    }
+
+    $status ;
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(13, ($? >>8) == 0) ;
+ok(14, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+# multi line test
+#################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{ 
+    my ($type) = shift ;
+    my (@strings) = @_ ;
+
+  
+    filter_add(bless []) 
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    # read first line
+    if (($status = filter_read()) > 0) {
+       chop ;
+       s/\r$//;
+       # and now the second line (it will append)
+        $status = filter_read() ;
+    }
+
+    $status ;
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $module2  ;
+EOM
+print "don't cut me 
+in half\n" ;
+print  
+<<EOF ;
+appen
+ded
+EO
+F
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(15, ($? >>8) == 0) ;
+ok(16, $a eq <<EOM) ;
+don't cut me in half
+appended
+EOM
+
+# Block test
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{ 
+    my ($type) = shift ;
+    my (@strings) = @_ ;
+
+  
+    filter_add (bless [@strings] )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    my ($pattern) ;
+    filter_read(20)  ;
+}
+1 ;
+EOM
+
+$string = <<'EOM' ;
+print "hello mum\n" ;
+$x = 'me ' x 3 ;
+print "Who wants it?\n$x\n" ;
+EOM
+
+
+writeFile($filename, <<EOM, $string ) ;
+use $block ;
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(17, ($? >>8) == 0) ;
+ok(18, $a eq <<EOM) ;
+hello mum
+Who wants it?
+me me me 
+EOM
+
+# use in the filter
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+use Cwd ;
+
+sub import
+{ 
+    my ($type) = shift ;
+    my (@strings) = @_ ;
+
+  
+    filter_add(bless [@strings] )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    my ($here) = quotemeta getcwd ;
+    if (($status = filter_read()) > 0) {
+        s/DIR/$here/g
+    }
+    $status ;
+}
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "We are in DIR\n" ;
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(19, ($? >>8) == 0) ;
+ok(20, $a eq <<EOM) ;
+We are in $here
+EOM
+
+
+# filter_del
+#############
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{
+    my ($type) = shift ;
+    my ($count) = @_ ;
+    filter_add(bless \$count )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    s/HERE/THERE/g
+        if ($status = filter_read()) > 0 ;
+
+    -- $$self ;
+    filter_del() if $$self <= 0 ;
+
+    $status ;
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block (3) ;
+EOM
+print "
+HERE I am
+I am HERE
+HERE today gone tomorrow\n" ;
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(21, ($? >>8) == 0) ;
+ok(22, $a eq <<EOM) ;
+
+THERE I am
+I am THERE
+HERE today gone tomorrow
+EOM
+
+
+# filter_read_exact
+####################
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{
+    my ($type) = shift ;
+    filter_add(bless [] )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read_exact(9)) > 0) {
+        s/HERE/THERE/g
+    }
+    $status ;
+}
+1 ;
+EOM
+writeFile($filenamebin, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "
+HERE I am
+I'm HERE
+HERE today gone tomorrow\n" ;
+EOM
+$a = `$Perl "-I." $Inc $filenamebin  2>&1` ;
+ok(23, ($? >>8) == 0) ;
+ok(24, $a eq <<EOM) ;
+
+HERE I am
+I'm THERE
+THERE today gone tomorrow
+EOM
+
+{
+
+# Check __DATA__
+####################
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{
+    my ($type) = shift ;
+    filter_add(bless [] )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read()) > 0) {
+        s/HERE/THERE/g
+    }
+    $status ;
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__DATA__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(25, ($? >>8) == 0) ;
+ok(26, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+{
+
+# Check __END__
+####################
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+EOM
+sub import
+{
+    my ($type) = shift ;
+    filter_add(bless [] )
+}
+sub filter
+{
+    my ($self) = @_ ;
+    my ($status) ;
+    if (($status = filter_read()) > 0) {
+        s/HERE/THERE/g
+    }
+    $status ;
+}
+1 ;
+EOM
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__END__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+$a = `$Perl "-I." $Inc $filename  2>&1` ;
+ok(27, ($? >>8) == 0) ;
+ok(28, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+END {
+    1 while unlink $filename ;
+    1 while unlink $filenamebin ;
+    1 while unlink "${module}.pm" ;
+    1 while unlink "${module2}.pm" ;
+    1 while unlink "${module3}.pm" ;
+    1 while unlink "${module4}.pm" ;
+    1 while unlink "${module5}.pm" ;
+    1 while unlink $nested ;
+    1 while unlink "${block}.pm" ;
+}
+
+
index 9503ea7..2209baa 100755 (executable)
@@ -15,6 +15,7 @@ use strict;
 use File::Spec;
 use File::Path;
 use File::Temp qw/ :mktemp unlink0 /;
+use FileHandle;
 
 ok(1);
 
index 2e45586..bc3845c 100755 (executable)
@@ -11,6 +11,8 @@ BEGIN {
 use strict;
 
 use File::Temp qw/ :POSIX unlink0 /;
+use FileHandle;
+
 ok(1);
 
 # TMPNAM - scalar
index 48a52b3..ed59765 100755 (executable)
@@ -5,7 +5,7 @@ BEGIN {
        chdir 't' if -d 't';
        @INC = '../lib';
        require Test; import Test;
-       plan(tests => 16);
+       plan(tests => 20);
 }
 
 use strict;
@@ -51,6 +51,10 @@ my ($fh, $tempfile) = tempfile(
                              );
 
 ok( (-f $tempfile) );
+# Should still be around after closing
+ok( close( $fh ) ); 
+ok( (-f $tempfile) );
+# Check again at exit
 push(@files, $tempfile);
 
 # TEMPDIR test
@@ -113,5 +117,29 @@ ok( -f $tempfile );
 ok( close( $fh ) );
 push( @still_there, $tempfile); # check at END
 
+# Would like to create a temp file and just retrieve the handle
+# but the test is problematic since:
+#  - We dont know the filename so we cant check that it is tidied
+#    correctly
+#  - The unlink0 required on unix for tempfile creation will fail
+#    on NFS
+# Try to do what we can.
+# Tempfile croaks on error so we need an eval
+$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) };
+
+if ($fh) {
+
+  # print something to it to make sure something is there
+  ok( print $fh "Test\n" );
+
+  # Close it - can not check it is gone since we dont know the name
+  ok( close($fh) );
+
+} else {
+  skip "Skip Failed probably due to NFS", 1;
+  skip "Skip Failed probably due to NFS", 1;
+}
+
 # Now END block will execute to test the removal of directories
+print "# End of tests. Execute END blocks\n";
 
index 54f5994..af83fdd 100755 (executable)
@@ -13,7 +13,7 @@ BEGIN {
 
 use GDBM_File;
 
-print "1..66\n";
+print "1..68\n";
 
 unlink <Op.dbmx*>;
 
@@ -178,6 +178,7 @@ EOM
     close FILE ;
 
     BEGIN { push @INC, '.'; }
+    unlink <dbhash.tmp*> ;
 
     eval 'use SubDB ; ';
     main::ok(13, $@ eq "") ;
@@ -392,3 +393,24 @@ EOM
    untie %h;
    unlink <Op.dbmx*>;
 }
+
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use GDBM_File ;
+
+    unlink <Op.dbmx*>;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640));
+    $h{ABC} = undef;
+    ok(68, $a eq "") ;
+    untie %h;
+    unlink <Op.dbmx*>;
+}
index 5a8e16c..38292a7 100755 (executable)
@@ -30,7 +30,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..14\n";
+print "1..20\n";
 
 use IO::Socket;
 
@@ -70,17 +70,15 @@ if($pid = fork()) {
 
 } elsif(defined $pid) {
 
-    # This can fail if localhost is undefined or the
-    # special 'loopback' address 127.0.0.1 is not configured
-    # on your system. (/etc/rc.config.d/netconfig on HP-UX.)
-    # As a shortcut (not recommended) you could change 'localhost'
-    # here to be the name of this machine eg 'myhost.mycompany.com'.
-
     $sock = IO::Socket::INET->new(PeerPort => $port,
                                  Proto => 'tcp',
                                  PeerAddr => 'localhost'
                                 )
-       or die "$! (maybe your system does not have the 'localhost' address defined)";
+         || IO::Socket::INET->new(PeerPort => $port,
+                                 Proto => 'tcp',
+                                 PeerAddr => '127.0.0.1'
+                                )
+       or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
 
     $sock->autoflush(1);
 
@@ -114,7 +112,8 @@ if($pid = fork()) {
     $listen->close;
 } elsif (defined $pid) {
     # child, try various ways to connect
-    $sock = IO::Socket::INET->new("localhost:$port");
+    $sock = IO::Socket::INET->new("localhost:$port")
+         || IO::Socket::INET->new("127.0.0.1:$port");
     if ($sock) {
        print "not " unless $sock->connected;
        print "ok 6\n";
@@ -151,10 +150,14 @@ if($pid = fork()) {
     sleep(1);
 
     $sock = IO::Socket->new(Domain => AF_INET,
-                            PeerAddr => "localhost:$port");
+                            PeerAddr => "localhost:$port")
+         || IO::Socket->new(Domain => AF_INET,
+                            PeerAddr => "127.0.0.1:$port");
     if ($sock) {
        $sock->print("ok 11\n");
        $sock->print("quit\n");
+    } else {
+       print "not ok 11\n";
     }
     $sock = undef;
     sleep(1);
@@ -166,7 +169,10 @@ if($pid = fork()) {
 # Then test UDP sockets
 $server = IO::Socket->new(Domain => AF_INET,
                           Proto  => 'udp',
-                          LocalAddr => 'localhost');
+                          LocalAddr => 'localhost')
+       || IO::Socket->new(Domain => AF_INET,
+                          Proto  => 'udp',
+                          LocalAddr => '127.0.0.1');
 $port = $server->sockport;
 
 if ($^O eq 'mpeix') {
@@ -179,7 +185,9 @@ if ($^O eq 'mpeix') {
     } elsif (defined($pid)) {
         #child
         $sock = IO::Socket::INET->new(Proto => 'udp',
-                                      PeerAddr => "localhost:$port");
+                                      PeerAddr => "localhost:$port")
+             || IO::Socket::INET->new(Proto => 'udp',
+                                      PeerAddr => "127.0.0.1:$port");
         $sock->send("ok 12\n");
         sleep(1);
         $sock->send("ok 12\n");  # send another one to be sure
@@ -195,3 +203,131 @@ print "ok 13\n";
 $server->blocking(0);
 print "not " if $server->blocking;
 print "ok 14\n";
+
+### TEST 15
+### Set up some data to be transfered between the server and
+### the client. We'll use own source code ...
+#
+local @data;
+if( !open( SRC, "< $0")) {
+    print "not ok 15 - $!";
+} else {
+    @data = <SRC>;
+    close( SRC);
+}
+print "ok 15\n";
+
+### TEST 16
+### Start the server
+#
+my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
+    print "not ";
+print "ok 16\n";
+die if( !defined( $listen));
+my $serverport = $listen->sockport;
+
+my $server_pid = fork();
+if( $server_pid) {
+
+    ### TEST 17 Client/Server establishment
+    #
+    print "ok 17\n";
+
+    ### TEST 18
+    ### Get data from the server using a single stream
+    #
+    $sock = IO::Socket::INET->new("localhost:$serverport")
+         || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+    if ($sock) {
+       $sock->print("send\n");
+
+       my @array = ();
+       while( <$sock>) {
+           push( @array, $_);
+       }
+
+       $sock->print("done\n");
+       $sock->close;
+
+       print "not " if( @array != @data);
+    } else {
+       print "not ";
+    }
+    print "ok 18\n";
+
+    ### TEST 19
+    ### Get data from the server using a stream, which is
+    ### interrupted by eof calls.
+    ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
+    ### did an getc followed by an ungetc in order to check for the streams
+    ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
+    ### a recv(2) call on the socket, while ungetc(3) put back a character
+    ### to an IO buffer, which never again was read.
+    #
+    $sock = IO::Socket::INET->new("localhost:$serverport")
+         || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+    if ($sock) {
+       $sock->print("send\n");
+
+       my @array = ();
+       while( !eof( $sock ) ){
+           while( <$sock>) {
+               push( @array, $_);
+               last;
+           }
+       }
+
+       $sock->print("done\n");
+       $sock->close;
+
+       print "not " if( @array != @data);
+    } else {
+       print "not ";
+    }
+    print "ok 19\n";
+
+    ### TEST 20
+    ### Stop the server
+    #
+    $sock = IO::Socket::INET->new("localhost:$serverport")
+         || IO::Socket::INET->new("127.0.0.1:$serverport");
+
+    if ($sock) {
+       $sock->print("done\n");
+       $sock->close;
+
+       print "not " if( 1 != kill 0, $server_pid);
+    } else {
+       print "not ";
+    }
+    print "ok 20\n";
+
+} elsif( defined( $server_pid)) {
+   
+    ### Child
+    #
+    SERVER_LOOP: while (1) {
+       last SERVER_LOOP unless $sock = $listen->accept;
+       while (<$sock>) {
+           last SERVER_LOOP if /^quit/;
+           last if /^done/;
+           if( /^send/) {
+               print $sock @data;
+               last;
+           }
+           print;
+       }
+       $sock = undef;
+    }
+    $listen->close;
+
+} else {
+
+    ### Fork failed
+    #
+    print "not ok 17\n";
+    die;
+}
+
index 3aa4b03..65c63bd 100755 (executable)
@@ -27,7 +27,7 @@ print "1..13\n";
 use IO::File;
 
 $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
-binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos');
+binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos');
 if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
 
 $firstline = <$tst>;
index 9df62cf..d63a5dc 100755 (executable)
@@ -57,19 +57,15 @@ print "1..7\n";
 use Socket;
 use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
 
-    # This can fail if localhost is undefined or the
-    # special 'loopback' address 127.0.0.1 is not configured
-    # on your system. (/etc/rc.config.d/netconfig on HP-UX.)
-    # As a shortcut (not recommended) you could change 'localhost'
-    # here to be the name of this machine eg 'myhost.mycompany.com'.
-
 $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
-    or die "$! (maybe your system does not have the 'localhost' address defined)";
+     || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
+    or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
 
 print "ok 1\n";
 
 $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
-    or die "$! (maybe your system does not have the 'localhost' address defined)";
+     || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
+    or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
 
 print "ok 2\n";
 
index 9305c31..2449fc4 100755 (executable)
@@ -40,3 +40,4 @@ print scalar <$x>;
 $! = 0;
 $x->setpos(undef);
 print $! ? "ok 4 # $!\n" : "not ok 4\n";
+
index 4937a8c..a834444 100755 (executable)
@@ -16,7 +16,7 @@ require NDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..64\n";
+print "1..65\n";
 
 unlink <Op.dbmx*>;
 
@@ -391,3 +391,20 @@ EOM
    untie %h;
    unlink <Op.dbmx*>;
 }
+
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use NDBM_File ;
+
+    unlink <Op.dbmx*>;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+}
diff --git a/t/lib/net-hostent.t b/t/lib/net-hostent.t
new file mode 100644 (file)
index 0000000..abc5b92
--- /dev/null
@@ -0,0 +1,72 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bSocket\b/ && 
+        !(($^O eq 'VMS') && $Config{d_socket})) {
+       print "1..0 # Test uses Socket, Socket not built\n";
+       exit 0;
+    }
+}
+
+BEGIN { $| = 1; print "1..7\n"; }
+
+END {print "not ok 1\n" unless $loaded;}
+
+use Net::hostent;
+
+$loaded = 1;
+print "ok 1\n";
+
+# test basic resolution of localhost <-> 127.0.0.1
+use Socket;
+
+my $h = gethost('localhost');
+print +(defined $h ? '' : 'not ') . "ok 2\n";
+my $i = gethostbyaddr(inet_aton("127.0.0.1"));
+print +(!defined $i ? 'not ' : '') . "ok 3\n";
+
+print "not " if inet_ntoa($h->addr) ne "127.0.0.1";
+print "ok 4\n";
+
+print "not " if inet_ntoa($i->addr) ne "127.0.0.1";
+print "ok 5\n";
+
+# need to skip the name comparisons on Win32 because windows will
+# return the name of the machine instead of "localhost" when resolving
+# 127.0.0.1 or even "localhost"
+
+# VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others
+# OS/390 returns localhost.YADDA.YADDA
+
+if ($^O eq 'MSWin32' or $^O eq 'cygwin') {
+  print "ok $_ # skipped on win32\n" for (6,7);
+} else {
+  my $in_alias;
+  unless ($h->name =~ /^localhost(?:\..+)?$/i) {
+    foreach (@{$h->aliases}) {
+      if (/^localhost(?:\..+)?$/i) {
+       $in_alias = 1;
+       last;
+      }
+    }
+    print "not " unless $in_alias;
+  } # Else we found it as the hostname
+  print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n";
+
+  if ($in_alias) {
+    # If we found it in the aliases before, expect to find it there again.
+    foreach (@{$h->aliases}) {
+      if (/^localhost(?:\..+)?$/i) {
+       undef $in_alias; # This time, clear the flag if we see "localhost"
+       last;
+      }
+    }
+    print "not " if $in_alias;
+  } else {
+    print "not " unless $i->name =~ /^localhost(?:\..+)?$/i;
+  }
+  print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n";
+}
index ccd3e60..f2c1bb6 100755 (executable)
@@ -16,7 +16,7 @@ require ODBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..64\n";
+print "1..66\n";
 
 unlink <Op.dbmx*>;
 
@@ -394,6 +394,27 @@ EOM
    unlink <Op.dbmx*>;
 }
 
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use ODBM_File ;
+
+    unlink <Op.dbmx*>;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+    $h{ABC} = undef;
+    ok(66, $a eq "") ;
+    untie %h;
+    unlink <Op.dbmx*>;
+}
+
 if ($^O eq 'hpux') {
     print <<EOM;
 #
index a90574f..288d3bd 100644 (file)
@@ -88,10 +88,10 @@ do_test( 5,
 
 do_test( 6,
         $c + $d,
-'SV = NV\\($ADDR\\) at $ADDR
+'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(PADTMP,NOK,pNOK\\)
-  NV = 456');
+  FLAGS = \\(PADTMP,IOK,pIOK\\)
+  IV = 456');
 
 ($d = "789") += 0.1;
 
@@ -110,8 +110,8 @@ do_test( 8,
         0xabcd,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\)
-  UV = 43981');
+  FLAGS = \\(.*IOK,READONLY,pIOK\\)
+  IV = 43981');
 
 do_test( 9,
         undef,
@@ -154,12 +154,10 @@ do_test(11,
       FLAGS = \\(IOK,pIOK\\)
       IV = 123
     Elt No. 1
-    SV = PVNV\\($ADDR\\) at $ADDR
+    SV = IV\\($ADDR\\) at $ADDR
       REFCNT = 1
-      FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
-      IV = 456
-      NV = 456
-      PV = 0');
+      FLAGS = \\(IOK,pIOK\\)
+      IV = 456');
 
 do_test(12,
        {$b=>$c},
@@ -180,12 +178,10 @@ do_test(12,
     RITER = -1
     EITER = 0x0
     Elt "123" HASH = $ADDR
-    SV = PVNV\\($ADDR\\) at $ADDR
+    SV = IV\\($ADDR\\) at $ADDR
       REFCNT = 1
-      FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
-      IV = 456
-      NV = 456
-      PV = 0');
+      FLAGS = \\(IOK,pIOK\\)
+      IV = 456');
 
 do_test(13,
         sub(){@_},
index b6a1a69..d60447e 100755 (executable)
@@ -15,7 +15,7 @@ require SDBM_File;
 #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
 use Fcntl;
 
-print "1..66\n";
+print "1..68\n";
 
 unlink <Op_dbmx.*>;
 
@@ -396,3 +396,24 @@ unlink <Op_dbmx*>, $Dfile;
    unlink <Op_dbmx*>;
 }
 
+{
+    # Bug ID 20001013.009
+    #
+    # test that $hash{KEY} = undef doesn't produce the warning
+    #     Use of uninitialized value in null operation 
+    use warnings ;
+    use strict ;
+    use SDBM_File ;
+
+    unlink <Op_dbmx*>;
+    my %h ;
+    my $a = "";
+    local $SIG{__WARN__} = sub {$a = $_[0]} ;
+    
+    ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+    $h{ABC} = undef;
+    ok(68, $a eq "") ;
+
+    untie %h;
+    unlink <Op_dbmx*>;
+}
index 28fe664..77d73bb 100644 (file)
@@ -1,10 +1,19 @@
 #!./perl
 
-# $Id: lock.t,v 1.0.1.1 2000/09/28 21:44:06 ram Exp $
+# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $
 #
 #  @COPYRIGHT@
 #
 # $Log: lock.t,v $
+# Revision 1.0.1.4  2001/01/03 09:41:00  ram
+# patch7: use new CAN_FLOCK routine to determine whether to run tests
+#
+# Revision 1.0.1.3  2000/10/26 17:11:27  ram
+# patch5: just check $^O, there's no need for the whole Config
+#
+# Revision 1.0.1.2  2000/10/23 18:03:07  ram
+# patch4: protected calls to flock() for dos platform
+#
 # Revision 1.0.1.1  2000/09/28 21:44:06  ram
 # patch2: created.
 #
@@ -19,10 +28,7 @@ sub BEGIN {
         print "1..0 # Skip: Storable was not built\n";
         exit 0;
     }
-    if (!$Config{'d_flock'} && !$Config{'d_fcntl'} && !$Config{'d_lockf'}) {
-        print "1..0 # Skip: no flock or flock emulation on this platform\n";
-        exit 0;
-    }
+
     require 'lib/st-dump.pl';
 }
 
@@ -30,6 +36,11 @@ sub ok;
 
 use Storable qw(lock_store lock_retrieve);
 
+unless (&Storable::CAN_FLOCK) {
+    print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
+       exit 0;
+}
+
 print "1..5\n";
 
 @a = ('first', undef, 3, -4, -3.14159, 456, 4.5);
index dcf6d1a..b429747 100644 (file)
@@ -1,6 +1,6 @@
 #!./perl
 
-# $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 ram Exp $
+# $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $
 #
 #  Copyright (c) 1995-2000, Raphael Manfredi
 #  
@@ -8,6 +8,10 @@
 #  in the README file that comes with the distribution.
 #  
 # $Log: recurse.t,v $
+# Revision 1.0.1.2  2000/11/05 17:22:05  ram
+# patch6: stress hook a little more with refs to lexicals
+#
+# $Log: recurse.t,v $
 # Revision 1.0.1.1  2000/09/17 16:48:05  ram
 # patch1: added test case for store hook bug
 #
@@ -97,15 +101,19 @@ sub make {
 
 sub STORABLE_freeze {
        my $self = shift;
-       my $t = dclone($self->{sync});
-       return ("", [$t, $self->{ext}], $self, $self->{ext});
+       my %copy = %$self;
+       my $r = \%copy;
+       my $t = dclone($r->{sync});
+       return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
 }
 
 sub STORABLE_thaw {
        my $self = shift;
-       my ($cloning, $undef, $a, $obj, $ext) = @_;
+       my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
        die "STORABLE_thaw #1" unless $obj eq $self;
        die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+       die "STORABLE_thaw #3" unless ref $r eq 'HASH';
+       die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
        $self->{ok} = $self;
        ($self->{sync}, $self->{ext}) = @$a;
 }
index 96625f2..2bdb69d 100644 (file)
@@ -14,6 +14,11 @@ BEGIN {
        require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);
 }
 
+use strict;
+
+our @s;
+our $fail;
+
 sub zap {
     close(BIG);
     unlink("big");
@@ -26,35 +31,42 @@ sub bye {
     exit(0);
 }
 
+my $explained;
+
 sub explain {
-    print <<EOM;
+    unless ($explained++) {
+       print <<EOM;
 #
-# If the lfs (large file support: large meaning larger than two gigabytes)
-# tests are skipped or fail, it may mean either that your process
-# (or process group) is not allowed to write large files (resource
-# limits) or that the file system you are running the tests on doesn't
-# let your user/group have large files (quota) or the filesystem simply
-# doesn't support large files.  You may even need to reconfigure your kernel.
-# (This is all very operating system and site-dependent.)
+# If the lfs (large file support: large meaning larger than two
+# gigabytes) tests are skipped or fail, it may mean either that your
+# process (or process group) is not allowed to write large files
+# (resource limits) or that the file system (the network filesystem?)
+# you are running the tests on doesn't let your user/group have large
+# files (quota) or the filesystem simply doesn't support large files.
+# You may even need to reconfigure your kernel.  (This is all very
+# operating system and site-dependent.)
 #
 # Perl may still be able to support large files, once you have
 # such a process, enough quota, and such a (file) system.
+# It is just that the test failed now.
 #
 EOM
+    }
+    print "1..0 # Skip: @_\n" if @_;
 }
 
 print "# checking whether we have sparse files...\n";
 
 # Known have-nots.
-if ($^O eq 'win32' || $^O eq 'vms') {
-    print "1..0 # Skip: no sparse files (because this is $^O) \n";
+if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+    print "1..0 # Skip: no sparse files in $^O\n";
     bye();
 }
 
 # Known haves that have problems running this test
 # (for example because they do not support sparse files, like UNICOS)
 if ($^O eq 'unicos') {
-    print "1..0 # Skip: large files known to work but unable to test them here ($^O)\n";
+    print "1..0 # Skip: no sparse files in $^0, unable to test large files\n";
     bye();
 }
 
@@ -120,9 +132,8 @@ sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or
 my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
 unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
     $sysseek = 'undef' unless defined $sysseek;
-    print "1..0 # Skip: seeking past 2GB failed: ",
-           $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)", "\n";
-    explain();
+    explain("seeking past 2GB failed: ",
+           $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)");
     bye();
 }
 
@@ -135,11 +146,12 @@ my $close     = close BIG;
 print "# close failed: $!\n" unless $close;
 unless($syswrite && $close) {
     if ($! =~/too large/i) {
-       print "1..0 # Skip: writing past 2GB failed: process limits?\n";
+       explain("writing past 2GB failed: process limits?");
     } elsif ($! =~ /quota/i) {
-       print "1..0 # Skip: filesystem quota limits?\n";
+       explain("filesystem quota limits?");
+    } else {
+       explain("error: $!");
     }
-    explain();
     bye();
 }
 
@@ -148,8 +160,7 @@ unless($syswrite && $close) {
 print "# @s\n";
 
 unless ($s[7] == 5_000_000_003) {
-    print "1..0 # Skip: not configured to use large files?\n";
-    explain();
+    explain("kernel/fs not configured to use large files?");
     bye();
 }
 
@@ -158,9 +169,30 @@ sub fail () {
     $fail++;
 }
 
+sub offset ($$) {
+    my ($offset_will_be, $offset_want) = @_;
+    my $offset_is = eval $offset_will_be;
+    unless ($offset_is == $offset_want) {
+        print "# bad offset $offset_is, want $offset_want\n";
+       my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
+       if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+           print "# 32-bit wraparound suspected in $offset_func() since\n";
+           print "# $offset_want cast into 32 bits equals $offset_is.\n";
+       } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
+                == $offset_is) {
+           print "# 32-bit wraparound suspected in $offset_func() since\n";
+           printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
+               $offset_want,
+               $offset_want,
+               $offset_is;
+        }
+        fail;
+    }
+}
+
 print "1..17\n";
 
-my $fail = 0;
+$fail = 0;
 
 fail unless $s[7] == 5_000_000_003;    # exercizes pp_stat
 print "ok 1\n";
@@ -176,28 +208,28 @@ print "ok 4\n";
 
 sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };
 
-fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000;
+offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
 print "ok 5\n";
 
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
 print "ok 6\n";
 
-fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001;
+offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001);
 print "ok 7\n";
 
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001);
 print "ok 8\n";
 
-fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000);
 print "ok 9\n";
 
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
 print "ok 10\n";
 
-fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000;
+offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000);
 print "ok 11\n";
 
-fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000);
 print "ok 12\n";
 
 my $big;
@@ -209,7 +241,9 @@ fail unless $big eq "big";
 print "ok 14\n";
 
 # 705_032_704 = (I32)5_000_000_000
-fail unless seek(BIG, 705_032_704, SEEK_SET);
+# See that we don't have "big" in the 705_... spot:
+# that would mean that we have a wraparound.
+fail unless sysseek(BIG, 705_032_704, SEEK_SET);
 print "ok 15\n";
 
 my $zero;
@@ -220,7 +254,7 @@ print "ok 16\n";
 fail unless $zero eq "\0\0\0";
 print "ok 17\n";
 
-explain if $fail;
+explain() if $fail;
 
 bye(); # does the necessary cleanup
 
index 7ad4204..04adb6b 100755 (executable)
@@ -8,21 +8,56 @@ BEGIN {
        print "1..0 # Skip: Sys::Syslog was not built\n";
        exit 0;
     }
+
+    require Socket;
+
+    # This code inspired by Sys::Syslog::connect():
+    require Sys::Hostname;
+    my ($host_uniq) = Sys::Hostname::hostname();
+    my ($host)      = $host_uniq =~ /([A-Za-z0-9_.-]+)/;
+
+    if (! defined Socket::inet_aton($host)) {
+        print "1..0 # Skip: Can't lookup $host\n";
+        exit 0;
+    }
 }
 
 use Sys::Syslog qw(:DEFAULT setlogsock);
 
+# Test this to 1 if your syslog accepts udp connections.
+# Most don't (or at least shouldn't)
+my $Test_Syslog_INET = 0;
+
 print "1..6\n";
 
 if (Sys::Syslog::_PATH_LOG()) {
-    print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n";
-    print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n";
-    print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n";
+    if (-e Sys::Syslog::_PATH_LOG()) {
+        print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n";
+        print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n";
+        print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n";
+    }
+    else {
+        for (1..3) {
+            print
+                "ok $_ # skipping, file ",
+                Sys::Syslog::_PATH_LOG(),
+                " does not exist\n";
+        }
+    }
 }
 else {
     for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" }
 }
 
-print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n";
-print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n";
-print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n";
+if( $Test_Syslog_INET ) {
+    print defined(eval { setlogsock('inet') }) ? "ok 4\n" 
+                                               : "not ok 4\n";
+    print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" 
+                                                                : "not ok 5\n";
+    print defined(eval { syslog('info', 'test') }) ? "ok 6\n" 
+                                                   : "not ok 6\n";
+}
+else {
+    print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n" 
+      foreach (4..6);
+}
index 680e1af..bc6aed7 100755 (executable)
@@ -13,7 +13,7 @@ BEGIN {
     $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 }
 $| = 1;
-print "1..22\n";
+print "1..74\n";
 use Thread 'yield';
 print "ok 1\n";
 
@@ -129,3 +129,79 @@ $thr1->join;
 $thr2->join;
 $thr3->join;
 print "ok 22\n";
+
+{
+    my $THRf_STATE_MASK = 7;
+    my $THRf_R_JOINABLE = 0;
+    my $THRf_R_JOINED = 1;
+    my $THRf_R_DETACHED = 2;
+    my $THRf_ZOMBIE = 3;
+    my $THRf_DEAD = 4;
+    my $THRf_DID_DIE = 8;
+    sub _test {
+       my($test, $t, $state, $die) = @_;
+       my $flags = $t->flags;
+       if (($flags & $THRf_STATE_MASK) == $state
+               && !($flags & $THRf_DID_DIE) == !$die) {
+           print "ok $test\n";
+       } else {
+           print <<BAD;
+not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]}
+BAD
+       }
+    }
+
+    my @t;
+    push @t, (
+       Thread->new(sub { sleep 4; die "thread die\n" }),
+       Thread->new(sub { die "thread die\n" }),
+       Thread->new(sub { sleep 4; 1 }),
+       Thread->new(sub { 1 }),
+    ) for 1, 2;
+    $_->detach for @t[grep $_ & 4, 0..$#t];
+
+    sleep 1;
+    my $test = 23;
+    for (0..7) {
+       my $t = $t[$_];
+       my $flags = ($_ & 1)
+           ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE
+           : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
+       _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
+       printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
+    }
+#   $test = 39;
+    for (grep $_ & 1, 0..$#t) {
+       next if $_ & 4;         # can't join detached threads
+       $t[$_]->eval;
+       my $die = ($_ & 2) ? "" : "thread die\n";
+       printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
+    }
+#   $test = 41;
+    for (0..7) {
+       my $t = $t[$_];
+       my $flags = ($_ & 1)
+           ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
+           : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE;
+       _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE);
+       printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++;
+    }
+#   $test = 57;
+    for (grep !($_ & 1), 0..$#t) {
+       next if $_ & 4;         # can't join detached threads
+       $t[$_]->eval;
+       my $die = ($_ & 2) ? "" : "thread die\n";
+       printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++;
+    }
+    sleep 1;   # make sure even the detached threads are done sleeping
+#   $test = 59;
+    for (0..7) {
+       my $t = $t[$_];
+       my $flags = ($_ & 1)
+           ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD
+           : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD;
+       _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE);
+       printf "%sok %s\n", $t->done ? "" : "not ", $test++;
+    }
+#   $test = 75;
+}
diff --git a/t/lib/tie-refhash.t b/t/lib/tie-refhash.t
new file mode 100644 (file)
index 0000000..d80b2e1
--- /dev/null
@@ -0,0 +1,305 @@
+#!/usr/bin/perl -w
+# 
+# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
+# 
+# The testing is in two parts: first, run lots of tests on both a tied
+# hash and an ordinary un-tied hash, and check they give the same
+# answer.  Then there are tests for those cases where the tied hashes
+# should behave differently to normal hashes, that is, when using
+# references as keys.
+# 
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}    
+
+use strict;
+use Tie::RefHash;
+use Data::Dumper;
+my $numtests = 34;
+my $currtest = 1;
+print "1..$numtests\n";
+
+my $ref = []; my $ref1 = [];
+
+# Test standard hash functionality, by performing the same operations
+# on a tied hash and on a normal hash, and checking that the results
+# are the same.  This does of course assume that Perl hashes are not
+# buggy :-)
+# 
+my @tests = standard_hash_tests();
+
+my @ordinary_results = runtests(\@tests, undef);
+foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
+    my @tied_results = runtests(\@tests, $class);
+    my $all_ok = 1;
+
+    die if @ordinary_results != @tied_results;
+    foreach my $i (0 .. $#ordinary_results) {
+        my ($or, $ow, $oe) = @{$ordinary_results[$i]};
+        my ($tr, $tw, $te) = @{$tied_results[$i]};
+        
+        my $ok = 1;
+        local $^W = 0;
+        $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
+        $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
+        $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
+        
+        if (not $ok) {
+            print STDERR
+              "failed for $class: $tests[$i]\n",
+              "ordinary hash gave:\n",
+              defined $or ? "\tresult:    $or\n" : "\tundef result\n",
+              defined $ow ? "\twarning:   $ow\n" : "\tno warning\n",
+              defined $oe ? "\texception: $oe\n" : "\tno exception\n",
+              "tied $class hash gave:\n",
+              defined $tr ? "\tresult:    $tr\n" : "\tundef result\n",
+              defined $tw ? "\twarning:   $tw\n" : "\tno warning\n",
+              defined $te ? "\texception: $te\n" : "\tno exception\n",
+              "\n";
+            $all_ok = 0;
+        }
+    }
+    test($all_ok);
+}
+
+# Now test Tie::RefHash's special powers
+my (%h, $h);
+$h = eval { tie %h, 'Tie::RefHash' };
+warn $@ if $@;
+test(not $@);
+test(ref($h) eq 'Tie::RefHash');
+test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
+$h{$ref} = 'cholet';
+test($h{$ref} eq 'cholet');
+test(exists $h{$ref});
+test((keys %h) == 1);
+test(ref((keys %h)[0]) eq 'ARRAY');
+test((keys %h)[0] eq $ref);
+test((values %h) == 1);
+test((values %h)[0] eq 'cholet');
+my $count = 0;
+while (my ($k, $v) = each %h) {
+    if ($count++ == 0) {
+        test(ref($k) eq 'ARRAY');
+        test($k eq $ref);
+    }
+}
+test($count == 1);
+delete $h{$ref};
+test(not defined $h{$ref});
+test(not exists($h{$ref}));
+test((keys %h) == 0);
+test((values %h) == 0);
+undef $h;
+untie %h;
+
+# And now Tie::RefHash::Nestable's differences from Tie::RefHash.
+$h = eval { tie %h, 'Tie::RefHash::Nestable' };
+warn $@ if $@;
+test(not $@);
+test(ref($h) eq 'Tie::RefHash::Nestable');
+test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
+$h{$ref}->{$ref1} = 'bungo';
+test($h{$ref}->{$ref1} eq 'bungo');
+
+# Test that the nested hash is also tied (for current implementation)
+test(defined(tied(%{$h{$ref}}))
+     and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
+
+test((keys %h) == 1);
+test((keys %h)[0] eq $ref);
+test((keys %{$h{$ref}}) == 1);
+test((keys %{$h{$ref}})[0] eq $ref1);
+
+
+die "expected to run $numtests tests, but ran ", $currtest - 1
+  if $currtest - 1 != $numtests;
+
+@tests = ();
+undef $ref;
+undef $ref1;
+
+exit();
+
+
+# Print 'ok X' if true, 'not ok X' if false
+# Uses global $currtest.
+# 
+sub test {
+    my $t = shift;
+    print 'not ' if not $t;
+    print 'ok ', $currtest++, "\n";
+}
+
+
+# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. 
+sub dumped {
+    my $s = shift;
+    my $d = Dumper($s);
+    $d =~ s/^\$VAR1 =\s*//;
+    $d =~ s/;$//;
+    chomp $d;
+    return $d;
+}
+
+# Crudely dump a hash into a canonical string representation (because
+# hash keys can appear in any order, Data::Dumper may give different
+# strings for the same hash).
+# 
+sub dumph {
+    my $h = shift;
+    my $r = '';
+    foreach (sort keys %$h) {
+        $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
+    }
+    return $r;
+}
+
+# Run the tests and give results.
+# 
+# Parameters: reference to list of tests to run
+#             name of class to use for tied hash, or undef if not tied
+# 
+# Returns: list of [R, W, E] tuples, one for each test.
+# R is the return value from running the test, W any warnings it gave,
+# and E any exception raised with 'die'.  E and W will be tidied up a
+# little to remove irrelevant details like line numbers :-)
+# 
+# Will also run a few of its own 'ok N' tests.
+# 
+sub runtests {
+    my ($tests, $class) = @_;
+    my @r;
+
+    my (%h, $h);
+    if (defined $class) {
+        $h = eval { tie %h, $class };
+        warn $@ if $@;
+        test(not $@);
+        test(ref($h) eq $class);
+        test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
+    }
+
+    foreach (@$tests) {
+        my ($result, $warning, $exception);
+        local $SIG{__WARN__} = sub { $warning .= $_[0] };
+        $result = scalar(eval $_);
+        if ($@)
+         {
+          die "$@:$_" unless defined $class;
+          $exception = $@;
+         }
+
+        foreach ($warning, $exception) {
+            next if not defined;
+            s/ at .+ line \d+\.$//mg;
+            s/ at .+ line \d+, at .*//mg;
+            s/ at .+ line \d+, near .*//mg;
+        }
+
+        my (@warnings, %seen);
+        foreach (split /\n/, $warning) {
+            push @warnings, $_ unless $seen{$_}++;
+        }
+        $warning = join("\n", @warnings);
+
+        push @r, [ $result, $warning, $exception ];
+    }
+
+    return @r;
+}
+
+
+# Things that should work just the same for an ordinary hash and a
+# Tie::RefHash.
+# 
+# Each test is a code string to be eval'd, it should do something with
+# %h and give a scalar return value.  The global $ref and $ref1 may
+# also be used.
+# 
+# One thing we don't test is that the ordering from 'keys', 'values'
+# and 'each' is the same.  You can't reasonably expect that.
+# 
+sub standard_hash_tests {
+    my @r;
+
+    # Library of standard tests on keys, values and each
+    my $STD_TESTS = <<'END'
+    join $;, sort keys %h;
+    join $;, sort values %h;
+    { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
+    { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
+END
+  ;
+    
+    # Tests on the existence of the element 'foo'
+    my $FOO_TESTS = <<'END'
+    defined $h{foo};
+    exists $h{foo};
+    $h{foo};    
+END
+  ;
+
+    # Test storing and deleting 'foo'
+    push @r, split /\n/, <<"END"
+    $STD_TESTS;
+    $FOO_TESTS;
+    \$h{foo} = undef;
+    $STD_TESTS;
+    $FOO_TESTS;
+    \$h{foo} = 'hello';
+    $STD_TESTS;
+    $FOO_TESTS;
+    delete  \$h{foo};
+    $STD_TESTS;
+    $FOO_TESTS;
+END
+  ;
+
+    # Test storing and removing under ordinary keys
+    my @things = ('boink', 0, 1, '', undef);
+    foreach my $key (map { dumped($_) } @things) {
+        foreach my $value ((map { dumped($_) } @things), '$ref') {
+            push @r, split /\n/, <<"END"
+            \$h{$key} = $value;
+            $STD_TESTS;
+            defined \$h{$key};
+            exists \$h{$key};
+            \$h{$key};
+            delete \$h{$key};
+            $STD_TESTS;
+            defined \$h{$key};
+            exists \$h{$key};
+            \$h{$key};
+END
+  ;
+        }
+    }
+    
+    # Test hash slices
+    my @slicetests;
+    @slicetests = split /\n/, <<'END'
+    @h{'b'} = ();
+    @h{'c'} = ('d');
+    @h{'e'} = ('f', 'g');
+    @h{'h', 'i'} = ();
+    @h{'j', 'k'} = ('l');
+    @h{'m', 'n'} = ('o', 'p');
+    @h{'q', 'r'} = ('s', 't', 'u');
+END
+  ;
+    my @aaa = @slicetests;
+    foreach (@slicetests) {
+        push @r, $_;
+        push @r, split(/\n/, $STD_TESTS);
+    }
+
+    # Test CLEAR
+    push @r, '%h = ();', split(/\n/, $STD_TESTS);
+
+    return @r;
+}
+
diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t
new file mode 100644 (file)
index 0000000..d7ea6cc
--- /dev/null
@@ -0,0 +1,17 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}
+
+# bug id 20001020.002
+# -dlc 20001021
+
+use Tie::Array;
+tie @a,Tie::StdArray;
+undef *Tie::StdArray::SPLICE;
+require "op/splice.t"
+
+# Pre-fix, this failed tests 6-9
diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t
new file mode 100644 (file)
index 0000000..8256db7
--- /dev/null
@@ -0,0 +1,111 @@
+#!/usr/bin/perl -w
+# 
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}    
+
+print "1..20\n";
+
+use strict;
+
+require Tie::SubstrHash;
+
+my %a;
+
+tie %a, 'Tie::SubstrHash', 3, 3, 3;
+
+$a{abc} = 123;
+$a{bcd} = 234;
+
+print "not " unless $a{abc} == 123;
+print "ok 1\n";
+
+print "not " unless keys %a == 2;
+print "ok 2\n";
+
+delete $a{abc};
+
+print "not " unless $a{bcd} == 234;
+print "ok 3\n";
+
+print "not " unless (values %a)[0] == 234;
+print "ok 4\n";
+
+eval { $a{abcd} = 123 };
+print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+print "ok 5\n";
+
+eval { $a{abc} = 1234 };
+print "not " unless $@ =~ /Value "1234" is not 3 characters long/;
+print "ok 6\n";
+
+eval { $a = $a{abcd}; $a++  };
+print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+print "ok 7\n";
+
+@a{qw(abc cde)} = qw(123 345); 
+
+print "not " unless $a{cde} == 345;
+print "ok 8\n";
+
+eval { $a{def} = 456 };
+print "not " unless $@ =~ /Table is full \(3 elements\)/;
+print "ok 9\n";
+
+%a = ();
+
+print "not " unless keys %a == 0;
+print "ok 10\n";
+
+# Tests 11..16 by Linc Madison.
+
+my $hashsize = 119;                # arbitrary values from my data
+my %test;
+tie %test, "Tie::SubstrHash", 13, 86, $hashsize;
+
+for (my $i = 1; $i <= $hashsize; $i++) {
+        my $key1 = $i + 100_000;           # fix to uniform 6-digit numbers
+        my $key2 = "abcdefg$key1";
+        $test{$key2} = ("abcdefgh" x 10) . "$key1";
+}
+
+for (my $i = 1; $i <= $hashsize; $i++) {
+        my $key1 = $i + 100_000;
+        my $key2 = "abcdefg$key1";
+       unless ($test{$key2}) {
+               print "not ";
+               last;
+       }
+}
+print "ok 11\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(1) == 2;
+print "ok 12\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(2) == 2;
+print "ok 13\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7;
+print "ok 14\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(13) == 13;
+print "ok 15\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17;
+print "ok 16\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(114) == 127;
+print "ok 17\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009;
+print "ok 18\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031;
+print "ok 19\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007;
+print "ok 20\n";
+
index 88fbc55..c34d188 100644 (file)
@@ -16,7 +16,7 @@ BEGIN {
 # 32+ bit integers don't cause noise
 no warnings qw(overflow portable);
 
-print "1..55\n";
+print "1..58\n";
 
 my $q = 12345678901;
 my $r = 23456789012;
@@ -294,4 +294,36 @@ $q = 18446744073709551615;
 print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615";
 print "ok 55\n";
 
+# Test that sv_2nv then sv_2iv is the same as sv_2iv direct
+# fails if whatever Atol is defined as can't actually cope with >32 bits.
+my $num = 4294967297;
+my $string = "4294967297";
+{
+  use integer;
+  $num += 0;
+  $string += 0;
+}
+if ($num eq $string) {
+  print "ok 56\n";
+} else {
+  print "not ok 56 # \"$num\" ne \"$string\"\n";
+}
+
+# Test that sv_2nv then sv_2uv is the same as sv_2uv direct
+$num = 4294967297;
+$string = "4294967297";
+$num &= 0;
+$string &= 0;
+if ($num eq $string) {
+  print "ok 57\n";
+} else {
+  print "not ok 57 # \"$num\" ne \"$string\"\n";
+}
+
+$q = "18446744073709551616e0";
+$q += 0;
+print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615";
+print "ok 58\n";
+
+
 # eof
index 7cc84e3..d48b5fb 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..70\n";
+print "1..71\n";
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -229,3 +229,8 @@ print "ok 69\n";
 
 print "not " unless unshift(@ary,12) == 5;
 print "ok 70\n";
+
+sub foo { "a" }
+@foo=(foo())[0,0];
+$foo[1] eq "a" or print "not ";
+print "ok 71\n";
index 2d05b82..aff433c 100755 (executable)
@@ -21,7 +21,7 @@ sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; }
 
 sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; }
     
-print "1..23\n";
+print "1..32\n";
 
 { my $x; $x ++;     ok  1, ! uninitialized; }
 { my $x; $x --;     ok  2, ! uninitialized; }
@@ -55,7 +55,19 @@ print "1..23\n";
 { my $x; $x |= "x"; ok 21, ! uninitialized; }
 { my $x; $x ^= "x"; ok 22, ! uninitialized; }
 
-ok 23, $warn eq '';
+{ use integer; my $x; $x += 1; ok 23, ! uninitialized; }
+{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; }
+
+{ use integer; my $x; $x *= 1; ok 25,  uninitialized; }
+{ use integer; my $x; $x /= 1; ok 26,  uninitialized; }
+{ use integer; my $x; $x %= 1; ok 27,  uninitialized; }
+
+{ use integer; my $x; $x ++;   ok 28, ! uninitialized; }
+{ use integer; my $x; $x --;   ok 29, ! uninitialized; }
+{ use integer; my $x; ++ $x;   ok 30, ! uninitialized; }
+{ use integer; my $x; -- $x;   ok 31, ! uninitialized; }
+
+ok 32, $warn eq '';
 
 # If we got any errors that we were not expecting, then print them
 print map "#$_\n", split /\n/, $warn if length $warn;
index 2702004..f9212e4 100644 (file)
@@ -142,6 +142,10 @@ eval 'my A $x : plugh plover;';
 mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
 BEGIN {++$ntests}
 
+eval 'package Cat; my Cat @socks;';
+mytest qr/^Can't declare class for non-scalar \@socks in "my"/;
+BEGIN {++$ntests}
+
 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 sub X::foo { 1 }
 *Y::bar = \&X::foo;
index fd080e6..622d169 100755 (executable)
@@ -9,7 +9,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..38\n";
+print "1..42\n";
 
 # numerics
 print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n");
@@ -107,7 +107,7 @@ for (0x100...0xFFF) {
       if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_);
 }
 if (@not36) {
-    print "# test 36 failed: @not36\n";
+    print "# test 36 failed\n";
     print "not ";
 }
 print "ok 36\n";
@@ -120,14 +120,46 @@ for my $i (0xEEE...0xF00) {
     push @not37, sprintf("%#03X %#03X", $i, $j)
        if $a ne chr(~$i).chr(~$j) or
           length($a) != 2 or 
-          ~$a ne chr($i).chr($j);
+           ~$a ne chr($i).chr($j);
   }
 }
 if (@not37) {
-    print "# test 37 failed: @not37\n";
+    print "# test 37 failed\n";
     print "not ";
 }
 print "ok 37\n";
 
 print "not " unless ~chr(~0) eq "\0";
 print "ok 38\n";
+
+my @not39;
+
+for my $i (0x100..0x120) {
+    for my $j (0x100...0x120) {
+       push @not39, sprintf("%#03X %#03X", $i, $j)
+           if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j));
+    }
+}
+if (@not39) {
+    print "# test 39 failed\n";
+    print "not ";
+}
+print "ok 39\n";
+
+my @not40;
+
+for my $i (0x100..0x120) {
+    for my $j (0x100...0x120) {
+       push @not40, sprintf("%#03X %#03X", $i, $j)
+           if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j));
+    }
+}
+if (@not40) {
+    print "# test 40 failed\n";
+    print "not ";
+}
+print "ok 40\n";
+
+# More variations on 19 and 22.
+print "ok \xFF\x{FF}\n" & "ok 41\n";
+print "ok \x{FF}\xFF\n" & "ok 42\n";
index 6723ca3..65d0669 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..30\n";
+print "1..33\n";
 
 # optimized
 
@@ -89,3 +89,17 @@ $_ = "ab\n";
 $/ = \3;
 print chomp() == 0 ? "ok 29\n" : "not ok 29\n";
 print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n";
+
+# Go Unicode.
+
+$_ = "abc\x{1234}";
+chop;
+print $_ eq "abc" ? "ok 31\n" : "not ok 31\n";
+
+$_ = "abc\x{1234}d";
+chop;
+print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n";
+
+$_ = "\x{1234}\x{2345}";
+chop;
+print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n";
index 4a7e68d..ffd34c6 100755 (executable)
 #!./perl
 
-@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1);
+BEGIN {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+}
+
+# 2s complement assumption. Won't break test, just makes the internals of
+# the SVs less interesting if were not on 2s complement system.
+my $uv_max = ~0;
+my $uv_maxm1 = ~0 ^ 1;
+my $uv_big = $uv_max;
+$uv_big = ($uv_big - 20000) | 1;
+my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small);
+$iv_max = $uv_max; # Do copy, *then* divide
+$iv_max /= 2;
+$iv_min = $iv_max;
+{
+  use integer;
+  $iv0 = 2 - 2;
+  $iv1 = 3 - 2;
+  $ivm1 = 2 - 3;
+  $iv_max -= 1;
+  $iv_min += 0;
+  $iv_big = $iv_max - 3;
+  $iv_small = $iv_min + 2;
+}
+my $uv_bigi = $iv_big;
+$uv_bigi |= 0x0;
+
+# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed.
+@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5,
+       'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1,
+       $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big,
+       $iv_small);
 
-$expect = ($#FOO+2) * ($#FOO+1);
+$expect = 6 * ($#FOO+2) * ($#FOO+1);
 print "1..$expect\n";
 
 my $ok = 0;
 for my $i (0..$#FOO) {
     for my $j ($i..$#FOO) {
        $ok++;
-       my $cmp = $FOO[$i] <=> $FOO[$j];
-       if (!defined($cmp) ||
-           $cmp == -1 && $FOO[$i] < $FOO[$j] ||
-           $cmp == 0  && $FOO[$i] == $FOO[$j] ||
-           $cmp == 1  && $FOO[$i] > $FOO[$j])
+       # Comparison routines may convert these internally, which would change
+       # what is used to determine the comparison on later runs. Hence copy
+       my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10,
+           $i11, $i12, $i13, $i14, $i15) =
+         ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+          $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+          $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]);
+       my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10,
+           $j11, $j12, $j13, $j14, $j15) =
+         ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+          $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+          $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]);
+       my $cmp = $i1 <=> $j1;
+       if (!defined($cmp) ? !($i2 < $j2)
+           : ($cmp == -1 && $i2 < $j2 ||
+              $cmp == 0  && !($i2 < $j2) ||
+              $cmp == 1  && !($i2 < $j2)))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n";
+       }
+       $ok++;
+       if (!defined($cmp) ? !($i4 == $j4)
+           : ($cmp == -1 && !($i4 == $j4) ||
+              $cmp == 0  && $i4 == $j4 ||
+              $cmp == 1  && !($i4 == $j4)))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, == disagrees\n";
+       }
+       $ok++;
+       if (!defined($cmp) ? !($i5 > $j5)
+           : ($cmp == -1 && !($i5 > $j5) ||
+              $cmp == 0  && !($i5 > $j5) ||
+              $cmp == 1  && ($i5 > $j5)))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, > disagrees\n";
+       }
+       $ok++;
+       if (!defined($cmp) ? !($i6 >= $j6)
+           : ($cmp == -1 && !($i6 >= $j6) ||
+              $cmp == 0  && $i6 >= $j6 ||
+              $cmp == 1  && $i6 >= $j6))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, >= disagrees\n";
+       }
+       $ok++;
+       # OK, so the docs are wrong it seems. NaN != NaN
+       if (!defined($cmp) ? ($i7 != $j7)
+           : ($cmp == -1 && $i7 != $j7 ||
+              $cmp == 0  && !($i7 != $j7) ||
+              $cmp == 1  && $i7 != $j7))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, != disagrees\n";
+       }
+       $ok++;
+       if (!defined($cmp) ? !($i8 <= $j8)
+           : ($cmp == -1 && $i8 <= $j8 ||
+              $cmp == 0  && $i8 <= $j8 ||
+              $cmp == 1  && !($i8 <= $j8)))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n";
+       }
+       $ok++;
+       $cmp = $i9 cmp $j9;
+       if ($cmp == -1 && $i10 lt $j10 ||
+           $cmp == 0  && !($i10 lt $j10) ||
+           $cmp == 1  && !($i10 lt $j10))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n";
+       }
+       $ok++;
+       if ($cmp == -1 && !($i11 eq $j11) ||
+           $cmp == 0  && ($i11 eq $j11) ||
+           $cmp == 1  && !($i11 eq $j11))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, eq disagrees\n";
+       }
+       $ok++;
+       if ($cmp == -1 && !($i12 gt $j12) ||
+           $cmp == 0  && !($i12 gt $j12) ||
+           $cmp == 1  && ($i12 gt $j12))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, gt disagrees\n";
+       }
+       $ok++;
+       if ($cmp == -1 && $i13 le $j13 ||
+           $cmp == 0  && ($i13 le $j13) ||
+           $cmp == 1  && !($i13 le $j13))
+       {
+           print "ok $ok\n";
+       }
+       else {
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, le disagrees\n";
+       }
+       $ok++;
+       if ($cmp == -1 && ($i14 ne $j14) ||
+           $cmp == 0  && !($i14 ne $j14) ||
+           $cmp == 1  && ($i14 ne $j14))
        {
            print "ok $ok\n";
        }
        else {
-           print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n";
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n";
        }
        $ok++;
-       $cmp = $FOO[$i] cmp $FOO[$j];
-       if ($cmp == -1 && $FOO[$i] lt $FOO[$j] ||
-           $cmp == 0  && $FOO[$i] eq $FOO[$j] ||
-           $cmp == 1  && $FOO[$i] gt $FOO[$j])
+       if ($cmp == -1 && !($i15 ge $j15) ||
+           $cmp == 0  && ($i15 ge $j15) ||
+           $cmp == 1  && ($i15 ge $j15))
        {
            print "ok $ok\n";
        }
        else {
-           print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n";
+           print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n";
        }
     }
 }
diff --git a/t/op/concat.t b/t/op/concat.t
new file mode 100644 (file)
index 0000000..76074e0
--- /dev/null
@@ -0,0 +1,100 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..11\n";
+
+($a, $b, $c) = qw(foo bar);
+
+print "not " unless "$a" eq "foo";
+print "ok 1\n";
+
+print "not " unless "$a$b" eq "foobar";
+print "ok 2\n";
+
+print "not " unless "$c$a$c" eq "foo";
+print "ok 3\n";
+
+# Okay, so that wasn't very challenging.  Let's go Unicode.
+
+my $test = 4;
+
+{
+    # bug id 20000819.004 
+
+    $_ = $dx = "\x{10f2}";
+    s/($dx)/$dx$1/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+
+    $_ = $dx = "\x{10f2}";
+    s/($dx)/$1$dx/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+
+    $dx = "\x{10f2}";
+    $_  = "\x{10f2}\x{10f2}";
+    s/($dx)($dx)/$1$2/;
+    {
+       use bytes;
+       print "not " unless $_ eq "$dx$dx";
+       print "ok $test\n";
+       $test++;
+    }
+}
+
+{
+    # bug id 20000901.092
+    # test that undef left and right of utf8 results in a valid string
+
+    my $a;
+    $a .= "\x{1ff}";
+    print "not " unless $a eq "\x{1ff}";
+    print "ok $test\n";
+    $test++;
+}
+
+{
+    # ID 20001020.006
+
+    "x" =~ /(.)/; # unset $2
+
+    # Without the fix this 5.7.0 would croak:
+    # Modification of a read-only value attempted at ...
+    "$2\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$2";
+
+    print "ok $test\n";
+    $test++;
+
+    *pi = \undef;
+    # This bug existed earlier than the $2 bug, but is fixed with the same
+    # patch. Without the fix this 5.7.0 would also croak:
+    # Modification of a read-only value attempted at ...
+    "$pi\x{1234}";
+
+    print "ok $test\n";
+    $test++;
+
+    # For symmetry with the above.
+    "\x{1234}$pi";
+
+    print "ok $test\n";
+    $test++;
+}
index 879c0d0..35792ab 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..19\n";
+print "1..24\n";
 
 $h{'abc'} = 'ABC';
 $h{'def'} = 'DEF';
@@ -131,3 +131,28 @@ if ($i == 5) { print "ok 16\n" } else { print "not ok\n" }
     print "ok 19\n";
 }
 
+# Check for Unicode hash keys.
+%u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}",  "foo");
+$u{"\x{12345}"}  = "bar";
+@u{"\x{123456}"} = "zap";
+
+foreach (keys %u) {
+    unless (length() == 1) {
+       print "not ";
+       last;
+    }
+}
+print "ok 20\n";
+
+$a = "\xe3\x81\x82"; $A = "\x{3042}";
+%b = ( $a => "non-utf8");
+%u = ( $A => "utf8");
+
+print "not " if exists $b{$A};
+print "ok 21\n";
+print "not " if exists $u{$a};
+print "ok 22\n";
+print "#$b{$_}\n" for keys %b; # Used to core dump before change #8056.
+print "ok 23\n";
+print "#$u{$_}\n" for keys %u; # Used to core dump before change #8056.
+print "ok 24\n";
index 93cf673..fbcd098 100755 (executable)
@@ -8,7 +8,9 @@ BEGIN {
     require Config; import Config;
     unless ($Config{'d_fork'}
            or ($^O eq 'MSWin32' and $Config{useithreads}
-               and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/))
+               and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ 
+#               and !defined $Config{'useperlio'}
+               ))
     {
        print "1..0 # Skip: no fork\n";
        exit 0;
@@ -184,6 +186,28 @@ child 3
 [1] -2- -3-
 -1- -2- -3-
 ########
+$| = 1;
+foreach my $c (1,2,3) {
+    if (fork) {
+       print "parent $c\n";
+    }
+    else {
+       print "child $c\n";
+       exit;
+    }
+}
+while (wait() != -1) { print "waited\n" }
+EXPECT
+child 1
+child 2
+child 3
+parent 1
+parent 2
+parent 3
+waited
+waited
+waited
+########
 use Config;
 $| = 1;
 $\ = "\n";
index cf2cafd..dc8e7d7 100755 (executable)
@@ -35,7 +35,7 @@ $VALID = 'LOCK_SH';
 ### First, we check whether Fcntl::constant returns sane answers.
 # Fcntl::constant("LOCK_SH",0) should always succeed.
 
-$value = Fcntl::constant($VALID,0);
+$value = Fcntl::constant($VALID);
 print((!defined $value)
       ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
       : "ok 1\n");
@@ -45,20 +45,20 @@ print((!defined $value)
 # test "goto &function_constant"
 sub goto_const { goto &Fcntl::constant; }
 
-$ret = goto_const($VALID,0);
+$ret = goto_const($VALID);
 print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
 
 # test "goto &$function_package_and_name"
 $FNAME1 = 'Fcntl::constant';
 sub goto_name1 { goto &$FNAME1; }
 
-$ret = goto_name1($VALID,0);
+$ret = goto_name1($VALID);
 print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
 
 # test "goto &$function_package_and_name" again, with dirtier stack
-$ret = goto_name1($VALID,0);
+$ret = goto_name1($VALID);
 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
-$ret = goto_name1($VALID,0);
+$ret = goto_name1($VALID);
 print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
 
 # test "goto &$function_name" from local package
@@ -67,14 +67,14 @@ $FNAME2 = 'constant';
 sub goto_name2 { goto &$FNAME2; }
 package main;
 
-$ret = Fcntl::goto_name2($VALID,0);
+$ret = Fcntl::goto_name2($VALID);
 print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
 
 # test "goto &$function_ref"
 $FREF = \&Fcntl::constant;
 sub goto_ref { goto &$FREF; }
 
-$ret = goto_ref($VALID,0);
+$ret = goto_ref($VALID);
 print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
 
 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
@@ -82,17 +82,17 @@ print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
 # test "goto &function_constant" from a sub called without arglist
 sub call_goto_const { &goto_const; }
 
-$ret = call_goto_const($VALID,0);
+$ret = call_goto_const($VALID);
 print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
 
 # test "goto &$function_package_and_name" from a sub called without arglist
 sub call_goto_name1 { &goto_name1; }
 
-$ret = call_goto_name1($VALID,0);
+$ret = call_goto_name1($VALID);
 print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
 
 # test "goto &$function_ref" from a sub called without arglist
 sub call_goto_ref { &goto_ref; }
 
-$ret = call_goto_ref($VALID,0);
+$ret = call_goto_ref($VALID);
 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
index b50878e..0f849fd 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..10\n";
+print "1..14\n";
 
 @x = (1, 2, 3);
 if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
@@ -44,3 +44,24 @@ if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";}
   print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c';
   print "ok 10\n";
 };
+
+{ my $s = join("", chr(0x1234), chr(0xff));
+  print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
+  print "ok 11\n";
+}
+
+{ my $s = join(chr(0xff), chr(0x1234), "");
+  print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
+  print "ok 12\n";
+}
+
+{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345));
+  print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}";
+  print "ok 13\n";
+}
+
+{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe));
+  print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}";
+  print "ok 14\n";
+}
+
diff --git a/t/op/length.t b/t/op/length.t
new file mode 100644 (file)
index 0000000..ceb005e
--- /dev/null
@@ -0,0 +1,85 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..13\n";
+
+print "not " unless length("")    == 0;
+print "ok 1\n";
+
+print "not " unless length("abc") == 3;
+print "ok 2\n";
+
+$_ = "foobar";
+print "not " unless length()      == 6;
+print "ok 3\n";
+
+# Okay, so that wasn't very challenging.  Let's go Unicode.
+
+{
+    my $a = "\x{41}";
+
+    print "not " unless length($a) == 1;
+    print "ok 4\n";
+    $test++;
+
+    use bytes;
+    print "not " unless $a eq "\x41" && length($a) == 1;
+    print "ok 5\n";
+    $test++;
+}
+
+{
+    my $a = "\x{80}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 6\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc2\x80" && length($a) == 2;
+    print "ok 7\n";
+    $test++;
+}
+
+{
+    my $a = "\x{100}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 8\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+    print "ok 9\n";
+    $test++;
+}
+
+{
+    my $a = "\x{100}\x{80}";
+    
+    print "not " unless length($a) == 2;
+    print "ok 10\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+    print "ok 11\n";
+    $test++;
+}
+
+{
+    my $a = "\x{80}\x{100}";
+    
+    print "not " unless length($a) == 2;
+    print "ok 12\n";
+    $test++;
+    
+    use bytes;
+    print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+    print "ok 13\n";
+    $test++;
+}
index feee8cc..0a1c399 100644 (file)
@@ -13,6 +13,11 @@ BEGIN {
        }
 }
 
+use strict;
+
+our @s;
+our $fail;
+
 sub zap {
     close(BIG);
     unlink("big");
@@ -25,35 +30,42 @@ sub bye {
     exit(0);
 }
 
+my $explained;
+
 sub explain {
-    print <<EOM;
+    unless ($explained++) {
+       print <<EOM;
 #
-# If the lfs (large file support: large meaning larger than two gigabytes)
-# tests are skipped or fail, it may mean either that your process
-# (or process group) is not allowed to write large files (resource
-# limits) or that the file system you are running the tests on doesn't
-# let your user/group have large files (quota) or the filesystem simply
-# doesn't support large files.  You may even need to reconfigure your kernel.
-# (This is all very operating system and site-dependent.)
+# If the lfs (large file support: large meaning larger than two
+# gigabytes) tests are skipped or fail, it may mean either that your
+# process (or process group) is not allowed to write large files
+# (resource limits) or that the file system (the network filesystem?)
+# you are running the tests on doesn't let your user/group have large
+# files (quota) or the filesystem simply doesn't support large files.
+# You may even need to reconfigure your kernel.  (This is all very
+# operating system and site-dependent.)
 #
 # Perl may still be able to support large files, once you have
 # such a process, enough quota, and such a (file) system.
+# It is just that the test failed now.
 #
 EOM
+    }
+    print "1..0 # Skip: @_\n" if @_;
 }
 
 print "# checking whether we have sparse files...\n";
 
 # Known have-nots.
-if ($^O eq 'win32' || $^O eq 'vms') {
-    print "1..0 # Skip: no sparse files (because this is $^O) \n";
+if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+    print "1..0 # Skip: no sparse files in $^O\n";
     bye();
 }
 
 # Known haves that have problems running this test
 # (for example because they do not support sparse files, like UNICOS)
 if ($^O eq 'unicos') {
-    print "1..0 # Skip: large files known to work but unable to test them here ($^O)\n";
+    print "1..0 # Skip: no sparse files in $^0, unable to test large files\n";
     bye();
 }
 
@@ -125,8 +137,7 @@ open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
 binmode BIG;
 if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) {
     my $err = $r ? 'signal '.($r & 0x7f) : $!;
-    print "1..0 # Skip: seeking past 2GB failed: $err\n";
-    explain();
+    explain("seeking past 2GB failed: $err");
     bye();
 }
 
@@ -138,11 +149,12 @@ my $close = close BIG;
 print "# close failed: $!\n" unless $close;
 unless ($print && $close) {
     if ($! =~/too large/i) {
-       print "1..0 # Skip: writing past 2GB failed: process limits?\n";
+       explain("writing past 2GB failed: process limits?");
     } elsif ($! =~ /quota/i) {
-       print "1..0 # Skip: filesystem quota limits?\n";
+       explain("filesystem quota limits?");
+    } else {
+       explain("error: $!");
     }
-    explain();
     bye();
 }
 
@@ -151,8 +163,7 @@ unless ($print && $close) {
 print "# @s\n";
 
 unless ($s[7] == 5_000_000_003) {
-    print "1..0 # Skip: not configured to use large files?\n";
-    explain();
+    explain("kernel/fs not configured to use large files?");
     bye();
 }
 
@@ -161,9 +172,30 @@ sub fail () {
     $fail++;
 }
 
+sub offset ($$) {
+    my ($offset_will_be, $offset_want) = @_;
+    my $offset_is = eval $offset_will_be;
+    unless ($offset_is == $offset_want) {
+        print "# bad offset $offset_is, want $offset_want\n";
+       my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
+       if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+           print "# 32-bit wraparound suspected in $offset_func() since\n";
+           print "# $offset_want cast into 32 bits equals $offset_is.\n";
+       } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
+                == $offset_is) {
+           print "# 32-bit wraparound suspected in $offset_func() since\n";
+           printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
+               $offset_want,
+               $offset_want,
+               $offset_is;
+        }
+        fail;
+    }
+}
+
 print "1..17\n";
 
-my $fail = 0;
+$fail = 0;
 
 fail unless $s[7] == 5_000_000_003;    # exercizes pp_stat
 print "ok 1\n";
@@ -183,25 +215,28 @@ binmode BIG;
 fail unless seek(BIG, 4_500_000_000, $SEEK_SET);
 print "ok 5\n";
 
-fail unless tell(BIG) == 4_500_000_000;
+offset('tell(BIG)', 4_500_000_000);
 print "ok 6\n";
 
 fail unless seek(BIG, 1, $SEEK_CUR);
 print "ok 7\n";
 
-fail unless tell(BIG) == 4_500_000_001;
+# If you get 205_032_705 from here it means that
+# your tell() is returning 32-bit values since (I32)4_500_000_001
+# is exactly 205_032_705.
+offset('tell(BIG)', 4_500_000_001);
 print "ok 8\n";
 
 fail unless seek(BIG, -1, $SEEK_CUR);
 print "ok 9\n";
 
-fail unless tell(BIG) == 4_500_000_000;
+offset('tell(BIG)', 4_500_000_000);
 print "ok 10\n";
 
 fail unless seek(BIG, -3, $SEEK_END);
 print "ok 11\n";
 
-fail unless tell(BIG) == 5_000_000_000;
+offset('tell(BIG)', 5_000_000_000);
 print "ok 12\n";
 
 my $big;
@@ -213,6 +248,8 @@ fail unless $big eq "big";
 print "ok 14\n";
 
 # 705_032_704 = (I32)5_000_000_000
+# See that we don't have "big" in the 705_... spot:
+# that would mean that we have a wraparound.
 fail unless seek(BIG, 705_032_704, $SEEK_SET);
 print "ok 15\n";
 
@@ -224,7 +261,7 @@ print "ok 16\n";
 fail unless $zero eq "\0\0\0";
 print "ok 17\n";
 
-explain if $fail;
+explain() if $fail;
 
 bye(); # does the necessary cleanup
 
index b478e01..781afa5 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..69\n";
+print "1..71\n";
 
 # XXX known to leak scalars
 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
@@ -235,3 +235,14 @@ while (/(o.+?),/gc) {
     untie $_;
 }
 
+{
+    # BUG 20001205.22
+    my %x;
+    $x{a} = 1;
+    { local $x{b} = 1; }
+    print "not " if exists $x{b};
+    print "ok 70\n";
+    { local @x{c,d,e}; }
+    print "not " if exists $x{c};
+    print "ok 71\n"; 
+}
index be4df75..1f5cbb6 100755 (executable)
@@ -9,7 +9,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..53\n";
+print "1..54\n";
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -185,3 +185,8 @@ test(do { eval 'E->foo()';
 test(do { eval '$e = bless {}, "E"; $e->foo()';
          $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
 
+# This is actually testing parsing of indirect objects and undefined subs
+#   print foo("bar") where foo does not exist is not an indirect object.
+#   print foo "bar"  where foo does not exist is an indirect object.
+eval { sub AUTOLOAD { "ok ", shift, "\n"; } };
+print nonsuch(++$cnt);
index f442494..805a32b 100755 (executable)
@@ -562,3 +562,58 @@ Modification of a read-only value attempted at - line 2.
 print qw(ab a\b a\\b);
 EXPECT
 aba\ba\b
+########
+# This test is here instead of pragma/locale.t because
+# the bug depends on in the internal state of the locale
+# settings and pragma/locale messes up that state pretty badly.
+# We need a "fresh run".
+use Config;
+my $have_setlocale = $Config{d_setlocale} eq 'define';
+eval {
+    require POSIX;
+};
+$have_setlocale = 0 if $@;
+# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+# and mingw32 uses said silly CRT
+$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
+exit(0) unless $have_setlocale;
+my @locales;
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) {
+    while(<LOCALES>) {
+        chomp;
+        push(@locales, $_);
+    }
+    close(LOCALES);
+}
+exit(0) unless @locales;
+for (@locales) {
+    use POSIX qw(locale_h);
+    use locale;
+    setlocale(LC_NUMERIC, $_) or next;
+    my $s = sprintf "%g %g", 3.1, 3.1;
+    next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/;
+    print "$_ $s\n";
+}
+EXPECT
+########
+die qr(x)
+EXPECT
+(?-xism:x) at - line 1.
+########
+# 20001210.003 mjd@plover.com
+format REMITOUT_TOP =
+FOO
+.
+
+format REMITOUT =
+BAR
+.
+
+# This loop causes a segv in 5.6.0
+for $lineno (1..61) {
+   write REMITOUT;
+}
+
+print "It's OK!";
+EXPECT
+It's OK!
index f3c9867..3db280b 100755 (executable)
@@ -85,8 +85,15 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1,
 unshift @list, (reverse map -$_, @list), 0; # 15 elts
 @list = map "$_", @list; # Normalize
 
-# print "@list\n";
+print "# @list\n";
 
+# need to special case ++ for max_uv, as ++ "magic" on a string gives
+# another string, whereas ++ magic on a string used as a number gives
+# a number. Not a problem when NV preserves UV, but if it doesn't then
+# stringification of the latter gives something in e notation.
+
+my $max_uv_pp = "$max_uv"; $max_uv_pp++;
+my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++;
 
 my @opnames = split //, "-+UINPuinp";
 
@@ -178,9 +185,18 @@ for my $num_chain (1..$max_chain) {
            }
            push @ans, $inpt;
          }
-         $nok++,
-           print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"
-             if $ans[0] ne $ans[1];
+         if ($ans[0] ne $ans[1]) {
+           print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n";
+           # XXX ought to check that "+" was in the list of opnames
+           if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1))
+               or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) {
+             # string ++ versus numeric ++. Tolerate this little
+             # bit of insanity
+             print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
+           } else {
+             $nok++,
+           }
+         }
        }
        print "not " if $nok;
        print "ok $test\n";
index 22ff3af..f664078 100755 (executable)
@@ -1,11 +1,11 @@
 #!./perl
 
-print "1..5\n";
+print "1..8\n";
 
 # compile time evaluation
 
-# 65   ASCII
-# 193  EBCDIC
+# 'A' 65       ASCII
+# 'A' 193      EBCDIC
 if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";}
 
 print "not " unless ord(chr(500)) == 500;
@@ -18,6 +18,17 @@ if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n";
 
 if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";}
 
+print "not " unless ord(chr(500)) == 500;
+print "ok 5\n";
+
 $x = 500;
 print "not " unless ord(chr($x)) == $x;
-print "ok 5\n";
+print "ok 6\n";
+
+print "not " unless ord("\x{1234}") == 0x1234;
+print "ok 7\n";
+
+$x = "\x{1234}";
+print "not " unless ord($x) == 0x1234;
+print "ok 8\n";
+
index f009086..17df867 100755 (executable)
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..223\n";
+print "1..231\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -496,7 +496,7 @@ $test++;
 $_ = 'xabcx';
 foreach $ans ('', 'c') {
   /(?<=(?=a)..)((?=c)|.)/g;
-  print "not " unless $1 eq $ans;
+  print "# \$1  ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans;
   print "ok $test\n";
   $test++;
 }
@@ -504,7 +504,7 @@ foreach $ans ('', 'c') {
 $_ = 'a';
 foreach $ans ('', 'a', '') {
   /^|a|$/g;
-  print "not " unless $& eq $ans;
+  print "# \$&  ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans;
   print "ok $test\n";
   $test++;
 }
@@ -545,6 +545,22 @@ $test++;
   print "ok $test\n";
   $test++;
 
+  local $lex_a = 2;
+  my $lex_a = 43;
+  my $lex_b = 17;
+  my $lex_c = 27;
+  my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
+  print "not " unless $lex_res eq '1';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_a eq '44';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_c eq '43';
+  print "ok $test\n";
+  $test++;
+
+
   no re "eval"; 
   $match = eval { /$a$c$a/ };
   print "not " 
@@ -554,6 +570,23 @@ $test++;
 }
 
 {
+  local $lex_a = 2;
+  my $lex_a = 43;
+  my $lex_b = 17;
+  my $lex_c = 27;
+  my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
+  print "not " unless $lex_res eq '1';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_a eq '44';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_c eq '43';
+  print "ok $test\n";
+  $test++;
+}
+
+{
   package aa;
   $c = 2;
   $::c = 3;
@@ -1064,7 +1097,8 @@ my %space = ( spc   => " ",
              cr    => "\r",
              lf    => "\n",
              ff    => "\f",
-# The vertical tabulator seems miraculously be 12 both in ASCII and EBCDIC.
+# There's no \v but the vertical tabulator seems miraculously
+# be 11 both in ASCII and EBCDIC.
              vt    => chr(11),
              false => "space" );
 
@@ -1073,14 +1107,25 @@ my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space;
 my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space;
 
 print "not " unless "@space0" eq "cr ff lf spc tab";
-print "ok $test\n";
+print "ok $test # @space0\n";
 $test++;
 
 print "not " unless "@space1" eq "cr ff lf spc tab vt";
-print "ok $test\n";
+print "ok $test # @space1\n";
 $test++;
 
 print "not " unless "@space2" eq "spc tab";
-print "ok $test\n";
+print "ok $test # @space2\n";
 $test++;
  
+# bugid 20001021.005 - this caused a SEGV
+print "not " unless undef =~ /^([^\/]*)(.*)$/;
+print "ok $test\n";
+$test++;
+
+# bugid 20000731.001
+
+print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/;
+print "ok $test\n";
+$test++;
+
index 46811b7..f3bc23c 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..3\n";
+print "1..4\n";
 
 $x='banana';
 $x=~/.a/g;
@@ -14,3 +14,10 @@ sub f { my $p=$_[0]; return $p }
 $x=~/.a/g;
 if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";}
 
+# Is pos() set inside //g? (bug id 19990615.008)
+$x = "test string?"; $x =~ s/\w/pos($x)/eg;
+print "not " unless $x eq "0123 5678910?";
+print "ok 4\n";
+
+
+
index c2753e5..52666da 100644 (file)
@@ -46,8 +46,8 @@ a[b-d]        aac     y       $&      ac
 a[-b]  a-      y       $&      a-
 a[b-]  a-      y       $&      a-
 a[b-a] -       c       -       Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
-a[]b   -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ at (eval 96) line 1, <TESTS> line 49.
-a[     -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 97) line 1, <TESTS> line 50.
+a[]b   -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
+a[     -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE /
 a]     a]      y       $&      a]
 a[]]b  a]b     y       $&      a]b
 a[^bc]d        aed     y       $&      aed
@@ -95,21 +95,21 @@ a[\S]b      a-b     y       -       -
 ab|cd  abc     y       $&      ab
 ab|cd  abcd    y       $&      ab
 ()ef   def     y       $&-$1   ef-
-*a     -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 192) line 1, <TESTS> line 98.
-(*)b   -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 193) line 1, <TESTS> line 99.
+*a     -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/
+(*)b   -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
 $b     b       n       -       -
 a\     -       c       -       Search pattern not terminated
 a\(b   a(b     y       $&-$1   a(b-
 a\(*b  ab      y       $&      ab
 a\(*b  a((b    y       $&      a((b
 a\\b   a\b     y       $&      a\b
-abc)   -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 205) line 1, <TESTS> line 106.
-(abc   -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 206) line 1, <TESTS> line 107.
+abc)   -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE /
+(abc   -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/
 ((a))  abc     y       $&-$1-$2        a-a-a
 (a)b(c)        abc     y       $&-$1-$2        abc-a-c
 a+b+c  aabbabc y       $&      abc
 a{1,}b{1,}c    aabbabc y       $&      abc
-a**    -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 215) line 1, <TESTS> line 112.
+a**    -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE /
 a.+?c  abcabc  y       $&      abc
 (a+|b)*        ab      y       $&-$1   ab-b
 (a+|b){0,}     ab      y       $&-$1   ab-b
@@ -117,7 +117,7 @@ a.+?c       abcabc  y       $&      abc
 (a+|b){1,}     ab      y       $&-$1   ab-b
 (a+|b)?        ab      y       $&-$1   a-a
 (a+|b){0,1}    ab      y       $&-$1   a-a
-)(     -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/ at (eval 230) line 1, <TESTS> line 120.
+)(     -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/
 [^ab]* cde     y       $&      cde
 abc            n       -       -
 a*             y       $&      
@@ -219,8 +219,8 @@ a[-]?c      ac      y       $&      ac
 'a[-b]'i       A-      y       $&      A-
 'a[b-]'i       A-      y       $&      A-
 'a[b-a]'i      -       c       -       Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/
-'a[]b'i        -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ at (eval 431) line 1, <TESTS> line 222.
-'a['i  -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE / at (eval 432) line 1, <TESTS> line 223.
+'a[]b'i        -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE ]b/
+'a['i  -       c       -       Unmatched [ before HERE mark in regex m/a[ << HERE /
 'a]'i  A]      y       $&      A]
 'a[]]b'i       A]B     y       $&      A]B
 'a[^bc]d'i     AED     y       $&      AED
@@ -232,21 +232,21 @@ a[-]?c    ac      y       $&      ac
 'ab|cd'i       ABC     y       $&      AB
 'ab|cd'i       ABCD    y       $&      AB
 '()ef'i        DEF     y       $&-$1   EF-
-'*a'i  -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/ at (eval 455) line 1, <TESTS> line 235.
-'(*)b'i        -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ at (eval 456) line 1, <TESTS> line 236.
+'*a'i  -       c       -       Quantifier follows nothing before HERE mark in regex m/* << HERE a/
+'(*)b'i        -       c       -       Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/
 '$b'i  B       n       -       -
 'a\'i  -       c       -       Search pattern not terminated
 'a\(b'i        A(B     y       $&-$1   A(B-
 'a\(*b'i       AB      y       $&      AB
 'a\(*b'i       A((B    y       $&      A((B
 'a\\b'i        A\B     y       $&      A\B
-'abc)'i        -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE / at (eval 468) line 1, <TESTS> line 243.
-'(abc'i        -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/ at (eval 469) line 1, <TESTS> line 244.
+'abc)'i        -       c       -       Unmatched ) before HERE mark in regex m/abc) << HERE /
+'(abc'i        -       c       -       Unmatched ( before HERE mark in regex m/( << HERE abc/
 '((a))'i       ABC     y       $&-$1-$2        A-A-A
 '(a)b(c)'i     ABC     y       $&-$1-$2        ABC-A-C
 'a+b+c'i       AABBABC y       $&      ABC
 'a{1,}b{1,}c'i AABBABC y       $&      ABC
-'a**'i -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE / at (eval 478) line 1, <TESTS> line 249.
+'a**'i -       c       -       Nested quantifiers before HERE mark in regex m/a** << HERE /
 'a.+?c'i       ABCABC  y       $&      ABC
 'a.*?c'i       ABCABC  y       $&      ABC
 'a.{0,5}?c'i   ABCABC  y       $&      ABC
@@ -257,7 +257,7 @@ a[-]?c      ac      y       $&      ac
 '(a+|b)?'i     AB      y       $&-$1   A-A
 '(a+|b){0,1}'i AB      y       $&-$1   A-A
 '(a+|b){0,1}?'i        AB      y       $&-$1   -
-')('i  -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/ at (eval 499) line 1, <TESTS> line 260.
+')('i  -       c       -       Unmatched ) before HERE mark in regex m/) << HERE (/
 '[^ab]*'i      CDE     y       $&      CDE
 'abc'i         n       -       -
 'a*'i          y       $&      
@@ -397,10 +397,10 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace     y       $1$2    ce
 '(ab)\d\1'i    ab4Ab   y       $1      ab
 foo\w*\d{4}baz foobar1234baz   y       $&      foobar1234baz
 a(?{})b        cabd    y       $&      ab
-a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ at (eval 780) line 1, <TESTS> line 400.
-a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ at (eval 781) line 1, <TESTS> line 401.
+a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/
+a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/
 a(?{}})b       -       c       -       
-a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ at (eval 783) line 1, <TESTS> line 403.
+a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/
 a(?{"\{"})b    cabd    y       $&      ab
 a(?{"{"}})b    -       c       -       Unmatched right curly bracket
 a(?{$bl="\{"}).b       caxbd   y       $bl     {
@@ -441,7 +441,7 @@ x(~~)*(?:(?:F)?)?   x~~     y       -       -
 ^(\(+)?blah(?(1)(\)))$ blah    y       ($2)    ()
 ^(\(+)?blah(?(1)(\)))$ blah)   n       -       -
 ^(\(+)?blah(?(1)(\)))$ (blah   n       -       -
-(?(1?)a|b)     a       c       -       Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ at (eval 868) line 1, <TESTS> line 444.
+(?(1?)a|b)     a       c       -       Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/
 (?(1)a|b|c)    a       c       -       Switch (?(condition)... contains too many branches
 (?(?{0})a|b)   a       n       -       -
 (?(?{0})b|a)   a       y       $&      a
@@ -473,7 +473,7 @@ $(?<=^(a))  a       y       $1      a
 ([[:]+)        a:[b]:  y       $1      :[
 ([[=]+)        a=[b]=  y       $1      =[
 ([[.]+)        a.[b].  y       $1      .[
-[a[:xyz:       -       c       -       Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ at (eval 950) line 1, <TESTS> line 476.
+[a[:xyz:       -       c       -       Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/
 [a[:xyz:]      -       c       -       POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE /
 [a[:]b[:c]     abc     y       $&      abc
 ([a[:xyz:]b]+) pbaq    c       -       POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/
@@ -775,3 +775,9 @@ tt+$        xxxtt   y       -       -
 '^.{9}abc.*\n'm        123\nabcabcabcabc\n     y       -       -
 ^(a)?a$        a       y       -$1-    --
 ^(a)?(?(1)a|b)+$       a       n       -       -
+^(a\1?)(a\1?)(a\2?)(a\3?)$     aaaaaa  y       $1,$2,$3,$4     a,aa,a,aa
+^(a\1?){4}$    aaaaaa  y       $1      aa
+^(0+)?(?:x(1))?        x1      y       -       -
+^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))?        012cxx0190      y       -       -
+^(b+?|a){1,2}c bbbac   y       $1      a
+^(b+?|a){1,2}c bbbbac  y       $1      a
index a2baab8..8ae9042 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..56\n";
+print "1..61\n";
 
 # Test glob operations.
 
@@ -279,14 +279,34 @@ print $$_,"\n";
     print ${\$_} for @a;
 }
 
+# This test is the reason for postponed destruction in sv_unref
+$a = [1,2,3];
+$a = $a->[1];
+print "not " unless $a == 2;
+print "ok 54\n";
+
+sub x::DESTROY {print "ok ", 54 + shift->[0], "\n"}
+{ my $a1 = bless [4],"x";
+  my $a2 = bless [3],"x";
+  { my $a3 = bless [2],"x";
+    my $a4 = bless [1],"x";
+    567;
+  }
+}
+
+
 # test global destruction
 
+my $test = 59;
+my $test1 = $test + 1;
+my $test2 = $test + 2;
+
 package FINALE;
 
 {
-    $ref3 = bless ["ok 56\n"];         # package destruction
-    my $ref2 = bless ["ok 55\n"];      # lexical destruction
-    local $ref1 = bless ["ok 54\n"];   # dynamic destruction
+    $ref3 = bless ["ok $test2\n"];     # package destruction
+    my $ref2 = bless ["ok $test1\n"];  # lexical destruction
+    local $ref1 = bless ["ok $test\n"];        # dynamic destruction
     1;                                 # flush any temp values on stack
 }
 
index 23ae576..7fbfc97 100755 (executable)
@@ -26,6 +26,9 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 # Column 5 contains the expected result of double-quote
 # interpolating that string after the match, or start of error message.
 #
+# Column 6, if present, contains a reason why the test is skipped.
+# This is printed with "skipped", for harness to pick up.
+#
 # \n in the tests are interpolated, as are variables of the form ${\w+}.
 #
 # If you want to add a regular expression test that can't be expressed
@@ -56,7 +59,7 @@ TEST:
 while (<TESTS>) {
     chomp;
     s/\\n/\n/g;
-    ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_);
+    ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
     $input = join(':',$pat,$subject,$result,$repl,$expect);
     infty_subst(\$pat);
     infty_subst(\$expect);
@@ -70,7 +73,8 @@ while (<TESTS>) {
     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
     $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
     # Certain tests don't work with utf8 (the re_test should be in UTF8)
-    $skip = 1 if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word):\]/;
+    $skip = 1, $reason = 'utf8'
+      if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/;
     $result =~ s/B//i unless $skip;
     for $study ('', 'study \$subject') {
        $c = $iters;
@@ -81,7 +85,8 @@ while (<TESTS>) {
            last;  # no need to study a syntax error
        }
        elsif ( $skip ) {
-           print "ok $. # skipped\n"; next TEST;
+           print "ok $. # skipped", length($reason) ? " $reason" : '', "\n";
+           next TEST;
        }
        elsif ($@) {
            print "not ok $. $input => error `$err'\n"; next TEST;
index f209239..50a020b 100644 (file)
@@ -65,14 +65,12 @@ my @death =
 
  '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/',
 
- 'my $m = chr(92); $m =~ $m', => 'Trailing \ in regex m/\/',
+ 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
 
  '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/',
 
  'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/',
 
- '/\x{x}/' => 'Can\'t use \x{} without \'use utf8\' declaration before {#} mark in regex m/\x{x}{#}/',
-
  '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/',
 
  '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/',
@@ -101,15 +99,24 @@ my @death =
 
 my $total = (@death + @warning)/2;
 
+# utf8 is a noop on EBCDIC platforms, it is not fatal
+my $Is_EBCDIC = (ord('A') == 193);
+if ($Is_EBCDIC) {
+    my @utf8_death = grep(/utf8/, @death); 
+    $total = $total - $#utf8_death;
+}
+
 print "1..$total\n";
 
 my $count = 0;
 
 while (@death)
 {
-    $count++;
     my $regex = shift @death;
     my $result = shift @death;
+    # skip the utf8 test on EBCDIC since they do not die
+    next if ($Is_EBCDIC && $regex =~ /utf8/);
+    $count++;
 
     $_ = "x";
     eval $regex;
diff --git a/t/op/reverse.t b/t/op/reverse.t
new file mode 100644 (file)
index 0000000..bb7b9b7
--- /dev/null
@@ -0,0 +1,33 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..4\n";
+
+print "not " unless reverse("abc")    eq "cba";
+print "ok 1\n";
+
+$_ = "foobar";
+print "not " unless reverse()         eq "raboof";
+print "ok 2\n";
+
+{
+    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";
+}
+
+{
+    # Unicode.
+
+    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";
+}
index 9095871..c1dfb63 100755 (executable)
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 use warnings;
-print "1..57\n";
+print "1..58\n";
 
 # XXX known to leak scalars
 {
@@ -321,3 +321,10 @@ sub cxt_six { sort test_if_scalar 1,2 }
     print "# x = '@b'\n";
     print !$def ? "ok 57\n" : "not ok 57\n";
 }
+
+# Bug 19991001.003
+{
+    sub routine { "one", "two" };
+    @a = sort(routine(1));
+    print "@a" eq "one two" ? "ok 58\n" : "not ok 58\n";
+}
index 45df76a..90c38e0 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..28\n";
+print "1..30\n";
 
 $FS = ':';
 
@@ -122,3 +122,13 @@ print "ok 27\n";
 print "not " if @list1 != @list2 or "@list1" ne "@list2"
              or @list1 != 2 or "@list1" ne "a   b c ";
 print "ok 28\n";
+
+# zero-width assertion
+$_ = join ':', split /(?=\w)/, "rm b";
+print "not" if $_ ne "r:m :b";
+print "ok 29\n";
+
+# unicode splittage
+@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1;
+print "not " unless "@ary" eq "1 20 300 4000 50000 4000 300 20 1";
+print "ok 30\n";
index 2f6cd27..4e80999 100755 (executable)
@@ -229,8 +229,8 @@ __END__
 >%.0f<      >0<           >0<
 >%.0f<      >2**38<       >274877906944<   >Should have exact int'l rep'n<
 >%.0f<      >0.1<         >0<
->%.0f<      >0.6<         >1<              >Known to fail with sfio<
->%.0f<      >-0.6<        >-1<             >Known to fail with sfio<
+>%.0f<      >0.6<         >1<              >Known to fail with sfio and nonstop-ux<
+>%.0f<      >-0.6<        >-1<             >Known to fail with sfio and nonstop-ux<
 >%.0f<      >1<           >1<
 >%#.0f<     >1<           >1.<
 >%g<        >12345.6789<  >12345.7<
@@ -308,3 +308,16 @@ __END__
 >%0*x<      >[-10, ,2**32-1]< >ffffffff  <
 >%y<        >''<          >%y INVALID<
 >%z<        >''<          >%z INVALID<
+>%2$d %1$d<    >[12, 34]<      >34 12<
+>%*2$d<                >[12, 3]<       > 12<
+>%2$d %d<      >[12, 34]<      >34 12<
+>%2$d %d %d<   >[12, 34]<      >34 12 34<
+>%3$d %d %d<   >[12, 34, 56]<  >56 12 34<
+>%2$*3$d %d<   >[12, 34, 3]<   > 34 12<
+>%*3$2$d %d<   >[12, 34, 3]<   > 34 12<
+>%2$d<         >12<    >0<
+>%0$d<         >12<    >%0$d INVALID<
+>%1$$d<                >12<    >%1$$d INVALID<
+>%1$1$d<       >12<    >%1$1$d INVALID<
+>%*2$*2$d<     >[12, 3]<       >%*2$*2$d INVALID<
+>%*2*2$d<      >[12, 3]<       >%*2*2$d INVALID<
index 7cc4447..1e3d396 100755 (executable)
@@ -99,7 +99,7 @@ print PROG 'print "@ARGV\n"', "\n";
 close PROG;
 my $echo = "$Invoke_Perl $ECHO";
 
-print "1..151\n";
+print "1..155\n";
 
 # First, let's make sure that Perl is checking the dangerous
 # environment variables. Maybe they aren't set yet, so we'll
@@ -681,3 +681,42 @@ else {
     }
 }
 
+{
+    # bug id 20001004.006
+
+    open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ;
+    local $/;
+    my $a = <IN>;
+    my $b = <IN>;
+    print "not " unless tainted($a) && tainted($b) && !defined($b);
+    print "ok 152\n";
+    close IN;
+}
+
+{
+    # bug id 20001004.007
+
+    open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ;
+    my $a = <IN>;
+
+    my $c = { a => 42,
+             b => $a };
+    print "not " unless !tainted($c->{a}) && tainted($c->{b});
+    print "ok 153\n";
+
+    my $d = { a => $a,
+             b => 42 };
+    print "not " unless tainted($d->{a}) && !tainted($d->{b});
+    print "ok 154\n";
+
+    my $e = { a => 42,
+             b => { c => $a, d => 42 } };
+    print "not " unless !tainted($e->{a}) &&
+                       !tainted($e->{b}) &&
+                        tainted($e->{b}->{c}) &&
+                       !tainted($e->{b}->{d});
+    print "ok 155\n";
+
+    close IN;
+}
+
index afcc4a1..4413ed2 100755 (executable)
@@ -162,19 +162,28 @@ $C = $B = tied %H ;
 untie %H;
 EXPECT
 ########
-
-# verify no leak when underlying object is selfsame tied variable
-my ($a, $b);
+# Forbidden aggregate self-ties
+my ($a, $b) = (0, 0);
 sub Self::TIEHASH { bless $_[1], $_[0] }
-sub Self::DESTROY { $b = $_[0] + 0; }
+sub Self::DESTROY { $b = $_[0] + 1; }
+{
+    my %c = 42;
+    tie %c, 'Self', \%c;
+}
+EXPECT
+Self-ties of arrays and hashes are not supported 
+########
+# Allowed scalar self-ties
+my ($a, $b) = (0, 0);
+sub Self::TIESCALAR { bless $_[1], $_[0] }
+sub Self::DESTROY   { $b = $_[0] + 1; }
 {
-    my %b5;
-    $a = \%b5 + 0;
-    tie %b5, 'Self', \%b5;
+    my $c = 42;
+    $a = $c + 0;
+    tie $c, 'Self', \$c;
 }
-die unless $a == $b;
+die unless $a == 0 && $b == 43;
 EXPECT
-Self-ties are not supported 
 ########
 # Interaction of tie and vec
 
diff --git a/t/op/utf8decode.t b/t/op/utf8decode.t
new file mode 100644 (file)
index 0000000..4d05a6b
--- /dev/null
@@ -0,0 +1,183 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+no utf8;
+
+print "1..78\n";
+
+my $test = 1;
+
+# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
+# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
+# version dated 2000-09-02. 
+
+# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff
+# because e.g. many patch programs have issues with binary data.
+
+my @MK = split(/\n/, <<__EOMK__);
+1      Correct UTF-8
+1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" -               11      ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5        5
+2      Boundary conditions 
+2.1    First possible sequence of certain length
+2.1.1 y "\x00"                 0               1       00      1
+2.1.2 y "\xc2\x80"                     80              2       c2:80   1
+2.1.3 y "\xe0\xa0\x80"         800             3       e0:a0:80        1
+2.1.4 y "\xf0\x90\x80\x80"             10000           4       f0:90:80:80     1
+2.1.5 y "\xf8\x88\x80\x80\x80" 200000          5       f8:88:80:80:80  1
+2.1.6 y "\xfc\x84\x80\x80\x80\x80"     4000000         6       fc:84:80:80:80:80       1
+2.2    Last possible sequence of certain length
+2.2.1 y "\x7f"                 7f              1       7f      1
+2.2.2 y "\xdf\xbf"                     7ff             2       df:bf   1
+# The ffff is illegal unless UTF8_ALLOW_FFFF
+2.2.3 n "\xef\xbf\xbf"                 ffff            3       ef:bf:bf        1       character 0xffff
+2.2.4 y "\xf7\xbf\xbf\xbf"                     1fffff          4       f7:bf:bf:bf     1
+2.2.5 y "\xfb\xbf\xbf\xbf\xbf"                 3ffffff         5       fb:bf:bf:bf:bf  1
+2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf"             7fffffff        6       fd:bf:bf:bf:bf:bf       1
+2.3    Other boundary conditions
+2.3.1 y "\xed\x9f\xbf"         d7ff            3       ed:9f:bf        1
+2.3.2 y "\xee\x80\x80"         e000            3       ee:80:80        1
+2.3.3 y "\xef\xbf\xbd"                 fffd            3       ef:bf:bd        1
+2.3.4 y "\xf4\x8f\xbf\xbf"             10ffff          4       f4:8f:bf:bf     1
+2.3.5 y "\xf4\x90\x80\x80"             110000          4       f4:90:80:80     1
+3      Malformed sequences
+3.1    Unexpected continuation bytes
+3.1.1 n "\x80"                 -               1       80      -       unexpected continuation byte 0x80
+3.1.2 n "\xbf"                 -               1       bf      -       unexpected continuation byte 0xbf
+3.1.3 n "\x80\xbf"                     -               2       80:bf   -       unexpected continuation byte 0x80
+3.1.4 n "\x80\xbf\x80"         -               3       80:bf:80        -       unexpected continuation byte 0x80
+3.1.5 n "\x80\xbf\x80\xbf"             -               4       80:bf:80:bf     -       unexpected continuation byte 0x80
+3.1.6 n "\x80\xbf\x80\xbf\x80" -               5       80:bf:80:bf:80  -       unexpected continuation byte 0x80
+3.1.7 n "\x80\xbf\x80\xbf\x80\xbf"     -               6       80:bf:80:bf:80:bf       -       unexpected continuation byte 0x80
+3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" -               7       80:bf:80:bf:80:bf:80    -       unexpected continuation byte 0x80
+3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf"                             -       64      80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf -       unexpected continuation byte 0x80
+3.2    Lonely start characters
+3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf "     -       64      c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 -       unexpected non-continuation byte 0x20 after start byte 0xc0
+3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef "     -       32      e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 -       unexpected non-continuation byte 0x20 after start byte 0xe0
+3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 "     -       16      f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 -       unexpected non-continuation byte 0x20 after start byte 0xf0
+3.2.4 n "\xf8 \xf9 \xfa \xfb "         -       8       f8:20:f9:20:fa:20:fb:20 -       unexpected non-continuation byte 0x20 after start byte 0xf8
+3.2.5 n "\xfc \xfd "                   -       4       fc:20:fd:20     -       unexpected non-continuation byte 0x20 after start byte 0xfc
+3.3    Sequences with last continuation byte missing
+3.3.1 n "\xc0"                 -       1       c0      -       1 byte, need 2
+3.3.2 n "\xe0\x80"                     -       2       e0:80   -       2 bytes, need 3
+3.3.3 n "\xf0\x80\x80"         -       3       f0:80:80        -       3 bytes, need 4
+3.3.4 n "\xf8\x80\x80\x80"             -       4       f8:80:80:80     -       4 bytes, need 5
+3.3.5 n "\xfc\x80\x80\x80\x80" -       5       fc:80:80:80:80  -       5 bytes, need 6
+3.3.6 n "\xdf"                 -       1       df      -       1 byte, need 2
+3.3.7 n "\xef\xbf"                     -       2       ef:bf   -       2 bytes, need 3
+3.3.8 n "\xf7\xbf\xbf"                 -       3       f7:bf:bf        -       3 bytes, need 4
+3.3.9 n "\xfb\xbf\xbf\xbf"                     -       4       fb:bf:bf:bf     -       4 bytes, need 5
+3.3.10 n "\xfd\xbf\xbf\xbf\xbf"                -       5       fd:bf:bf:bf:bf  -       5 bytes, need 6
+3.4    Concatenation of incomplete sequences
+3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf"     -       30      c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf       -       unexpected non-continuation byte 0xe0 after start byte 0xc0
+3.5    Impossible bytes
+3.5.1 n "\xfe"                 -       1       fe      -       byte 0xfe
+3.5.2 n "\xff"                 -       1       ff      -       byte 0xff
+3.5.3 n "\xfe\xfe\xff\xff"                     -       4       fe:fe:ff:ff     -       byte 0xfe
+4      Overlong sequences
+4.1    Examples of an overlong ASCII character
+4.1.1 n "\xc0\xaf"                     -       2       c0:af   -       2 bytes, need 1
+4.1.2 n "\xe0\x80\xaf"         -       3       e0:80:af        -       3 bytes, need 1
+4.1.3 n "\xf0\x80\x80\xaf"             -       4       f0:80:80:af     -       4 bytes, need 1
+4.1.4 n "\xf8\x80\x80\x80\xaf" -       5       f8:80:80:80:af  -       5 bytes, need 1
+4.1.5 n "\xfc\x80\x80\x80\x80\xaf"     -       6       fc:80:80:80:80:af       -       6 bytes, need 1
+4.2    Maximum overlong sequences
+4.2.1 n "\xc1\xbf"                     -       2       c1:bf   -       2 bytes, need 1
+4.2.2 n "\xe0\x9f\xbf"         -       3       e0:9f:bf        -       3 bytes, need 2
+4.2.3 n "\xf0\x8f\xbf\xbf"             -       4       f0:8f:bf:bf     -       4 bytes, need 3
+4.2.4 n "\xf8\x87\xbf\xbf\xbf"         -       5       f8:87:bf:bf:bf  -       5 bytes, need 4
+4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf"             -       6       fc:83:bf:bf:bf:bf       -       6 bytes, need 5
+4.3    Overlong representation of the NUL character
+4.3.1 n "\xc0\x80"                     -       2       c0:80   -       2 bytes, need 1
+4.3.2 n "\xe0\x80\x80"         -       3       e0:80:80        -       3 bytes, need 1
+4.3.3 n "\xf0\x80\x80\x80"             -       4       f0:80:80:80     -       4 bytes, need 1
+4.3.4 n "\xf8\x80\x80\x80\x80" -       5       f8:80:80:80:80  -       5 bytes, need 1
+4.3.5 n "\xfc\x80\x80\x80\x80\x80"     -       6       fc:80:80:80:80:80       -       6 bytes, need 1
+5      Illegal code positions
+5.1    Single UTF-16 surrogates
+5.1.1 n "\xed\xa0\x80"         -       3       ed:a0:80        -       UTF-16 surrogate 0xd800
+5.1.2 n "\xed\xad\xbf"                 -       3       ed:ad:bf        -       UTF-16 surrogate 0xdb7f
+5.1.3 n "\xed\xae\x80"         -       3       ed:ae:80        -       UTF-16 surrogate 0xdb80
+5.1.4 n "\xed\xaf\xbf"                 -       3       ed:af:bf        -       UTF-16 surrogate 0xdbff
+5.1.5 n "\xed\xb0\x80"         -       3       ed:b0:80        -       UTF-16 surrogate 0xdc00
+5.1.6 n "\xed\xbe\x80"         -       3       ed:be:80        -       UTF-16 surrogate 0xdf80
+5.1.7 n "\xed\xbf\xbf"                 -       3       ed:bf:bf        -       UTF-16 surrogate 0xdfff
+5.2    Paired UTF-16 surrogates
+5.2.1 n "\xed\xa0\x80\xed\xb0\x80"             -       6       ed:a0:80:ed:b0:80       -       UTF-16 surrogate 0xd800
+5.2.2 n "\xed\xa0\x80\xed\xbf\xbf"             -       6       ed:a0:80:ed:bf:bf       -       UTF-16 surrogate 0xd800
+5.2.3 n "\xed\xad\xbf\xed\xb0\x80"             -       6       ed:ad:bf:ed:b0:80       -       UTF-16 surrogate 0xdb7f
+5.2.4 n "\xed\xad\xbf\xed\xbf\xbf"             -       6       ed:ad:bf:ed:bf:bf       -       UTF-16 surrogate 0xdb7f
+5.2.5 n "\xed\xae\x80\xed\xb0\x80"             -       6       ed:ae:80:ed:b0:80       -       UTF-16 surrogate 0xdb80
+5.2.6 n "\xed\xae\x80\xed\xbf\xbf"             -       6       ed:ae:80:ed:bf:bf       -       UTF-16 surrogate 0xdb80
+5.2.7 n "\xed\xaf\xbf\xed\xb0\x80"             -       6       ed:af:bf:ed:b0:80       -       UTF-16 surrogate 0xdbff
+5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf"             -       6       ed:af:bf:ed:bf:bf       -       UTF-16 surrogate 0xdbff
+5.3    Other illegal code positions
+5.3.1 n "\xef\xbf\xbe"                 -       3       ef:bf:be        -       byte order mark 0xfffe
+# The ffff is illegal unless UTF8_ALLOW_FFFF
+5.3.2 n "\xef\xbf\xbf"                 -       3       ef:bf:bf        -       character 0xffff
+__EOMK__
+
+# 104..181
+{
+    my $WARNCNT;
+    my $id;
+
+    local $SIG{__WARN__} =
+       sub {
+           print "# $id: @_";
+           $WARNCNT++;
+           $WARNMSG = "@_";
+       };
+
+    sub moan {
+       print "$id: @_";
+    }
+    
+    sub test_unpack_U {
+       $WARNCNT = 0;
+       $WARNMSG = "";
+       unpack('U*', $_[0]);
+    }
+
+    for (@MK) {
+       if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) {
+           # print "# $_\n";
+       } elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) {
+           $id = $1;
+           my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $error) =
+               ($2, $3, $4, $5, $6, $7, $8);
+           my @hex = split(/:/, $hex);
+           unless (@hex == $byteslen) {
+               my $nhex = @hex;
+               moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n";
+           }
+           {
+               use bytes;
+               my $bytesbyteslen = length($bytes);
+               unless ($bytesbyteslen == $byteslen) {
+                   moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n";
+               }
+           }
+           if ($okay eq 'y') {
+               test_unpack_U($bytes);
+               if ($WARNCNT) {
+                   moan "unpack('U*') false negative\n";
+                   print "not ";
+               }
+           } elsif ($okay eq 'n') {
+               test_unpack_U($bytes);
+               if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) {
+                   moan "unpack('U*') false positive\n";
+                   print "not ";
+               }
+           }
+           print "ok $test\n";
+           $test++;
+       } else {
+           moan "unknown format\n";
+       }
+    }
+}
index 08beced..edfebd2 100755 (executable)
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..23\n";
+print "1..28\n";
 
 my $test = 1;
 
@@ -155,3 +155,27 @@ print "ok $test\n";  ++$test;
        eq '1##10110##11000101##10001101##11100001##10000101##10011100';
     print "ok $test\n";  ++$test;
 }
+
+{
+    # bug id 20000323.056
+
+    print "not " unless "\x{41}" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x41" eq +v65;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{c8}" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\xc8" eq +v200;
+    print "ok $test\n";
+    $test++;
+
+    print "not " unless "\x{221b}" eq v8731;
+    print "ok $test\n";
+    $test++;
+}
index 5b01eb7..fc155a8 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..9\n";
+print "1..11\n";
 
 my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
 
@@ -43,7 +43,7 @@ of huma...
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 1\n"; unlink 'Op_write.tmp'; }
+    { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 1\n"; }
 
@@ -85,7 +85,7 @@ necessary
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 2\n"; unlink 'Op_write.tmp'; }
+    { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 2\n"; }
 
@@ -129,7 +129,7 @@ necessary
 now is the time for all good men to come to\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 3\n"; unlink 'Op_write.tmp'; }
+    { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 3\n"; }
 
@@ -184,7 +184,7 @@ $right =
 "fit\n";
 
 if (`$CAT Op_write.tmp` eq $right)
-    { print "ok 6\n"; unlink 'Op_write.tmp'; }
+    { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
 else
     { print "not ok 6\n"; }
 
@@ -213,8 +213,53 @@ write (OUT4);
 close  OUT4;
 if (`$CAT Op_write.tmp` eq "1\n") {
     print "ok 9\n";
-    unlink "Op_write.tmp";
+    1 while unlink "Op_write.tmp";
     }
 else {
     print "not ok 9\n";
     }
+
+eval <<'EOFORMAT';
+format OUT10 =
+@####.## @0###.##
+$test1, $test1
+.
+EOFORMAT
+
+open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$test1 = 12.95;
+write(OUT10);
+close OUT10;
+
+$right = "   12.95 00012.95\n";
+if (`$CAT Op_write.tmp` eq $right)
+    { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
+else
+    { print "not ok 10\n"; }
+
+eval <<'EOFORMAT';
+format OUT11 =
+@0###.## 
+$test1
+@ 0#
+$test1
+@0 # 
+$test1
+.
+EOFORMAT
+
+open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$test1 = 12.95;
+write(OUT11);
+close OUT11;
+
+$right = 
+"00012.95
+1 0#
+10 #\n";
+if (`$CAT Op_write.tmp` eq $right)
+    { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
+else
+    { print "not ok 11\n"; }
index 450b4d0..f932976 100755 (executable)
@@ -14,7 +14,7 @@ END { print @warnings }
 
 ######################### We start with some black magic to print on failure.
 
-BEGIN { $| = 1; print "1..73\n"; }
+BEGIN { $| = 1; print "1..82\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use constant 1.01;
 $loaded = 1;
@@ -229,3 +229,23 @@ test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:
 test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
 test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
 @warnings = ();
+
+
+use constant {
+       THREE  => 3,
+       FAMILY => [ qw( John Jane Sally ) ],
+       AGES   => { John => 33, Jane => 28, Sally => 3 },
+       RFAM   => [ [ qw( John Jane Sally ) ] ],
+       SPIT   => sub { shift },
+       PHFAM  => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
+};
+
+test 74, @{+FAMILY} == THREE;
+test 75, @{+FAMILY} == @{RFAM->[0]};
+test 76, FAMILY->[2] eq RFAM->[0]->[2];
+test 77, AGES->{FAMILY->[1]} == 28;
+test 78, PHFAM->{John} == AGES->{John};
+test 79, PHFAM->[3] == AGES->{FAMILY->[2]};
+test 80, @{+PHFAM} == SPIT->(THREE+1);
+test 81, THREE**3 eq SPIT->(@{+FAMILY}**3);
+test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE];
index c8a0df8..61528b3 100755 (executable)
@@ -34,7 +34,9 @@ eval {
 # and mingw32 uses said silly CRT
 $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
 
-print "1..", ($have_setlocale ? 116 : 98), "\n";
+my $last = $have_setlocale ? 116 : 98;
+
+print "1..$last\n";
 
 use vars qw(&LC_ALL);
 
@@ -242,13 +244,13 @@ Afrikaans:af:za:1 15
 Arabic:ar:dz eg sa:6 arabic8
 Brezhoneg Breton:br:fr:1 15
 Bulgarski Bulgarian:bg:bg:5
-Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW GB2312 tw.EUC
+Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
 Hrvatski Croatian:hr:hr:2
 Cymraeg Welsh:cy:cy:1 14 15
 Czech:cs:cz:2
 Dansk Danish:dk:da:1 15
 Nederlands Dutch:nl:be nl:1 15
-English American British:en:au ca gb ie nz us uk:1 15 cp850
+English American British:en:au ca gb ie nz us uk zw:1 15 cp850
 Esperanto:eo:eo:3
 Eesti Estonian:et:ee:4 6 13
 Suomi Finnish:fi:fi:1 15
@@ -271,11 +273,12 @@ Latvian:lv:lv:4 6 13
 Lithuanian:lt:lt:4 6 13
 Macedonian:mk:mk:1 15
 Maltese:mt:mt:3
-Norsk Norwegian:no:no:1 15
+Moldovan:mo:mo:2
+Norsk Norwegian:no no\@nynorsk:no:1 15
 Occitan:oc:es:1 15
 Polski Polish:pl:pl:2
 Rumanian:ro:ro:2
-Russki Russian:ru:ru su ua:5 koi8 koi8r koi8u cp1251
+Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
 Serbski Serbian:sr:yu:5
 Slovak:sk:sk:2
 Slovene Slovenian:sl:si:2
@@ -283,10 +286,11 @@ Sqhip Albanian:sq:sq:1 15
 Svenska Swedish:sv:fi se:1 15
 Thai:th:th:11 tis620
 Turkish:tr:tr:9 turkish8
-Yiddish:::1 15
+Yiddish:yi::1 15
 EOF
 
 if ($^O eq 'os390') {
+    # These cause heartburn.  Broken locales?
     $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
     $locales =~ s/Thai:th:th:11 tis620\n//;
 }
@@ -326,6 +330,7 @@ sub decode_encodings {
            }
        } else {
            push @enc, $_;
+           push @enc, "$_.UTF-8";
        }
     }
     if ($^O eq 'os390') {
@@ -347,32 +352,61 @@ foreach (0..15) {
     trylocale("iso_latin_$_");
 }
 
-foreach my $locale (split(/\n/, $locales)) {
-    my ($locale_name, $language_codes, $country_codes, $encodings) =
-       split(/:/, $locale);
-    my @enc = decode_encodings($encodings);
-    foreach my $loc (split(/ /, $locale_name)) {
-       trylocale($loc);
-       foreach my $enc (@enc) {
-           trylocale("$loc.$enc");
-       }
-       $loc = lc $loc;
-       foreach my $enc (@enc) {
-           trylocale("$loc.$enc");
-       }
+# Sanitize the environment so that we can run the external 'locale'
+# program without the taint mode getting grumpy.
+
+# $ENV{PATH} is special in VMS.
+delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
+
+# Other subversive stuff.
+delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+    while (<LOCALES>) {
+        chomp;
+       trylocale($_);
     }
-    foreach my $lang (split(/ /, $language_codes)) {
-       trylocale($lang);
-       foreach my $country (split(/ /, $country_codes)) {
-           my $lc = "${lang}_${country}";
-           trylocale($lc);
+    close(LOCALES);
+} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
+# The SYS$I18N_LOCALE logical name search list was not present on 
+# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
+    opendir(LOCALES, "SYS\$I18N_LOCALE:");
+    while ($_ = readdir(LOCALES)) {
+        chomp;
+        trylocale($_);
+    }
+    close(LOCALES);
+} else {
+
+    # This is going to be slow.
+
+    foreach my $locale (split(/\n/, $locales)) {
+       my ($locale_name, $language_codes, $country_codes, $encodings) =
+           split(/:/, $locale);
+       my @enc = decode_encodings($encodings);
+       foreach my $loc (split(/ /, $locale_name)) {
+           trylocale($loc);
            foreach my $enc (@enc) {
-               trylocale("$lc.$enc");
+               trylocale("$loc.$enc");
            }
-           my $lC = "${lang}_\U${country}";
-           trylocale($lC);
+           $loc = lc $loc;
            foreach my $enc (@enc) {
-               trylocale("$lC.$enc");
+               trylocale("$loc.$enc");
+           }
+       }
+       foreach my $lang (split(/ /, $language_codes)) {
+           trylocale($lang);
+           foreach my $country (split(/ /, $country_codes)) {
+               my $lc = "${lang}_${country}";
+               trylocale($lc);
+               foreach my $enc (@enc) {
+                   trylocale("$lc.$enc");
+               }
+               my $lC = "${lang}_\U${country}";
+               trylocale($lC);
+               foreach my $enc (@enc) {
+                   trylocale("$lC.$enc");
+               }
            }
        }
     }
@@ -380,6 +414,8 @@ foreach my $locale (split(/\n/, $locales)) {
 
 setlocale(LC_ALL, "C");
 
+sub utf8locale { $_[0] =~ /utf-?8/i }
+
 @Locale = sort @Locale;
 
 debug "# Locales = @Locale\n";
@@ -470,7 +506,10 @@ foreach $Locale (@Locale) {
 
        # Test \w.
     
-       {
+       if (utf8locale($Locale)) {
+           # Until the polymorphic regexen arrive.
+           debug "# skipping UTF-8 locale '$Locale'\n";
+       } else {
            my $word = join('', @Neoalpha);
 
            $word =~ /^(\w+)$/;
@@ -623,6 +662,9 @@ foreach $Locale (@Locale) {
     }
 
     debug "# testing 115 with locale '$Locale'\n";
+    # Does taking lc separately differ from taking
+    # the lc "in-line"?  (This was the bug 19990704.002, change #3568.)
+    # The bug was in the caching of the 'o'-magic.
     {
        use locale;
 
@@ -646,7 +688,13 @@ foreach $Locale (@Locale) {
     }
 
     debug "# testing 116 with locale '$Locale'\n";
-    {
+    # Does lc of an UPPER (if different from the UPPER) match
+    # case-insensitively the UPPER, and does the UPPER match
+    # case-insensitively the lc of the UPPER.  And vice versa.
+    if (utf8locale($Locale)) {
+        # Until the polymorphic regexen arrive.
+        debug "# skipping UTF-8 locale '$Locale'\n";
+    } else {
        use locale;
 
        my @f = ();
@@ -661,15 +709,16 @@ foreach $Locale (@Locale) {
            push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
        }
        tryneoalpha($Locale, 116, @f == 0);
-       print "# testing 116 failed for locale '$Locale' for characters @f\n"
-            if @f;
+        if (@f) {
+           print "# failed 116 locale '$Locale' characters @f\n"
+        }
     }
 
 }
 
 # Recount the errors.
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
        if ($_ == 102) {
            print "# The failure of test 102 is not necessarily fatal.\n";
@@ -685,7 +734,7 @@ foreach (99..116) {
 
 my $didwarn = 0;
 
-foreach (99..116) {
+foreach (99..$last) {
     if ($Problem{$_}) {
        my @f = sort keys %{ $Problem{$_} };
        my $f = join(" ", @f);
@@ -710,17 +759,18 @@ EOW
     }
 }
 
-# Tell which locales were okay.
+# Tell which locales were okay and which were not.
 
 if ($didwarn) {
-    my @s;
+    my (@s, @F);
     
     foreach my $l (@Locale) {
        my $p = 0;
-       foreach my $t (102..116) {
+       foreach my $t (102..$last) {
            $p++ if $Problem{$t}{$l};
        }
        push @s, $l if $p == 0;
+      push @F, $l unless $p == 0;
     }
     
     if (@s) {
@@ -732,7 +782,19 @@ if ($didwarn) {
             "#\t", $s, "\n#\n",
            "# tested okay.\n#\n",
     } else {
-        warn "# None of your locales was fully okay.\n";
+        warn "# None of your locales were fully okay.\n";
+    }
+
+    if (@F) {
+        my $F = join(" ", @F);
+        $F =~ s/(.{50,60}) /$1\n#\t/g;
+
+        warn
+          "# The following locales\n#\n",
+            "#\t", $F, "\n#\n",
+          "# had problems.\n#\n",
+    } else {
+        warn "# None of your locales were broken.\n";
     }
 }
 
index c7105dc..bf24c07 100755 (executable)
@@ -133,6 +133,7 @@ test ( $a eq "087");                # 29
 test ( $b eq "88");            # 30
 test (ref $a eq "Oscalar");    # 31
 
+undef $b;                      # Destroying updates tables too...
 
 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
 
index 3ab8766..a54075d 100755 (executable)
@@ -1,4 +1,4 @@
-print "1..46\n";
+print "1..49\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -334,8 +334,8 @@ print "# '$_'.\nnot "
   unless /Can\'t return a temporary from lvalue subroutine/;
 print "ok 38\n";
 
-sub xxx () { 'xxx' } # Not lvalue
-sub lv1tmpr : lvalue { xxx }                   # is it a TEMP?
+sub yyy () { 'yyy' } # Const, not lvalue
+sub lv1tmpr : lvalue { yyy }                   # is it read-only?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
@@ -427,3 +427,25 @@ $a = \&lv1nn;
 $a->() = 8;
 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 print "ok 46\n";
+
+# This must happen at run time
+eval {
+    sub AUTOLOAD : lvalue { $newvar };
+};
+foobar() = 12;
+print "# '$newvar'.\nnot " unless $newvar eq "12";
+print "ok 47\n";
+
+# Testing DWIM of foo = bar;
+sub foo : lvalue {
+    $a;
+}
+$a = "not ok 48\n";
+foo = "ok 48\n";
+print $a;
+
+open bar, ">nothing" or die $!; 
+bar = *STDOUT;
+print bar "ok 49\n";
+unlink "nothing";
+
index c3538c0..8e4d296 100755 (executable)
@@ -10,7 +10,7 @@ BEGIN {
     }
 }
 
-print "1..99\n";
+print "1..105\n";
 
 my $test = 1;
 
@@ -42,6 +42,7 @@ sub nok_bytes {
 
 {
     use utf8;
+
     $_ = ">\x{263A}<"; 
     s/([\x{80}-\x{10ffff}])/"&#".ord($1).";"/eg; 
     ok $_, '>&#9786;<';
@@ -104,215 +105,193 @@ sub nok_bytes {
     ok $1, '123alpha';
     $test++;                           # 12
 }
-{
-    use utf8;
-
-    $_ = "\x{263A}>\x{263A}\x{263A}"; 
 
-    ok length, 4;
-    $test++;                           # 13
-
-    ok length((m/>(.)/)[0]), 1;
-    $test++;                           # 14
-
-    ok length($&), 2;
-    $test++;                           # 15
+{
+    # no use utf8 needed
+    $_ = "\x{263A}\x{263A}x\x{263A}y\x{263A}";
+    
+    ok length($_), 6;                  # 13
+    $test++;
 
-    ok length($'), 1;
-    $test++;                           # 16
+    ($a) = m/x(.)/;
 
-    ok length($`), 1;
-    $test++;                           # 17
+    ok length($a), 1;                  # 14
+    $test++;
 
-    ok length($1), 1;
-    $test++;                           # 18
+    ok length($`), 2;                  # 15
+    $test++;
+    ok length($&), 2;                  # 16
+    $test++;
+    ok length($'), 2;                  # 17
+    $test++;
 
-    ok length($tmp=$&), 2;
-    $test++;                           # 19
+    ok length($1), 1;                  # 18
+    $test++;
 
-    ok length($tmp=$'), 1;
-    $test++;                           # 20
+    ok length($b=$`), 2;               # 19
+    $test++;
 
-    ok length($tmp=$`), 1;
-    $test++;                           # 21
+    ok length($b=$&), 2;               # 20
+    $test++;
 
-    ok length($tmp=$1), 1;
-    $test++;                           # 22
+    ok length($b=$'), 2;               # 21
+    $test++;
 
-    {
-       use bytes;
+    ok length($b=$1), 1;               # 22
+    $test++;
 
-       my $tmp = $&;
-       ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
-       $test++;                                # 23
+    ok $a, "\x{263A}";                 # 23
+    $test++;
 
-       $tmp = $';
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 24
+    ok $`, "\x{263A}\x{263A}";         # 24
+    $test++;
 
-       $tmp = $`;
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 25
+    ok $&, "x\x{263A}";                        # 25
+    $test++;
 
-       $tmp = $1;
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 26
-    }
+    ok $', "y\x{263A}";                        # 26
+    $test++;
 
-    ok_bytes $&, pack("C*", ord(">"), 0342, 0230, 0272);
-    $test++;                           # 27
+    ok $1, "\x{263A}";                 # 27
+    $test++;
 
-    ok_bytes $', pack("C*", 0342, 0230, 0272);
-    $test++;                           # 28
+    ok_bytes $a, "\342\230\272";       # 28
+    $test++;
 
-    ok_bytes $`, pack("C*", 0342, 0230, 0272);
-    $test++;                           # 29
+    ok_bytes $1, "\342\230\272";       # 29
+    $test++;
 
-    ok_bytes $1, pack("C*", 0342, 0230, 0272);
-    $test++;                           # 30
+    ok_bytes $&, "x\342\230\272";      # 30
+    $test++;
 
     {
-       use bytes;
-       no utf8;
-
-       ok length, 10;
-       $test++;                                # 31
-
-       ok length((m/>(.)/)[0]), 1;
-       $test++;                                # 32
-
-       ok length($&), 2;
-       $test++;                                # 33
+       use utf8; # required
+       $_ = chr(0x263A) . chr(0x263A) . 'x' . chr(0x263A) . 'y' . chr(0x263A);
+    }
 
-       ok length($'), 5;
-       $test++;                                # 34
+    ok length($_), 6;                  # 31
+    $test++;
 
-       ok length($`), 3;
-       $test++;                                # 35
+    ($a) = m/x(.)/;
 
-       ok length($1), 1;
-       $test++;                                # 36
+    ok length($a), 1;                  # 32
+    $test++;
 
-       ok $&, pack("C*", ord(">"), 0342);
-       $test++;                                # 37
+    ok length($`), 2;                  # 33
+    $test++;
 
-       ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-       $test++;                                # 38
+    ok length($&), 2;                  # 34
+    $test++;
 
-       ok $`, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 39
+    ok length($'), 2;                  # 35
+    $test++;
 
-       ok $1, pack("C*", 0342);
-       $test++;                                # 40
+    ok length($1), 1;                  # 36
+    $test++;
 
-    }
+    ok length($b=$`), 2;               # 37
+    $test++;
 
+    ok length($b=$&), 2;               # 38
+    $test++;
 
-    {
-       no utf8;
-       $_="\342\230\272>\342\230\272\342\230\272";
-    }
+    ok length($b=$'), 2;               # 39
+    $test++;
 
-    ok length, 10;
-    $test++;                           # 41
+    ok length($b=$1), 1;               # 40
+    $test++;
 
-    ok length((m/>(.)/)[0]), 1;
-    $test++;                           # 42
+    ok $a, "\x{263A}";                 # 41
+    $test++;
 
-    ok length($&), 2;
-    $test++;                           # 43
+    ok $`, "\x{263A}\x{263A}";         # 42
+    $test++;
 
-    ok length($'), 1;
-    $test++;                           # 44
+    ok $&, "x\x{263A}";                        # 43
+    $test++;
 
-    ok length($`), 1;
-    $test++;                           # 45
+    ok $', "y\x{263A}";                        # 44
+    $test++;
 
-    ok length($1), 1;
-    $test++;                           # 46
+    ok $1, "\x{263A}";                 # 45
+    $test++;
 
-    ok length($tmp=$&), 2;
-    $test++;                           # 47
+    ok_bytes $a, "\342\230\272";       # 46
+    $test++;
 
-    ok length($tmp=$'), 1;
-    $test++;                           # 48
+    ok_bytes $1, "\342\230\272";       # 47
+    $test++;
 
-    ok length($tmp=$`), 1;
-    $test++;                           # 49
+    ok_bytes $&, "x\342\230\272";      # 48
+    $test++;
 
-    ok length($tmp=$1), 1;
-    $test++;                           # 50
+    $_ = "\342\230\272\342\230\272x\342\230\272y\342\230\272";
 
-    {
-       use bytes;
+    ok length($_), 14;                 # 49
+    $test++;
 
-        my $tmp = $&;
-       ok $tmp, pack("C*", ord(">"), 0342, 0230, 0272);
-       $test++;                                # 51
+    ($a) = m/x(.)/;
 
-        $tmp = $';
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 52
+    ok length($a), 1;                  # 50
+    $test++;
 
-        $tmp = $`;
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 53
+    ok length($`), 6;                  # 51
+    $test++;
 
-        $tmp = $1;
-       ok $tmp, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 54
-    }
-    {
-       use bytes;
-       no utf8;
+    ok length($&), 2;                  # 52
+    $test++;
 
-       ok length, 10;
-       $test++;                                # 55
+    ok length($'), 6;                  # 53
+    $test++;
 
-       ok length((m/>(.)/)[0]), 1;
-       $test++;                                # 56
+    ok length($1), 1;                  # 54
+    $test++;
 
-       ok length($&), 2;
-       $test++;                                # 57
+    ok length($b=$`), 6;               # 55
+    $test++;
 
-       ok length($'), 5;
-       $test++;                                # 58
+    ok length($b=$&), 2;               # 56
+    $test++;
 
-       ok length($`), 3;
-       $test++;                                # 59
+    ok length($b=$'), 6;               # 57
+    $test++;
 
-       ok length($1), 1;
-       $test++;                                # 60
+    ok length($b=$1), 1;               # 58
+    $test++;
 
-       ok $&, pack("C*", ord(">"), 0342);
-       $test++;                                # 61
+    ok $a, "\342";                     # 59
+    $test++;
 
-       ok $', pack("C*", 0230, 0272, 0342, 0230, 0272);
-       $test++;                                # 62
+    ok $`, "\342\230\272\342\230\272"; # 60
+    $test++;
 
-       ok $`, pack("C*", 0342, 0230, 0272);
-       $test++;                                # 63
+    ok $&, "x\342";                    # 61
+    $test++;
 
-       ok $1, pack("C*", 0342);
-       $test++;                                # 64
+    ok $', "\230\272y\342\230\272";    # 62
+    $test++;
 
-    }
+    ok $1, "\342";                     # 63
+    $test++;
+}
 
+{
+    use utf8;
     ok "\x{ab}" =~ /^\x{ab}$/, 1;
-    $test++;                                   # 65
+    $test++;                           # 64
 }
 
 {
     use utf8;
     ok_bytes chr(0xe2), pack("C*", 0xc3, 0xa2);
-    $test++;                # 66
+    $test++;                # 65
 }
 
 {
     use utf8;
     my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
     ok "@a", "1234 123 2345";
-    $test++;                # 67
+    $test++;                # 66
 }
 
 {
@@ -320,17 +299,22 @@ sub nok_bytes {
     my $x = chr(123);
     my @a = map ord, split(/$x/, join("", map chr, (1234, 123, 2345)));
     ok "@a", "1234 2345";
-    $test++;                # 68
+    $test++;                # 67
 }
 
 {
     # bug id 20001009.001
 
-    my($a,$b);
-    { use bytes; $a = "\xc3\xa4"; }  
-    { use utf8;  $b = "\xe4"; }
-    { use bytes; ok_bytes $a, $b; $test++; } # 69
-    { use utf8;  nok      $a, $b; $test++; } # 70
+    my ($a, $b);
+
+    { use bytes; $a = "\xc3\xa4" }
+    { use utf8;  $b = "\xe4"     } # \xXX must not produce UTF-8
+
+    print "not " if $a eq $b;
+    print "ok $test\n"; $test++;       # 68
+
+    { use utf8; print "not " if $a eq $b; }
+    print "ok $test\n"; $test++;       # 69
 }
 
 {
@@ -340,7 +324,7 @@ sub nok_bytes {
     for (@x) {
        s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
        my($latin) = /^(.+)(?:\s+\d)/;
-       print $latin eq "stra\337e" ? "ok $test\n" :
+       print $latin eq "stra\337e" ? "ok $test\n" :    # 70, 71
            "#latin[$latin]\nnot ok $test\n";
        $test++;
        $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
@@ -350,64 +334,6 @@ sub nok_bytes {
 }
 
 {
-    # bug id 20000819.004 
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$dx$1/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-
-    $_ = $dx = "\x{10f2}";
-    s/($dx)/$1$dx/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-
-    $dx = "\x{10f2}";
-    $_  = "\x{10f2}\x{10f2}";
-    s/($dx)($dx)/$1$2/;
-    {
-       use bytes;
-       print "not " unless $_ eq "$dx$dx";
-       print "ok $test\n";
-       $test++;
-    }
-}
-
-{
-    # bug id 20000323.056
-
-    use utf8;
-
-    print "not " unless "\x{41}" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x41" eq +v65;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{c8}" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\xc8" eq +v200;
-    print "ok $test\n";
-    $test++;
-
-    print "not " unless "\x{221b}" eq v8731;
-    print "ok $test\n";
-    $test++;
-}
-
-{
     # bug id 20000427.003 
 
     use utf8;
@@ -423,18 +349,7 @@ sub nok_bytes {
     }
 
     print "not " unless $r eq " U+B36C U+5A8C U+FF5B U+5079 U+505B";
-    print "ok $test\n";
-    $test++;
-}
-
-{
-    # bug id 20000901.092
-    # test that undef left and right of utf8 results in a valid string
-
-    my $a;
-    $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
+    print "ok $test\n";                        # 72
     $test++;
 }
 
@@ -449,27 +364,27 @@ sub nok_bytes {
     print "not "
        unless $a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a;
     print "ok $test\n";
-    $test++;
+    $test++;                           # 73
 
     my ($a, $b) = split(/\x{100}/, $s);
     print "not " unless $a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;                           # 74
 
     my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
     print "not " unless $a eq "\x20\x40" && $b eq "\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;                           # 75
 
     my ($a, $b) = split(/\x40\x{80}/, $s);
     print "not " unless $a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20";
     print "ok $test\n";
-    $test++;
+    $test++;                           # 76
 
     my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
     print "not " unless $a eq "\x20" && $b eq "\x{100}" && $c eq "\x20";
     print "ok $test\n";
-    $test++;
+    $test++;                           # 77
 }
 
 {
@@ -479,14 +394,14 @@ sub nok_bytes {
 
     my $smiley = "\x{263a}";
 
-    for my $s ("\x{263a}",                     #  1
-              $smiley,                        #  2
+    for my $s ("\x{263a}",                     # 78
+              $smiley,                        # 79
                
-              "" . $smiley,                   #  3
-              "" . "\x{263a}",                #  4
+              "" . $smiley,                   # 80
+              "" . "\x{263a}",                # 81
 
-              $smiley    . "",                #  5
-              "\x{263a}" . "",                #  6
+              $smiley    . "",                # 82
+              "\x{263a}" . "",                # 83
               ) {
        my $length_chars = length($s);
        my $length_bytes;
@@ -502,14 +417,14 @@ sub nok_bytes {
        $test++;
     }
 
-    for my $s ("\x{263a}" . "\x{263a}",        #  7
-              $smiley    . $smiley,           #  8
+    for my $s ("\x{263a}" . "\x{263a}",        # 84
+              $smiley    . $smiley,           # 85
 
-              "\x{263a}\x{263a}",             #  9
-              "$smiley$smiley",               # 10
+              "\x{263a}\x{263a}",             # 86
+              "$smiley$smiley",               # 87
               
-              "\x{263a}" x 2,                 # 11
-              $smiley    x 2,                 # 12
+              "\x{263a}" x 2,                 # 88
+              $smiley    x 2,                 # 89
               ) {
        my $length_chars = length($s);
        my $length_bytes;
@@ -525,3 +440,117 @@ sub nok_bytes {
        $test++;
     }
 }
+
+{
+    use utf8;
+
+    print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;                                   # 90
+
+    print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;                                   # 91
+
+    print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;                                   # 92
+
+    print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;                                   # 93
+
+    print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;                                   # 94
+
+    print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;                                   # 95
+
+    print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
+    print "ok $test\n";
+    $test++;                                   # 96
+
+    print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
+    print "ok $test\n";
+    $test++;                                   # 97
+}
+
+{
+    # the first half of 20001028.003
+
+    my $X = chr(1448);
+    my ($Y) = $X =~ /(.*)/;
+    print "not " unless length $Y == 1;
+    print "ok $test\n";
+    $test++;                                   # 98
+}
+
+{
+    # 20001108.001
+
+    use utf8;
+    my $X = "Szab\x{f3},Bal\x{e1}zs";
+    my $Y = $X;
+    $Y =~ s/(B)/$1/ for 0..3;
+    print "not " unless $Y eq $X;
+    print "ok $test\n";
+    $test++;                                   # 99
+}
+
+{
+    # 20001114.001     
+
+    use utf8;
+    use charnames ':full';
+    my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
+    print "not " unless ord($text) == 0xc4;
+    print "ok $test\n";
+    $test++;                                    # 100
+}
+
+{
+    # 20001205.014
+
+    use utf8;
+
+    my $a = "ABC\x{263A}";
+
+    my @b = split( //, $a );
+
+    print "not " unless @b == 4;
+    print "ok $test\n";
+    $test++;                                    # 101
+
+    print "not " unless length($b[3]) == 1;
+    print "ok $test\n";
+    $test++;                                    # 102
+
+    $a =~ s/^A/Z/;
+    print "not " unless length($a) == 4;
+    print "ok $test\n";
+    $test++;                                    # 103
+}
+
+{
+    # the second half of 20001028.003
+
+    use utf8;
+    $X =~ s/^/chr(1488)/e;
+    print "not " unless length $X == 1;
+    print "ok $test\n";
+    $test++;                                   # 104
+}
+
+{
+    # 20000517.001
+
+    my $x = "\x{100}A";
+
+    $x =~ s/A/B/;
+
+    print "not " unless $x eq "\x{100}B" && length($x) == 2;
+    print "ok $test\n";
+    $test++;                                   # 105
+}
index 4268205..5dd0380 100644 (file)
@@ -47,6 +47,9 @@
   Possible Y2K bug: about to append an integer to '19' [pp_concat]
     $x     = "19$yy\n";
 
+  Use of reference "%s" as array index [pp_aelem]
+    $x[\1]
+
 __END__
 # pp_hot.c [pp_print]
 use warnings 'unopened' ;
@@ -151,6 +154,7 @@ open (FH, ">./xcv") ;
 my $a = <FH> ;
 no warnings 'io' ;
 $a = <FH> ;
+close (FH) ;
 unlink $file ;
 EXPECT
 Filehandle FH opened only for output at - line 5.
@@ -227,3 +231,17 @@ $x     = "19" . $yy . "\n";
 EXPECT
 Possible Y2K bug: about to append an integer to '19' at - line 12.
 Possible Y2K bug: about to append an integer to '19' at - line 13.
+########
+# pp_hot.c [pp_aelem]
+{
+use warnings 'misc';
+print $x[\1];
+}
+{
+no warnings 'misc';
+print $x[\1];
+}
+
+EXPECT
+OPTION regex
+Use of reference ".*" as array index at - line 4.
index 2843c70..e30637b 100644 (file)
@@ -3,6 +3,15 @@
   untie attempted while %d inner references still exist        [pp_untie]
     sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ;
 
+  fileno() on unopened filehandle abc          [pp_fileno]
+    $a = "abc"; fileno($a)
+
+  binmode() on unopened filehandle abc         [pp_binmode]
+    $a = "abc"; fileno($a)
+
+  printf() on unopened filehandle abc          [pp_prtf]
+    $a = "abc"; printf $a "fred"
+
   Filehandle %s opened only for input          [pp_leavewrite]
     format STDIN =
     .
@@ -74,7 +83,7 @@
     flock STDIN, 8;
     flock $a, 8;
 
-  lstat() on filehandle %s                     [pp_stat]
+  The stat preceding lstat() wasn't an lstat %s        [pp_stat]
     lstat(STDIN);
 
   warn(warn_nl, "stat");                       [pp_stat]
@@ -203,7 +212,9 @@ syswrite() on closed filehandle STDIN at - line 6.
 # pp_sys.c [pp_flock]
 use Config; 
 BEGIN { 
-  if ( $^O eq 'VMS' and ! $Config{d_flock}) {
+  if ( !$Config{d_flock} &&
+       !$Config{d_fcntl_can_lock} &&
+       !$Config{d_lockf} ) {
     print <<EOM ;
 SKIPPED
 # flock not present
@@ -225,11 +236,11 @@ flock STDIN, 8;
 flock FOO, 8;
 flock $a, 8;
 EXPECT
-flock() on closed filehandle STDIN at - line 14.
 flock() on closed filehandle STDIN at - line 16.
+flock() on closed filehandle STDIN at - line 18.
        (Are you trying to call flock() on dirhandle STDIN?)
-flock() on unopened filehandle FOO at - line 17.
-flock() on unopened filehandle at - line 18.
+flock() on unopened filehandle FOO at - line 19.
+flock() on unopened filehandle at - line 20.
 ########
 # pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername]
 use warnings 'io' ;
@@ -352,7 +363,7 @@ lstat(STDIN) ;
 no warnings 'io' ;
 lstat(STDIN) ;
 EXPECT
-lstat() on filehandle STDIN at - line 13.
+The stat preceding lstat() wasn't an lstat at - line 13.
 ########
 # pp_sys.c [pp_fttext]
 use warnings qw(unopened closed) ;
@@ -398,3 +409,11 @@ close F ;
 unlink $file ;
 EXPECT
 Filehandle F opened only for output at - line 12.
+########
+# pp_sys.c [pp_binmode]
+use warnings 'unopened' ;
+binmode(BLARG);
+$a = "BLERG";binmode($a);
+EXPECT
+binmode() on unopened filehandle BLARG at - line 3.
+binmode() on unopened filehandle at - line 4.
index 6a2fe54..9a7dbaf 100644 (file)
 
 __END__
 # utf8.c [utf8_to_uv] -W
+BEGIN {
+    if (ord('A') == 193) {
+        print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings.";
+        exit 0;
+    }
+}
 use utf8 ;
 my $a = "snøstorm" ;
 {
@@ -24,6 +30,6 @@ my $a = "sn
     my $a = "snøstorm";
 }
 EXPECT
-Malformed UTF-8 character at - line 3.
-Malformed UTF-8 character at - line 8.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9.
+Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14.
 ########
index 3674497..872e6e1 100644 (file)
@@ -25,28 +25,37 @@ if (@ARGV)
 else
   { @w_files = sort glob("pragma/warn/*") }
 
-foreach (@w_files) {
+my $files = 0;
+foreach my $file (@w_files) {
 
     next if /(~|\.orig|,v)$/;
 
-    open F, "<$_" or die "Cannot open $_: $!\n" ;
+    open F, "<$file" or die "Cannot open $file: $!\n" ;
+    my $line = 0;
     while (<F>) {
+        $line++; 
        last if /^__END__/ ;
     }
 
     {
         local $/ = undef;
-        @prgs = (@prgs, split "\n########\n", <F>) ;
+        $files++; 
+        @prgs = (@prgs, $file, split "\n########\n", <F>) ;
     }
     close F ;
 }
 
 undef $/;
 
-print "1..", scalar @prgs, "\n";
+print "1..", scalar(@prgs)-$files, "\n";
  
  
 for (@prgs){
+    unless (/\n/)
+     {
+      print "# From $_\n"; 
+      next; 
+     }
     my $switch = "";
     my @temps = () ;
     if (s/^\s*-\w+//){
diff --git a/taint.c b/taint.c
index 0f0ce98..7a8baac 100644 (file)
--- a/taint.c
+++ b/taint.c
@@ -11,7 +11,6 @@
 void
 Perl_taint_proper(pTHX_ const char *f, const char *s)
 {
-    dTHR;      /* just for taint */
     char *ug;
 
 #ifdef HAS_SETEUID
@@ -64,12 +63,10 @@ Perl_taint_env(pTHX)
        if (!svp || *svp == &PL_sv_undef)
            break;
        if (SvTAINTED(*svp)) {
-           dTHR;
            TAINT;
            taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
        }
        if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
-           dTHR;
            TAINT;
            taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
        }
@@ -81,12 +78,10 @@ Perl_taint_env(pTHX)
     svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
     if (svp && *svp) {
        if (SvTAINTED(*svp)) {
-           dTHR;
            TAINT;
            taint_proper("Insecure %s%s", "$ENV{PATH}");
        }
        if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
-           dTHR;
            TAINT;
            taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
        }
@@ -96,7 +91,6 @@ Perl_taint_env(pTHX)
     /* tainted $TERM is okay if it contains no metachars */
     svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
     if (svp && *svp && SvTAINTED(*svp)) {
-       dTHR;   /* just for taint */
        STRLEN n_a;
        bool was_tainted = PL_tainted;
        char *t = SvPV(*svp, n_a);
@@ -116,7 +110,6 @@ Perl_taint_env(pTHX)
     for (e = misc_env; *e; e++) {
        svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
        if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
-           dTHR;       /* just for taint */
            TAINT;
            taint_proper("Insecure $ENV{%s}%s", *e);
        }
index e4cfacc..7f591d9 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -84,8 +84,7 @@ PERLVAR(Tcurpm,               PMOP *)         /* what to do \ interps in REs from */
 PERLVAR(Tnrs,          SV *)
 PERLVAR(Trs,           SV *)           /* input record separator $/ */
 PERLVAR(Tlast_in_gv,   GV *)           /* GV used in last <FH> */
-PERLVAR(Tofs,          char *)         /* output field separator $, */
-PERLVAR(Tofslen,       STRLEN)
+PERLVAR(Tofs_sv,       SV *)           /* output field separator $, */
 PERLVAR(Tdefoutgv,     GV *)           /* default FH for output */
 PERLVARI(Tchopset,     char *, " \n-") /* $: */
 PERLVAR(Tformtarget,   SV *)
@@ -236,5 +235,5 @@ PERLVAR(i,          struct thread_intern)
 #endif
 
 PERLVAR(trailing_nul,  char)           /* For the sake of thrsv and oursv */
-
+PERLVAR(thr_done,      bool)           /* True when the thread has finished */
 #endif /* USE_THREADS */
diff --git a/toke.c b/toke.c
index b3c6674..e0d6f07 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1,6 +1,6 @@
 /*    toke.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -13,7 +13,7 @@
 
 /*
  * This file is the lexer for Perl.  It's closely linked to the
- * parser, perly.y.  
+ * parser, perly.y.
  *
  * The main routine is yylex(), which returns the next token.
  */
@@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
 #define UTF (PL_hints & HINT_UTF8)
 
-/* In variables name $^X, these are the legal values for X.  
+/* In variables name $^X, these are the legal values for X.
  * 1999-02-27 mjd-perl-patch@plover.com */
 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
 
@@ -69,26 +69,24 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
 #define LEX_FORMLINE            1
 #define LEX_KNOWNEXT            0
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-#  include <unistd.h> /* Needed for execv() */
-#endif
-
-
 #ifdef ff_next
 #undef ff_next
 #endif
 
 #ifdef USE_PURE_BISON
-YYSTYPE* yylval_pointer = NULL;
-int* yychar_pointer = NULL;
+#  ifndef YYMAXLEVEL
+#    define YYMAXLEVEL 100
+#  endif
+YYSTYPE* yylval_pointer[YYMAXLEVEL];
+int* yychar_pointer[YYMAXLEVEL];
+int yyactlevel = -1;
 #  undef yylval
 #  undef yychar
-#  define yylval (*yylval_pointer)
-#  define yychar (*yychar_pointer)
-#  define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
+#  define yylval (*yylval_pointer[yyactlevel])
+#  define yychar (*yychar_pointer[yyactlevel])
+#  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
 #  undef yylex
-#  define yylex()      Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
+#  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
 #endif
 
 #include "keywords.h"
@@ -123,7 +121,7 @@ int* yychar_pointer = NULL;
  * Aop          : addition-level operator
  * Mop          : multiplication-level operator
  * Eop          : equality-testing operator
- * Rop        : relational operator <= != gt
+ * Rop          : relational operator <= != gt
  *
  * Also see LOP and lop() below.
  */
@@ -276,7 +274,6 @@ S_missingterm(pTHX_ char *s)
 void
 Perl_deprecate(pTHX_ char *s)
 {
-    dTHR;
     if (ckWARN(WARN_DEPRECATED))
        Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 }
@@ -339,7 +336,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 void
 Perl_lex_start(pTHX_ SV *line)
 {
-    dTHR;
     char *s;
     STRLEN len;
 
@@ -435,7 +431,6 @@ Perl_lex_end(pTHX)
 STATIC void
 S_incline(pTHX_ char *s)
 {
-    dTHR;
     char *t;
     char *n;
     char *e;
@@ -451,7 +446,7 @@ S_incline(pTHX_ char *s)
        return;
     if (*s == ' ' || *s == '\t')
        s++;
-    else 
+    else
        return;
     while (SPACE_OR_TAB(*s)) s++;
     if (!isDIGIT(*s))
@@ -497,7 +492,6 @@ S_incline(pTHX_ char *s)
 STATIC char *
 S_skipspace(pTHX_ register char *s)
 {
-    dTHR;
     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
        while (s < PL_bufend && SPACE_OR_TAB(*s))
            s++;
@@ -616,7 +610,6 @@ S_check_uni(pTHX)
 {
     char *s;
     char *t;
-    dTHR;
 
     if (PL_oldoldbufptr != PL_last_uni)
        return;
@@ -628,8 +621,8 @@ S_check_uni(pTHX)
     if (ckWARN_d(WARN_AMBIGUOUS)){
         char ch = *s;
         *s = '\0';
-        Perl_warner(aTHX_ WARN_AMBIGUOUS, 
-                  "Warning: Use of \"%s\" without parens is ambiguous", 
+        Perl_warner(aTHX_ WARN_AMBIGUOUS,
+                  "Warning: Use of \"%s\" without parens is ambiguous",
                   PL_last_uni);
         *s = ch;
     }
@@ -682,7 +675,6 @@ S_uni(pTHX_ I32 f, char *s)
 STATIC I32
 S_lop(pTHX_ I32 f, int x, char *s)
 {
-    dTHR;
     yylval.ival = f;
     CLINE;
     PL_expect = x;
@@ -709,7 +701,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
  * handles the token correctly.
  */
 
-STATIC void 
+STATIC void
 S_force_next(pTHX_ I32 type)
 {
     PL_nexttype[PL_nexttoke] = type;
@@ -742,7 +734,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow
 {
     register char *s;
     STRLEN len;
-    
+
     start = skipspace(start);
     s = start;
     if (isIDFIRST_lazy_if(s,UTF) ||
@@ -784,7 +776,6 @@ S_force_ident(pTHX_ register char *s, int kind)
        PL_nextval[PL_nexttoke].opval = o;
        force_next(WORD);
        if (kind) {
-           dTHR;               /* just for in_eval */
            o->op_private = OPpCONST_ENTERED;
            /* XXX see note in pp_entereval() for why we forgo typo
               warnings if the symbol must be introduced in an eval.
@@ -809,10 +800,10 @@ Perl_str_to_version(pTHX_ SV *sv)
     bool utf = SvUTF8(sv) ? TRUE : FALSE;
     char *end = start + len;
     while (start < end) {
-       I32 skip;
+       STRLEN skip;
        UV n;
        if (utf)
-           n = utf8_to_uv_chk((U8*)start, &skip, 0);
+           n = utf8_to_uv((U8*)start, len, &skip, 0);
        else {
            n = *(U8*)start;
            skip = 1;
@@ -824,7 +815,7 @@ Perl_str_to_version(pTHX_ SV *sv)
     return retval;
 }
 
-/* 
+/*
  * S_force_version
  * Forces the next token to be a version number.
  */
@@ -844,7 +835,7 @@ S_force_version(pTHX_ char *s)
         for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
            SV *ver;
-            s = scan_num(s);
+            s = scan_num(s, &yylval);
             version = yylval.opval;
            ver = cSVOPx(version)->op_sv;
            if (SvPOK(ver) && !SvNIOK(ver)) {
@@ -857,7 +848,7 @@ S_force_version(pTHX_ char *s)
 
     /* NOTE: The parser sees the package name and the VERSION swapped */
     PL_nextval[PL_nexttoke].opval = version;
-    force_next(WORD); 
+    force_next(WORD);
 
     return (s);
 }
@@ -965,7 +956,7 @@ S_sublex_start(pTHX)
                SvUTF8_on(nsv);
            SvREFCNT_dec(sv);
            sv = nsv;
-       } 
+       }
        yylval.opval = (OP*)newSVOP(op_type, 0, sv);
        PL_lex_stuff = Nullsv;
        return THING;
@@ -997,7 +988,6 @@ S_sublex_start(pTHX)
 STATIC I32
 S_sublex_push(pTHX)
 {
-    dTHR;
     ENTER;
 
     PL_lex_state = PL_sublex_info.super_state;
@@ -1171,7 +1161,7 @@ S_sublex_done(pTHX)
              } (end switch)
          } (end if backslash)
     } (end while character to read)
-                 
+               
 */
 
 STATIC char *
@@ -1183,14 +1173,13 @@ S_scan_const(pTHX_ char *start)
     register char *d = SvPVX(sv);              /* destination for copies */
     bool dorange = FALSE;                      /* are we in a translit range? */
     bool didrange = FALSE;                     /* did we just finish a range? */
-    bool has_utf = FALSE;                      /* embedded \x{} */
-    I32 len;                                   /* ? */
+    bool has_utf8 = FALSE;                     /* embedded \x{} */
     UV uv;
 
     I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
        ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
        : UTF;
-    I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
+    I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
        ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
                                                OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
        : UTF;
@@ -1244,11 +1233,11 @@ S_scan_const(pTHX_ char *start)
                dorange = FALSE;
                didrange = TRUE;
                continue;
-           } 
+           }
 
            /* range begins (ignore - as first or last char) */
            else if (*s == '-' && s+1 < send  && s != start) {
-               if (didrange) { 
+               if (didrange) {
                    Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
                }
                if (utf) {
@@ -1283,9 +1272,9 @@ S_scan_const(pTHX_ char *start)
                while (count && (c = *regparse)) {
                    if (c == '\\' && regparse[1])
                        regparse++;
-                   else if (c == '{') 
+                   else if (c == '{')
                        count++;
-                   else if (c == '}') 
+                   else if (c == '}')
                        count--;
                    regparse++;
                }
@@ -1322,27 +1311,10 @@ S_scan_const(pTHX_ char *start)
                break;          /* in regexp, $ might be tail anchor */
        }
 
-       /* (now in tr/// code again) */
-
-       if (*s & 0x80 && thisutf) {
-          (void)utf8_to_uv_chk((U8*)s, &len, 0);
-          if (len == 1) {
-              /* illegal UTF8, make it valid */
-              char *old_pvx = SvPVX(sv);
-              /* need space for one extra char (NOTE: SvCUR() not set here) */
-              d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
-              d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
-          }
-          else {
-              while (len--)
-                  *d++ = *s++;
-          }
-          has_utf = TRUE;
-          continue;
-       }
-
        /* backslashes */
        if (*s == '\\' && s+1 < send) {
+           bool to_be_utf8 = FALSE;
+
            s++;
 
            /* some backslashes we leave behind */
@@ -1356,7 +1328,6 @@ S_scan_const(pTHX_ char *start)
            if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
                isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
            {
-               dTHR;                   /* only for ckWARN */
                if (ckWARN(WARN_SYNTAX))
                    Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
                *--s = '$';
@@ -1381,9 +1352,8 @@ S_scan_const(pTHX_ char *start)
                /* FALL THROUGH */
            default:
                {
-                   dTHR;
                    if (ckWARN(WARN_MISC) && isALNUM(*s))
-                       Perl_warner(aTHX_ WARN_MISC, 
+                       Perl_warner(aTHX_ WARN_MISC,
                               "Unrecognized escape \\%c passed through",
                               *s);
                    /* default action is to copy the quoted character */
@@ -1394,9 +1364,11 @@ S_scan_const(pTHX_ char *start)
            /* \132 indicates an octal constant */
            case '0': case '1': case '2': case '3':
            case '4': case '5': case '6': case '7':
-               len = 0;        /* disallow underscores */
-               uv = (UV)scan_oct(s, 3, &len);
-               s += len;
+               {
+                   STRLEN len = 0;     /* disallow underscores */
+                   uv = (UV)scan_oct(s, 3, &len);
+                   s += len;
+               }
                goto NUM_ESCAPE_INSERT;
 
            /* \x24 indicates a hex constant */
@@ -1408,46 +1380,68 @@ S_scan_const(pTHX_ char *start)
                        yyerror("Missing right brace on \\x{}");
                        e = s;
                    }
-                   len = 1;            /* allow underscores */
-                    uv = (UV)scan_hex(s + 1, e - s - 1, &len);
-                    s = e + 1;
+                   else {
+                       STRLEN len = 1;         /* allow underscores */
+                       uv = (UV)scan_hex(s + 1, e - s - 1, &len);
+                       to_be_utf8 = TRUE;
+                   }
+                   s = e + 1;
                }
                else {
-                   len = 0;            /* disallow underscores */
-                   uv = (UV)scan_hex(s, 2, &len);
-                   s += len;
+                   {
+                       STRLEN len = 0;         /* disallow underscores */
+                       uv = (UV)scan_hex(s, 2, &len);
+                       s += len;
+                   }
                }
 
              NUM_ESCAPE_INSERT:
                /* Insert oct or hex escaped character.
-                * There will always enough room in sv since such escapes will
-                * be longer than any utf8 sequence they can end up as
-                */
+                * There will always enough room in sv since such
+                * escapes will be longer than any UT-F8 sequence
+                * they can end up as. */
+
+               /* This spot is wrong for EBCDIC.  Characters like
+                * the lowercase letters and digits are >127 in EBCDIC,
+                * so here they would need to be mapped to the Unicode
+                * repertoire.   --jhi */
+               
                if (uv > 127) {
-                   if (!thisutf && !has_utf && uv > 255) {
-                       /* might need to recode whatever we have accumulated so far
-                        * if it contains any hibit chars
+                   if (!has_utf8 && (to_be_utf8 || uv > 255)) {
+                       /* Might need to recode whatever we have
+                        * accumulated so far if it contains any
+                        * hibit chars.
+                        *
+                        * (Can't we keep track of that and avoid
+                        *  this rescan? --jhi)
                         */
                        int hicount = 0;
                        char *c;
+
                        for (c = SvPVX(sv); c < d; c++) {
-                           if (*c & 0x80)
+                           if (UTF8_IS_CONTINUED(*c))
                                hicount++;
                        }
                        if (hicount) {
                            char *old_pvx = SvPVX(sv);
                            char *src, *dst;
-                           d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
+                           U8 tmpbuf[UTF8_MAXLEN+1];
+                           U8 *tmpend;
+                         
+                           d = SvGROW(sv,
+                                      SvCUR(sv) + hicount + 1) +
+                                        (d - old_pvx);
 
                            src = d - 1;
                            d += hicount;
                            dst = d - 1;
 
                            while (src < dst) {
-                               if (*src & 0x80) {
-                                   dst--;
-                                   uv_to_utf8((U8*)dst, (U8)*src--);
-                                   dst--;
+                               if (UTF8_IS_CONTINUED(*src)) {
+                                   tmpend = uv_to_utf8(tmpbuf, (U8)*src--);
+                                   dst -= tmpend - tmpbuf;
+                                   Copy((char *)tmpbuf, dst+1,
+                                        tmpend - tmpbuf, char);
                                }
                                else {
                                    *dst-- = *src--;
@@ -1456,9 +1450,9 @@ S_scan_const(pTHX_ char *start)
                         }
                     }
 
-                    if (thisutf || uv > 255) {
+                    if (to_be_utf8 || (has_utf8 && uv > 127) || uv > 255) {
                        d = (char*)uv_to_utf8((U8*)d, uv);
-                       has_utf = TRUE;
+                       has_utf8 = TRUE;
                     }
                    else {
                        *d++ = (char)uv;
@@ -1477,17 +1471,17 @@ S_scan_const(pTHX_ char *start)
                    SV *res;
                    STRLEN len;
                    char *str;
+
                    if (!e) {
                        yyerror("Missing right brace on \\N{}");
                        e = s - 1;
                        goto cont_scan;
                    }
                    res = newSVpvn(s + 1, e - s - 1);
-                   res = new_constant( Nullch, 0, "charnames", 
+                   res = new_constant( Nullch, 0, "charnames",
                                        res, Nullsv, "\\N{...}" );
                    str = SvPV(res,len);
-                   if (!has_utf && SvUTF8(res)) {
+                   if (!has_utf8 && SvUTF8(res)) {
                        char *ostart = SvPVX(sv);
                        SvCUR_set(sv, d - ostart);
                        SvPOK_on(sv);
@@ -1496,7 +1490,7 @@ S_scan_const(pTHX_ char *start)
                        /* this just broke our allocation above... */
                        SvGROW(sv, send - start);
                        d = SvPVX(sv) + SvCUR(sv);
-                       has_utf = TRUE;
+                       has_utf8 = TRUE;
                    }
                    if (len > e - s + 4) {
                        char *odest = SvPVX(sv);
@@ -1521,11 +1515,13 @@ S_scan_const(pTHX_ char *start)
                *d = *s++;
                if (isLOWER(*d))
                   *d = toUPPER(*d);
-               *d = toCTRL(*d); 
+               *d = toCTRL(*d);
                d++;
 #else
-               len = *s++;
-               *d++ = toCTRL(len);
+               {
+                   U8 c = *s++;
+                   *d++ = toCTRL(c);
+               }
 #endif
                continue;
 
@@ -1566,6 +1562,29 @@ S_scan_const(pTHX_ char *start)
            continue;
        } /* end if (backslash) */
 
+       /* (now in tr/// code again) */
+
+       if (UTF8_IS_CONTINUED(*s) && (this_utf8 || has_utf8)) {
+           STRLEN len = (STRLEN) -1;
+           UV uv;
+           if (this_utf8) {
+               uv = utf8_to_uv((U8*)s, send - s, &len, 0);
+           }
+           if (len == (STRLEN)-1) {
+               /* Illegal UTF8 (a high-bit byte), make it valid. */
+               char *old_pvx = SvPVX(sv);
+               /* need space for one extra char (NOTE: SvCUR() not set here) */
+               d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
+               d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
+           }
+           else {
+               while (len--)
+                   *d++ = *s++;
+           }
+           has_utf8 = TRUE;
+           continue;
+       }
+
        *d++ = *s++;
     } /* while loop to process each character */
 
@@ -1573,7 +1592,7 @@ S_scan_const(pTHX_ char *start)
     *d = '\0';
     SvCUR_set(sv, d - SvPVX(sv));
     SvPOK_on(sv);
-    if (has_utf)
+    if (has_utf8)
        SvUTF8_on(sv);
 
     /* shrink the sv if we allocated more than we used */
@@ -1585,9 +1604,9 @@ S_scan_const(pTHX_ char *start)
     /* return the substring (via yylval) only if we parsed anything */
     if (s > PL_bufptr) {
        if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
-           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 
+           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
                              sv, Nullsv,
-                             ( PL_lex_inwhat == OP_TRANS 
+                             ( PL_lex_inwhat == OP_TRANS
                                ? "tr"
                                : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
                                    ? "s"
@@ -1858,7 +1877,7 @@ S_incl_perldb(pTHX)
 
 
 /* Encoded script support. filter_add() effectively inserts a
- * 'pre-processing' function into the current source input stream. 
+ * 'pre-processing' function into the current source input stream.
  * Note that the filter function only applies to the current source file
  * (e.g., it will not affect files 'require'd or 'use'd by this one).
  *
@@ -1894,7 +1913,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
     av_store(PL_rsfp_filters, 0, datasv) ;
     return(datasv);
 }
+
 
 /* Delete most recently added instance of this filter function.        */
 void
@@ -1921,8 +1940,8 @@ Perl_filter_del(pTHX_ filter_t funcp)
 /* Invoke the n'th filter function for the current rsfp.        */
 I32
 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
-            
-               
+
+
                                /* 0 = read one text line */
 {
     filter_t funcp;
@@ -1935,7 +1954,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
        /* Note that we append to the line. This is handy.      */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "filter_read %d: from rsfp\n", idx));
-       if (maxlen) { 
+       if (maxlen) {
            /* Want a block */
            int len ;
            int old_len = SvCUR(buf_sv) ;
@@ -2057,28 +2076,42 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
       if we already built the token before, use it.
 */
 
+#ifdef USE_PURE_BISON
+#ifdef __SC__
+#pragma segment Perl_yylex_r
+#endif
+int
+Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
+{
+    int r;
+
+    yyactlevel++;
+    yylval_pointer[yyactlevel] = lvalp;
+    yychar_pointer[yyactlevel] = lcharp;
+    if (yyactlevel >= YYMAXLEVEL)
+       Perl_croak(aTHX_ "panic: YYMAXLEVEL");
+
+    r = Perl_yylex(aTHX);
+
+    yyactlevel--;
+
+    return r;
+}
+#endif
+
 #ifdef __SC__
 #pragma segment Perl_yylex
 #endif
 int
-#ifdef USE_PURE_BISON
-Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
-#else
 Perl_yylex(pTHX)
-#endif
 {
-    dTHR;
     register char *s;
     register char *d;
     register I32 tmp;
     STRLEN len;
     GV *gv = Nullgv;
     GV **gvp = 0;
-
-#ifdef USE_PURE_BISON
-    yylval_pointer = lvalp;
-    yychar_pointer = lcharp;
-#endif
+    bool bof = FALSE;
 
     /* check if there's an identifier for us to look at */
     if (PL_pending_ident) {
@@ -2086,6 +2119,9 @@ Perl_yylex(pTHX)
        char pit = PL_pending_ident;
        PL_pending_ident = 0;
 
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
+
        /* if we're in a my(), we can't allow dynamics here.
           $foo'bar has already been turned into $foo::bar, so
           just check for colons.
@@ -2110,7 +2146,7 @@ Perl_yylex(pTHX)
            }
        }
 
-       /* 
+       /*
           build the ops for accesses to a my() variable.
 
           Deny my($a) or my($b) in a sort block, *if* $a or $b is
@@ -2223,6 +2259,10 @@ Perl_yylex(pTHX)
            PL_expect = PL_lex_expect;
            PL_lex_defer = LEX_NORMAL;
        }
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
+              (IV)PL_nexttype[PL_nexttoke]); })
+
        return(PL_nexttype[PL_nexttoke]);
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -2254,6 +2294,8 @@ Perl_yylex(pTHX)
            return yylex();
        }
        else {
+           DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Saw case modifier at '%s'\n", PL_bufptr); })
            s = PL_bufptr + 1;
            if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
                tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
@@ -2304,6 +2346,8 @@ Perl_yylex(pTHX)
     case LEX_INTERPSTART:
        if (PL_bufptr == PL_bufend)
            return sublex_done();
+       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+              "### Interpolated variable at '%s'\n", PL_bufptr); })
        PL_expect = XTERM;
        PL_lex_dojoin = (*PL_bufptr == '@');
        PL_lex_state = LEX_INTERPNORMAL;
@@ -2400,7 +2444,7 @@ Perl_yylex(pTHX)
     s = PL_bufptr;
     PL_oldoldbufptr = PL_oldbufptr;
     PL_oldbufptr = s;
-    DEBUG_p( {
+    DEBUG_T( {
        PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
                      exp_name[PL_expect], s);
     } )
@@ -2420,6 +2464,9 @@ Perl_yylex(pTHX)
            PL_last_lop = 0;
            if (PL_lex_brackets)
                yyerror("Missing right curly or square bracket");
+            DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### Tokener got EOF\n");
+            } )
            TOKEN(0);
        }
        if (s++ < PL_bufend)
@@ -2485,8 +2532,32 @@ Perl_yylex(pTHX)
            goto retry;
        }
        do {
-           bool bof;
-           bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
+           bof = PL_rsfp ? TRUE : FALSE;
+           if (bof) {
+#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
+#ifdef FTELL_FOR_PIPE_IS_BROKEN
+               /* This loses the possibility to detect the bof
+                * situation on perl -P when the libc5 is being used.
+                * Workaround?  Maybe attach some extra state to PL_rsfp?
+                */
+               if (!PL_preprocess)
+                   bof = PerlIO_tell(PL_rsfp) == 0;
+#else
+               bof = PerlIO_tell(PL_rsfp) == 0;
+#endif
+           }
            s = filter_gets(PL_linestr, PL_rsfp, 0);
            if (s == Nullch) {
              fake_eof:
@@ -2526,7 +2597,7 @@ Perl_yylex(pTHX)
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
                    PL_doextract = FALSE;
                }
-           } 
+           }
            incline(s);
        } while (PL_doextract);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -2651,7 +2722,7 @@ Perl_yylex(pTHX)
                    else
                        newargv = PL_origargv;
                    newargv[0] = ipath;
-                   PerlProc_execv(ipath, newargv);
+                   PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
                    Perl_croak(aTHX_ "Can't exec %s", ipath);
                }
 #endif
@@ -2699,7 +2770,7 @@ Perl_yylex(pTHX)
     case '\r':
 #ifdef PERL_STRICT_CR
        Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
-       Perl_croak(aTHX_ 
+       Perl_croak(aTHX_
       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
 #endif
     case ' ': case '\t': case '\f': case 013:
@@ -2735,6 +2806,8 @@ Perl_yylex(pTHX)
        goto retry;
     case '-':
        if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+           I32 ftst = 0;
+
            s++;
            PL_bufptr = s;
            tmp = *s++;
@@ -2744,42 +2817,64 @@ Perl_yylex(pTHX)
 
            if (strnEQ(s,"=>",2)) {
                s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+                DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                            "### Saw unary minus before =>, forcing word '%s'\n", s);
+                } )
                OPERATOR('-');          /* unary minus */
            }
            PL_last_uni = PL_oldbufptr;
-           PL_last_lop_op = OP_FTEREAD;        /* good enough */
            switch (tmp) {
-           case 'r': FTST(OP_FTEREAD);
-           case 'w': FTST(OP_FTEWRITE);
-           case 'x': FTST(OP_FTEEXEC);
-           case 'o': FTST(OP_FTEOWNED);
-           case 'R': FTST(OP_FTRREAD);
-           case 'W': FTST(OP_FTRWRITE);
-           case 'X': FTST(OP_FTREXEC);
-           case 'O': FTST(OP_FTROWNED);
-           case 'e': FTST(OP_FTIS);
-           case 'z': FTST(OP_FTZERO);
-           case 's': FTST(OP_FTSIZE);
-           case 'f': FTST(OP_FTFILE);
-           case 'd': FTST(OP_FTDIR);
-           case 'l': FTST(OP_FTLINK);
-           case 'p': FTST(OP_FTPIPE);
-           case 'S': FTST(OP_FTSOCK);
-           case 'u': FTST(OP_FTSUID);
-           case 'g': FTST(OP_FTSGID);
-           case 'k': FTST(OP_FTSVTX);
-           case 'b': FTST(OP_FTBLK);
-           case 'c': FTST(OP_FTCHR);
-           case 't': FTST(OP_FTTTY);
-           case 'T': FTST(OP_FTTEXT);
-           case 'B': FTST(OP_FTBINARY);
-           case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
-           case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
-           case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+           case 'r': ftst = OP_FTEREAD;        break;
+           case 'w': ftst = OP_FTEWRITE;       break;
+           case 'x': ftst = OP_FTEEXEC;        break;
+           case 'o': ftst = OP_FTEOWNED;       break;
+           case 'R': ftst = OP_FTRREAD;        break;
+           case 'W': ftst = OP_FTRWRITE;       break;
+           case 'X': ftst = OP_FTREXEC;        break;
+           case 'O': ftst = OP_FTROWNED;       break;
+           case 'e': ftst = OP_FTIS;           break;
+           case 'z': ftst = OP_FTZERO;         break;
+           case 's': ftst = OP_FTSIZE;         break;
+           case 'f': ftst = OP_FTFILE;         break;
+           case 'd': ftst = OP_FTDIR;          break;
+           case 'l': ftst = OP_FTLINK;         break;
+           case 'p': ftst = OP_FTPIPE;         break;
+           case 'S': ftst = OP_FTSOCK;         break;
+           case 'u': ftst = OP_FTSUID;         break;
+           case 'g': ftst = OP_FTSGID;         break;
+           case 'k': ftst = OP_FTSVTX;         break;
+           case 'b': ftst = OP_FTBLK;          break;
+           case 'c': ftst = OP_FTCHR;          break;
+           case 't': ftst = OP_FTTTY;          break;
+           case 'T': ftst = OP_FTTEXT;         break;
+           case 'B': ftst = OP_FTBINARY;       break;
+           case 'M': case 'A': case 'C':
+               gv_fetchpv("\024",TRUE, SVt_PV);
+               switch (tmp) {
+               case 'M': ftst = OP_FTMTIME;    break;
+               case 'A': ftst = OP_FTATIME;    break;
+               case 'C': ftst = OP_FTCTIME;    break;
+               default:                        break;
+               }
+               break;
            default:
-               Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
                break;
            }
+           if (ftst) {
+               PL_last_lop_op = ftst;
+               DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### Saw file test %c\n", ftst);
+               } )
+               FTST(ftst);
+           }
+           else {
+               /* Assume it was a minus followed by a one-letter named
+                * subroutine call (or a -bareword), then. */
+               DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### %c looked like a file test but was not\n", ftst);
+               } )
+               s -= 2;
+           }
        }
        tmp = *s++;
        if (*s == tmp) {
@@ -3040,6 +3135,9 @@ Perl_yylex(pTHX)
                if (*d == '}') {
                    char minus = (PL_tokenbuf[0] == '-');
                    s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
+                   if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, 0) &&
+                       PL_nextval[PL_nexttoke-1].opval)
+                     SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke-1].opval)->op_sv);
                    if (minus)
                        force_next('-');
                }
@@ -3477,8 +3575,8 @@ Perl_yylex(pTHX)
     case '?':                  /* may either be conditional or pattern */
        if (PL_expect != XOPERATOR) {
            /* Disable warning on "study /blah/" */
-           if (PL_oldoldbufptr == PL_last_uni 
-               && (*PL_last_uni != 's' || s - PL_last_uni < 5 
+           if (PL_oldoldbufptr == PL_last_uni
+               && (*PL_last_uni != 's' || s - PL_last_uni < 5
                    || memNE(PL_last_uni, "study", 5)
                    || isALNUM_lazy_if(PL_last_uni+5,UTF)))
                check_uni();
@@ -3522,13 +3620,19 @@ Perl_yylex(pTHX)
        /* FALL THROUGH */
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
-       s = scan_num(s);
+       s = scan_num(s, &yylval);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                    "### Saw number in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR)
            no_op("Number",s);
        TERM(THING);
 
     case '\'':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                    "### Saw string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3545,6 +3649,9 @@ Perl_yylex(pTHX)
 
     case '"':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                    "### Saw string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR) {
            if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
                PL_expect = XTERM;
@@ -3558,7 +3665,7 @@ Perl_yylex(pTHX)
            missingterm((char*)0);
        yylval.ival = OP_CONST;
        for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
-           if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
+           if (*d == '$' || *d == '@' || *d == '\\' || UTF8_IS_CONTINUED(*d)) {
                yylval.ival = OP_STRINGIFY;
                break;
            }
@@ -3567,6 +3674,9 @@ Perl_yylex(pTHX)
 
     case '`':
        s = scan_str(s,FALSE,FALSE);
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                    "### Saw backtick string in '%s'\n", s);
+        } )
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
        if (!s)
@@ -3592,7 +3702,7 @@ Perl_yylex(pTHX)
            while (isDIGIT(*start) || *start == '_')
                start++;
            if (*start == '.' && isDIGIT(start[1])) {
-               s = scan_num(s);
+               s = scan_num(s, &yylval);
                TERM(THING);
            }
            /* avoid v123abc() or $h{v1}, allow C<print v10;> */
@@ -3603,7 +3713,7 @@ Perl_yylex(pTHX)
                gv = gv_fetchpv(s, FALSE, SVt_PVCV);
                *start = c;
                if (!gv) {
-                   s = scan_num(s);
+                   s = scan_num(s, &yylval);
                    TERM(THING);
                }
            }
@@ -3682,6 +3792,8 @@ Perl_yylex(pTHX)
            CLINE;
            yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
            yylval.opval->op_private = OPpCONST_BARE;
+           if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+             SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
            TERM(WORD);
        }
 
@@ -3766,7 +3878,7 @@ Perl_yylex(pTHX)
                    PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
                {
                    if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
-                       Perl_warner(aTHX_ WARN_BAREWORD, 
+                       Perl_warner(aTHX_ WARN_BAREWORD,
                            "Bareword \"%s\" refers to nonexistent package",
                             PL_tokenbuf);
                    len -= 2;
@@ -3823,10 +3935,10 @@ Perl_yylex(pTHX)
                    /* If not a declared subroutine, it's an indirect object. */
                    /* (But it's an indir obj regardless for sort.) */
 
-                   if ((PL_last_lop_op == OP_SORT ||
-                         (!immediate_paren && (!gv || !GvCVu(gv)))) &&
+                   if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
+                         ((!gv || !GvCVu(gv)) &&
                         (PL_last_lop_op != OP_MAPSTART &&
-                        PL_last_lop_op != OP_GREPSTART))
+                        PL_last_lop_op != OP_GREPSTART))))
                    {
                        PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
                        goto bareword;
@@ -3841,6 +3953,8 @@ Perl_yylex(pTHX)
                if (*s == '=' && s[1] == '>') {
                    CLINE;
                    sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+                   if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len))
+                     SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
                    TERM(WORD);
                }
 
@@ -4012,6 +4126,10 @@ Perl_yylex(pTHX)
                    }
                }
 #endif
+#ifdef PERLIO_LAYERS
+               if (UTF && !IN_BYTE)
+                   PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+#endif
                PL_rsfp = Nullfp;
            }
            goto fake_eof;
@@ -4162,7 +4280,7 @@ Perl_yylex(pTHX)
 
        case KEY_exists:
            UNI(OP_EXISTS);
-           
+       
        case KEY_exit:
            UNI(OP_EXIT);
 
@@ -4366,7 +4484,7 @@ Perl_yylex(pTHX)
        case KEY_last:
            s = force_word(s,WORD,TRUE,FALSE,FALSE);
            LOOPX(OP_LAST);
-           
+       
        case KEY_lc:
            UNI(OP_LC);
 
@@ -4511,7 +4629,7 @@ Perl_yylex(pTHX)
 
        case KEY_pos:
            UNI(OP_POS);
-           
+       
        case KEY_pack:
            LOP(OP_PACK,XTERM);
 
@@ -4542,6 +4660,7 @@ Perl_yylex(pTHX)
                int warned = 0;
                d = SvPV_force(PL_lex_stuff, len);
                while (len) {
+                   SV *sv;
                    for (; isSPACE(*d) && len; --len, ++d) ;
                    if (len) {
                        char *b = d;
@@ -4562,8 +4681,11 @@ Perl_yylex(pTHX)
                        else {
                            for (; !isSPACE(*d) && len; --len, ++d) ;
                        }
+                       sv = newSVpvn(b, d-b);
+                       if (DO_UTF8(PL_lex_stuff))
+                           SvUTF8_on(sv);
                        words = append_elem(OP_LIST, words,
-                                           newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
+                                           newSVOP(OP_CONST, 0, tokeq(sv)));
                    }
                }
                if (words) {
@@ -4673,7 +4795,7 @@ Perl_yylex(pTHX)
 
        case KEY_chomp:
            UNI(OP_CHOMP);
-           
+       
        case KEY_scalar:
            UNI(OP_SCALAR);
 
@@ -4962,7 +5084,7 @@ Perl_yylex(pTHX)
        case KEY_umask:
            if (ckWARN(WARN_UMASK)) {
                for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
-               if (*d != '0' && isDIGIT(*d)) 
+               if (*d != '0' && isDIGIT(*d))
                    Perl_warner(aTHX_ WARN_UMASK,
                                "umask: argument is missing initial 0");
            }
@@ -5017,7 +5139,7 @@ Perl_yylex(pTHX)
        {
            static char ctl_l[2];
 
-           if (ctl_l[0] == '\0') 
+           if (ctl_l[0] == '\0')
                ctl_l[0] = toCTRL('L');
            gv_fetchpv(ctl_l,TRUE, SVt_PV);
        }
@@ -5163,7 +5285,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
            if (strEQ(d,"exit"))                return -KEY_exit;
            if (strEQ(d,"eval"))                return KEY_eval;
            if (strEQ(d,"exec"))                return -KEY_exec;
-           if (strEQ(d,"each"))                return KEY_each;
+           if (strEQ(d,"each"))                return -KEY_each;
            break;
        case 5:
            if (strEQ(d,"elsif"))               return KEY_elsif;
@@ -5307,7 +5429,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
        break;
     case 'k':
        if (len == 4) {
-           if (strEQ(d,"keys"))                return KEY_keys;
+           if (strEQ(d,"keys"))                return -KEY_keys;
            if (strEQ(d,"kill"))                return -KEY_kill;
        }
        break;
@@ -5389,11 +5511,11 @@ Perl_keyword(pTHX_ register char *d, I32 len)
     case 'p':
        switch (len) {
        case 3:
-           if (strEQ(d,"pop"))                 return KEY_pop;
+           if (strEQ(d,"pop"))                 return -KEY_pop;
            if (strEQ(d,"pos"))                 return KEY_pos;
            break;
        case 4:
-           if (strEQ(d,"push"))                return KEY_push;
+           if (strEQ(d,"push"))                return -KEY_push;
            if (strEQ(d,"pack"))                return -KEY_pack;
            if (strEQ(d,"pipe"))                return -KEY_pipe;
            break;
@@ -5500,7 +5622,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
        case 'h':
            switch (len) {
            case 5:
-               if (strEQ(d,"shift"))           return KEY_shift;
+               if (strEQ(d,"shift"))           return -KEY_shift;
                break;
            case 6:
                if (strEQ(d,"shmctl"))          return -KEY_shmctl;
@@ -5529,7 +5651,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
        case 'p':
            if (strEQ(d,"split"))               return KEY_split;
            if (strEQ(d,"sprintf"))             return -KEY_sprintf;
-           if (strEQ(d,"splice"))              return KEY_splice;
+           if (strEQ(d,"splice"))              return -KEY_splice;
            break;
        case 'q':
            if (strEQ(d,"sqrt"))                return -KEY_sqrt;
@@ -5609,7 +5731,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
            if (strEQ(d,"unlink"))              return -KEY_unlink;
            break;
        case 7:
-           if (strEQ(d,"unshift"))             return KEY_unshift;
+           if (strEQ(d,"unshift"))             return -KEY_unshift;
            if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
            break;
        }
@@ -5655,7 +5777,6 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what)
     char *w;
 
     if (*s == ' ' && s[1] == '(') {    /* XXX gotta be a better way */
-       dTHR;                           /* only for ckWARN */
        if (ckWARN(WARN_SYNTAX)) {
            int level = 1;
            for (w = s+2; *w && level; w++) {
@@ -5710,18 +5831,27 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
     SV **cvp;
     SV *cv, *typesv;
     const char *why1, *why2, *why3;
-    
+
     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
        SV *msg;
        
-       why1 = "%^H is not consistent";
        why2 = strEQ(key,"charnames")
-              ? " (missing \"use charnames ...\"?)"
+              ? "(possibly a missing \"use charnames ...\")"
               : "";
-       why3 = "";
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
+                           (type ? type: "undef"), why2);
+
+       /* This is convoluted and evil ("goto considered harmful")
+        * but I do not understand the intricacies of all the different
+        * failure modes of %^H in here.  The goal here is to make
+        * the most probable error message user-friendly. --jhi */
+
+       goto msgdone;
+
     report:
-       msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", 
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
                            (type ? type: "undef"), why1, why2, why3);
+    msgdone:
        yyerror(SvPVX(msg));
        SvREFCNT_dec(msg);
        return sv;
@@ -5741,11 +5871,11 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        typesv = sv_2mortal(newSVpv(type, 0));
     else
        typesv = &PL_sv_undef;
-    
+
     PUSHSTACKi(PERLSI_OVERLOAD);
     ENTER ;
     SAVETMPS;
-    
+
     PUSHMARK(SP) ;
     EXTEND(sp, 3);
     if (pv)
@@ -5755,9 +5885,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        PUSHs(typesv);
     PUTBACK;
     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
-    
+
     SPAGAIN ;
-    
+
     /* Check the eval first */
     if (!PL_in_eval && SvTRUE(ERRSV)) {
        STRLEN n_a;
@@ -5770,12 +5900,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        res = POPs;
        (void)SvREFCNT_inc(res);
     }
-    
+
     PUTBACK ;
     FREETMPS ;
     LEAVE ;
     POPSTACK;
-    
+
     if (!SvOK(res)) {
        why1 = "Call to &{$^H{";
        why2 = key;
@@ -5786,7 +5916,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
 
     return res;
 }
-  
+
 STATIC char *
 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
 {
@@ -5806,9 +5936,9 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag
            *d++ = *s++;
            *d++ = *s++;
        }
-       else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
+       else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
            char *t = s + UTF8SKIP(s);
-           while (*t & 0x80 && is_utf8_mark((U8*)t))
+           while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
                t += UTF8SKIP(t);
            if (d + (t - s) > e)
                Perl_croak(aTHX_ ident_too_long);
@@ -5858,9 +5988,9 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
                *d++ = *s++;
                *d++ = *s++;
            }
-           else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
+           else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
                char *t = s + UTF8SKIP(s);
-               while (*t & 0x80 && is_utf8_mark((U8*)t))
+               while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
                    t += UTF8SKIP(t);
                if (d + (t - s) > e)
                    Perl_croak(aTHX_ ident_too_long);
@@ -5913,7 +6043,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
                e = s;
                while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
                    e += UTF8SKIP(e);
-                   while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
+                   while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
                        e += UTF8SKIP(e);
                }
                Copy(s, d, e - s, char);
@@ -5929,7 +6059,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
            *d = '\0';
            while (s < send && SPACE_OR_TAB(*s)) s++;
            if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
-               dTHR;                   /* only for ckWARN */
                if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
                    const char *brack = *s == '[' ? "[...]" : "{...}";
                    Perl_warner(aTHX_ WARN_AMBIGUOUS,
@@ -5940,8 +6069,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
                PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
                return s;
            }
-       } 
-       /* Handle extended ${^Foo} variables 
+       }
+       /* Handle extended ${^Foo} variables
         * 1999-02-27 mjd-perl-patch@plover.com */
        else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
                 && isALNUM(*s))
@@ -5961,7 +6090,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
            if (funny == '#')
                funny = '@';
            if (PL_lex_state == LEX_NORMAL) {
-               dTHR;                   /* only for ckWARN */
                if (ckWARN(WARN_AMBIGUOUS) &&
                    (keyword(dest, d - dest) || get_cv(dest, FALSE)))
                {
@@ -6150,7 +6278,9 @@ S_scan_trans(pTHX_ char *start)
            squash = OPpTRANS_SQUASH;
        s++;
     }
-    o->op_private = del|squash|complement;
+    o->op_private = del|squash|complement|
+      (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
+      (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
 
     PL_lex_op = o;
     yylval.ival = OP_TRANS;
@@ -6160,7 +6290,6 @@ S_scan_trans(pTHX_ char *start)
 STATIC char *
 S_scan_heredoc(pTHX_ register char *s)
 {
-    dTHR;
     SV *herewas;
     I32 op_type = OP_SCALAR;
     I32 len;
@@ -6345,6 +6474,8 @@ retval:
        Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
     }
     SvREFCNT_dec(herewas);
+    if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
+       SvUTF8_on(tmpstr);
     PL_lex_stuff = tmpstr;
     yylval.ival = op_type;
     return s;
@@ -6495,7 +6626,7 @@ S_scan_inputsymbol(pTHX_ char *start)
    calls scan_str().  s/// makes yylex() call scan_subst() which calls
    scan_str().  tr/// and y/// make yylex() call scan_trans() which
    calls scan_str().
-      
+
    It skips whitespace before the string starts, and treats the first
    character as the delimiter.  If the delimiter is one of ([{< then
    the corresponding "close" character )]}> is used as the closing
@@ -6512,14 +6643,13 @@ S_scan_inputsymbol(pTHX_ char *start)
 STATIC char *
 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 {
-    dTHR;
     SV *sv;                            /* scalar value: string */
     char *tmps;                                /* temp string, used for delimiter matching */
     register char *s = start;          /* current position in the buffer */
     register char term;                        /* terminating character */
     register char *to;                 /* current position in the sv's data */
     I32 brackets = 1;                  /* bracket nesting level */
-    bool has_utf = FALSE;              /* is there any utf8 content? */
+    bool has_utf8 = FALSE;             /* is there any utf8 content? */
 
     /* skip space before the delimiter */
     if (isSPACE(*s))
@@ -6530,8 +6660,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
     /* after skipping whitespace, the next character is the terminator */
     term = *s;
-    if ((term & 0x80) && UTF)
-       has_utf = TRUE;
+    if (UTF8_IS_CONTINUED(term) && UTF)
+       has_utf8 = TRUE;
 
     /* mark where we are */
     PL_multi_start = CopLINE(PL_curcop);
@@ -6577,8 +6707,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
                   have found the terminator */
                else if (*s == term)
                    break;
-               else if (!has_utf && (*s & 0x80) && UTF)
-                   has_utf = TRUE;
+               else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
+                   has_utf8 = TRUE;
                *to = *s;
            }
        }
@@ -6606,8 +6736,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
                    break;
                else if (*s == PL_multi_open)
                    brackets++;
-               else if (!has_utf && (*s & 0x80) && UTF)
-                   has_utf = TRUE;
+               else if (!has_utf8 && UTF8_IS_CONTINUED(*s) && UTF)
+                   has_utf8 = TRUE;
                *to = *s;
            }
        }
@@ -6662,12 +6792,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
        /* having changed the buffer, we must update PL_bufend */
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
     }
-    
+
     /* at this point, we have successfully read the delimited string */
 
     if (keep_delims)
        sv_catpvn(sv, s, 1);
-    if (has_utf)
+    if (has_utf8)
        SvUTF8_on(sv);
     PL_multi_end = CopLINE(PL_curcop);
     s++;
@@ -6681,7 +6811,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
     /* decide whether this is the first or second quoted string we've read
        for this op
     */
-    
+
     if (PL_lex_stuff)
        PL_lex_repl = sv;
     else
@@ -6710,9 +6840,9 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
   try converting the number to an integer and see if it can do so
   without loss of precision.
 */
-  
+
 char *
-Perl_scan_num(pTHX_ char *start)
+Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 {
     register char *s = start;          /* current position in buffer */
     register char *d;                  /* destination in temp buffer */
@@ -6728,7 +6858,7 @@ Perl_scan_num(pTHX_ char *start)
     switch (*s) {
     default:
       Perl_croak(aTHX_ "panic: scan_num");
-      
+
     /* if it starts with a 0, it could be an octal number, a decimal in
        0.13 disguise, or a hexadecimal number, or a binary number. */
     case '0':
@@ -6743,7 +6873,6 @@ Perl_scan_num(pTHX_ char *start)
             we in octal/hex/binary?" indicator to disallow hex characters
             when in octal mode.
           */
-           dTHR;
            NV n = 0.0;
            UV u = 0;
            I32 shift;
@@ -6831,7 +6960,6 @@ Perl_scan_num(pTHX_ char *start)
 
                        if ((x >> shift) != u
                            && !(PL_hints & HINT_NEW_BINARY)) {
-                           dTHR;
                            overflowed = TRUE;
                            n = (NV) u;
                            if (ckWARN_d(WARN_OVERFLOW))
@@ -6863,7 +6991,6 @@ Perl_scan_num(pTHX_ char *start)
          out:
            sv = NEWSV(92,0);
            if (overflowed) {
-               dTHR;
                if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
                    Perl_warner(aTHX_ WARN_PORTABLE,
                                "%s number > %s non-portable",
@@ -6872,7 +6999,6 @@ Perl_scan_num(pTHX_ char *start)
            }
            else {
 #if UVSIZE > 4
-               dTHR;
                if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
                    Perl_warner(aTHX_ WARN_PORTABLE,
                                "%s number > %s non-portable",
@@ -6898,11 +7024,10 @@ Perl_scan_num(pTHX_ char *start)
 
        /* read next group of digits and _ and copy into d */
        while (isDIGIT(*s) || *s == '_') {
-           /* skip underscores, checking for misplaced ones 
+           /* skip underscores, checking for misplaced ones
               if -w is on
            */
            if (*s == '_') {
-               dTHR;                   /* only for ckWARN */
                if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
                    Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
                lastub = ++s;
@@ -6918,7 +7043,6 @@ Perl_scan_num(pTHX_ char *start)
 
        /* final misplaced underbar check */
        if (lastub && s - lastub != 3) {
-           dTHR;
            if (ckWARN(WARN_SYNTAX))
                Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
        }
@@ -7027,7 +7151,7 @@ Perl_scan_num(pTHX_ char *start)
           compilers have issues.  Then we try casting it back and see
           if it was the same [1].  We only do this if we know we
           specifically read an integer.  If floatit is true, then we
-          don't need to do the conversion at all. 
+          don't need to do the conversion at all.
 
           [1] Note that this is lossy if our NVs cannot preserve our
           UVs.  There are metaconfig defines NV_PRESERVES_UV (a boolean)
@@ -7038,7 +7162,7 @@ Perl_scan_num(pTHX_ char *start)
           Maybe could do some tricks with DBL_DIG, LDBL_DIG and
           DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
           as NV_DIG and NV_MANT_DIG)?
-          
+       
           --jhi
           */
        {
@@ -7055,7 +7179,7 @@ Perl_scan_num(pTHX_ char *start)
 #endif
        if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
                       (PL_hints & HINT_NEW_INTEGER) )
-           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, 
+           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
                              (floatit ? "float" : "integer"),
                              sv, Nullsv, NULL);
        break;
@@ -7070,7 +7194,7 @@ vstring:
                pos++;
            if (!isALPHA(*pos)) {
                UV rev;
-               U8 tmpbuf[UTF8_MAXLEN];
+               U8 tmpbuf[UTF8_MAXLEN+1];
                U8 *tmpend;
                bool utf8 = FALSE;
                s++;                            /* get past 'v' */
@@ -7115,7 +7239,8 @@ vstring:
                SvREADONLY_on(sv);
                if (utf8) {
                    SvUTF8_on(sv);
-                   sv_utf8_downgrade(sv, TRUE);
+                   if (!UTF||IN_BYTE)
+                     sv_utf8_downgrade(sv, TRUE);
                }
            }
        }
@@ -7125,9 +7250,9 @@ vstring:
     /* make the op for the constant and return */
 
     if (sv)
-       yylval.opval = newSVOP(OP_CONST, 0, sv);
+       lvalp->opval = newSVOP(OP_CONST, 0, sv);
     else
-       yylval.opval = Nullop;
+       lvalp->opval = Nullop;
 
     return s;
 }
@@ -7135,7 +7260,6 @@ vstring:
 STATIC char *
 S_scan_formline(pTHX_ register char *s)
 {
-    dTHR;
     register char *eol;
     register char *t;
     SV *stuff = newSVpvn("",0);
@@ -7226,7 +7350,6 @@ S_set_csh(pTHX)
 I32
 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
 {
-    dTHR;
     I32 oldsavestack_ix = PL_savestack_ix;
     CV* outsidecv = PL_compcv;
     AV* comppadlist;
@@ -7282,7 +7405,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
 int
 Perl_yywarn(pTHX_ char *s)
 {
-    dTHR;
     PL_in_eval |= EVAL_WARNONLY;
     yyerror(s);
     PL_in_eval &= ~EVAL_WARNONLY;
@@ -7292,7 +7414,6 @@ Perl_yywarn(pTHX_ char *s)
 int
 Perl_yyerror(pTHX_ char *s)
 {
-    dTHR;
     char *where = NULL;
     char *context = NULL;
     int contlen = -1;
@@ -7376,8 +7497,8 @@ S_swallow_bom(pTHX_ U8 *s)
     STRLEN slen;
     slen = SvCUR(PL_linestr);
     switch (*s) {
-    case 0xFF:       
-       if (s[1] == 0xFE) { 
+    case 0xFF:
+       if (s[1] == 0xFE) {
            /* UTF-16 little-endian */
            if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
                Perl_croak(aTHX_ "Unsupported script encoding");
@@ -7479,7 +7600,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
        if (!*SvPV_nolen(sv))
        /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
        return count;
-       
+
        tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
        sv_usepvn(sv, (char*)tmps, tend - tmps);
     }
index 96d3264..9a21350 100644 (file)
--- a/uconfig.h
+++ b/uconfig.h
  */
 /*#define HAS_STRTOL   / **/
 
-/* 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_STRXFRM:
  *     This symbol, if defined, indicates that the strxfrm() routine is
  *     available to transform strings.
  */
 #define SH_PATH ""  /**/
 
-/* 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   /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
  *     This symbol contains the ~name expanded version of ARCHLIB, to be used
  *     in programs that are not prepared to deal with ~ expansion at run-time.
  */
-/*#define ARCHLIB "/usr/local/lib/perl5/5.6/unknown"           / **/
-/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.6/unknown"               / **/
+/*#define ARCHLIB "/usr/local/lib/perl5/5.7/unknown"           / **/
+/*#define ARCHLIB_EXP "/usr/local/lib/perl5/5.7/unknown"               / **/
 
 /* ARCHNAME:
  *     This symbol holds a string representing the architecture name.
 #define CPPRUN ""
 #define CPPLAST ""
 
+/* 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_ACCESS:
  *     This manifest constant lets the C program know that the access()
  *     system call is available to check for accessibility using real UID/GID.
  */
 /*#define HAS_ENDSERVENT               / **/
 
+/* 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_FD_SET:
  *     This symbol, when defined, indicates presence of the fd_set typedef
  *     in <sys/types.h>
  */
 /*#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_GETNET_PROTOS       / **/
 
+/* 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_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.
  */
 /*#define HAS_SANE_MEMCMP      / **/
 
+/* 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_SEM:
  *     This symbol, if defined, indicates that the entire sem*(2) library is
  *     supported.
  */
 /*#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_SETPROCTITLE:
  *     This symbol, if defined, indicates that the setproctitle routine is
  *     available to set process title.
  *     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)->_IO_read_ptr)
 /*#define STDIO_PTR_LVALUE             / **/
 #define FILE_cnt(fp)   ((fp)->_IO_read_end - (fp)->_IO_read_ptr)
 /*#define STDIO_CNT_LVALUE             / **/
+/*#define STDIO_PTR_LVAL_SETS_CNT      / **/
+/*#define STDIO_PTR_LVAL_NOCHANGE_CNT  / **/
 #endif
 
 /* USE_STDIO_BASE:
  */
 /*#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_STRTOUL:
+ *     This symbol, if defined, indicates that the strtoul routine is
+ *     available to provide conversion of strings to unsigned long.
+ */
+/*#define HAS_STRTOUL  / **/
+
 /* HAS_STRTOULL:
  *     This symbol, if defined, indicates that the strtoull routine is
  *     available to convert strings to unsigned long longs.
 #define RD_NODATA -1
 #undef EOF_NONBLOCK
 
+/* 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            / **/
+
 /* Netdb_host_t:
  *     This symbol holds the type used for the 1st argument
  *     to gethostbyaddr().
 #endif
 #define        NVSIZE          8               /**/
 #undef NV_PRESERVES_UV
-#define        NV_PRESERVES_UV_BITS    
+#define        NV_PRESERVES_UV_BITS    0
 
 /* IVdf:
  *     This symbol defines the format string used for printing a Perl IV
  *     This symbol contains the ~name expanded version of PRIVLIB, to be used
  *     in programs that are not prepared to deal with ~ expansion at run-time.
  */
-#define PRIVLIB "/usr/local/lib/perl5/5.6"             /**/
-#define PRIVLIB_EXP "/usr/local/lib/perl5/5.6"         /**/
+#define PRIVLIB "/usr/local/lib/perl5/5.7"             /**/
+#define PRIVLIB_EXP "/usr/local/lib/perl5/5.7"         /**/
 
 /* PTRSIZE:
  *     This symbol contains the size of a pointer, so that the C preprocessor
  */
 #define STARTPERL ""           /**/
 
+/* 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   /**/
+
 /* HAS_STDIO_STREAM_ARRAY:
  *     This symbol, if defined, tells that there is an array
  *     holding the stdio streams.
 #define PERL_XS_APIVERSION "5.005"
 #define PERL_PM_APIVERSION "5.005"
 
-/* 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_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      / **/
-
 #endif
index faf618a..f6d64ae 100755 (executable)
@@ -4,8 +4,8 @@ _o='.o'
 afs='false'
 alignbytes='4'
 apiversion='5.005'
-archlib='/usr/local/lib/perl5/5.6/unknown'
-archlibexp='/usr/local/lib/perl5/5.6/unknown'
+archlib='/usr/local/lib/perl5/5.7/unknown'
+archlibexp='/usr/local/lib/perl5/5.7/unknown'
 archname='unknown'
 bin='/usr/local/bin'
 bincompat5005='define'
@@ -16,7 +16,6 @@ clocktype='clock_t'
 cpp_stuff='42'
 crosscompile='undef'
 d_Gconvert='sprintf((b),"%.*g",(n),(x))'
-d_SCNfldbl='undef'
 d_PRIEUldbl='undef'
 d_PRIFUldbl='undef'
 d_PRIGUldbl='undef'
@@ -29,6 +28,8 @@ d_PRIi64='undef'
 d_PRIo64='undef'
 d_PRIu64='undef'
 d_PRIx64='undef'
+d_SCNfldbl='undef'
+d__fwalk='undef'
 d_access='undef'
 d_accessx='undef'
 d_alarm='undef'
@@ -70,12 +71,12 @@ d_endnent='undef'
 d_endpent='undef'
 d_endpwent='undef'
 d_endsent='undef'
-d_endspent='undef'
 d_eofnblk='undef'
 d_eunice='undef'
 d_fchmod='undef'
 d_fchown='undef'
 d_fcntl='undef'
+d_fcntl_can_lock='undef'
 d_fd_macros='undef'
 d_fd_set='undef'
 d_fds_bits='undef'
@@ -85,14 +86,18 @@ d_flock='undef'
 d_fork='define'
 d_fpathconf='undef'
 d_fpos64_t='undef'
+d_frexpl='undef'
 d_fs_data_s='undef'
 d_fseeko='undef'
 d_fsetpos='undef'
 d_fstatfs='undef'
 d_fstatvfs='undef'
+d_fsync='undef'
 d_ftello='undef'
 d_ftime='undef'
 d_getcwd='undef'
+d_getespwnam='undef'
+d_getfsstat='undef'
 d_getgrent='undef'
 d_getgrps='undef'
 d_gethbyaddr='undef'
@@ -107,6 +112,7 @@ d_getnbyaddr='undef'
 d_getnbyname='undef'
 d_getnent='undef'
 d_getnetprotos='undef'
+d_getpagsz='undef'
 d_getpbyname='undef'
 d_getpbynumber='undef'
 d_getpent='undef'
@@ -116,6 +122,7 @@ d_getpgrp='undef'
 d_getppid='undef'
 d_getprior='undef'
 d_getprotoprotos='undef'
+d_getprpwnam='undef'
 d_getpwent='undef'
 d_getsbyname='undef'
 d_getsbyport='undef'
@@ -131,8 +138,10 @@ d_htonl='undef'
 d_iconv='undef'
 d_index='undef'
 d_inetaton='undef'
-d_int64t='undef'
+d_int64_t='undef'
 d_isascii='undef'
+d_isnan='undef'
+d_isnanl='undef'
 d_killpg='undef'
 d_lchown='undef'
 d_ldbl_dig='undef'
@@ -141,7 +150,9 @@ d_locconv='undef'
 d_lockf='undef'
 d_longdbl='undef'
 d_longlong='undef'
+d_lseekproto='undef'
 d_lstat='undef'
+d_madvise='undef'
 d_mblen='undef'
 d_mbstowcs='undef'
 d_mbtowc='undef'
@@ -156,6 +167,8 @@ d_mkfifo='undef'
 d_mkstemp='undef'
 d_mkstemps='undef'
 d_mktime='undef'
+d_mmap='undef'
+d_modfl='undef'
 d_mprotect='undef'
 d_msg='undef'
 d_msg_ctrunc='undef'
@@ -172,6 +185,7 @@ d_munmap='undef'
 d_mymalloc='undef'
 d_nice='undef'
 d_nv_preserves_uv='undef'
+d_nv_preserves_uv_bits='0'
 d_off64_t='undef'
 d_old_pthread_create_joinable='undef'
 d_oldpthreads='undef'
@@ -179,6 +193,7 @@ d_oldsock='undef'
 d_open3='undef'
 d_pathconf='undef'
 d_pause='undef'
+d_perl_otherlibdirs='undef'
 d_phostname='undef'
 d_pipe='undef'
 d_poll='undef'
@@ -192,6 +207,7 @@ d_pwexpire='undef'
 d_pwgecos='undef'
 d_pwpasswd='undef'
 d_pwquota='undef'
+d_qgcvt='undef'
 d_quad='undef'
 d_readdir='undef'
 d_readlink='undef'
@@ -201,6 +217,7 @@ d_rmdir='undef'
 d_safebcpy='undef'
 d_safemcpy='undef'
 d_sanemcmp='undef'
+d_sbrkproto='undef'
 d_sched_yield='undef'
 d_scm_rights='undef'
 d_seekdir='undef'
@@ -234,7 +251,6 @@ d_setrgid='undef'
 d_setruid='undef'
 d_setsent='undef'
 d_setsid='undef'
-d_setspent='undef'
 d_setvbuf='undef'
 d_sfio='undef'
 d_shm='undef'
@@ -246,6 +262,7 @@ d_shmget='undef'
 d_sigaction='undef'
 d_sigsetjmp='undef'
 d_socket='undef'
+d_socklen_t='undef'
 d_sockpair='undef'
 d_socks5_init='undef'
 d_sqrtl='undef'
@@ -255,6 +272,8 @@ d_statfs_s='undef'
 d_statvfs='undef'
 d_stdio_cnt_lval='undef'
 d_stdio_ptr_lval='undef'
+d_stdio_ptr_lval_nochange_cnt='undef'
+d_stdio_ptr_lval_sets_cnt='undef'
 d_stdio_stream_array='undef'
 d_stdiobase='undef'
 d_stdstdio='undef'
@@ -267,6 +286,7 @@ d_strtod='undef'
 d_strtol='undef'
 d_strtold='undef'
 d_strtoll='undef'
+d_strtoq='undef'
 d_strtoul='undef'
 d_strtoull='undef'
 d_strtouq='undef'
@@ -290,6 +310,7 @@ d_umask='undef'
 d_uname='undef'
 d_union_semun='undef'
 d_ustat='undef'
+d_vendorarch='undef'
 d_vendorbin='undef'
 d_vendorlib='undef'
 d_vfork='undef'
@@ -344,6 +365,7 @@ i_float='undef'
 i_gdbm='undef'
 i_grp='undef'
 i_iconv='undef'
+i_ieeefp='undef'
 i_inttypes='undef'
 i_libutil='undef'
 i_limits='undef'
@@ -359,6 +381,7 @@ i_neterrno='undef'
 i_netinettcp='undef'
 i_niin='undef'
 i_poll='undef'
+i_prot='undef'
 i_pthread='undef'
 i_pwd='undef'
 i_rpcsvcdbm='undef'
@@ -370,6 +393,7 @@ i_stdarg='define'
 i_stddef='undef'
 i_stdlib='undef'
 i_string='define'
+i_sunmath='undef'
 i_sysaccess='undef'
 i_sysdir='undef'
 i_sysfile='undef'
@@ -377,6 +401,8 @@ i_sysfilio='undef'
 i_sysin='undef'
 i_sysioctl='undef'
 i_syslog='undef'
+i_sysmman='undef'
+i_sysmode='undef'
 i_sysmount='undef'
 i_sysndir='undef'
 i_sysparam='undef'
@@ -393,6 +419,7 @@ i_systimes='undef'
 i_systypes='undef'
 i_sysuio='undef'
 i_sysun='undef'
+i_sysutsname='undef'
 i_sysvfs='undef'
 i_syswait='undef'
 i_termio='undef'
@@ -406,6 +433,7 @@ i_varargs='undef'
 i_varhdr='stdarg.h'
 i_vfork='undef'
 ignore_versioned_solibs='y'
+inc_version_list_init='NULL'
 installstyle='lib/perl5'
 installusrbinperl='undef'
 intsize='4'
@@ -426,6 +454,7 @@ modetype=int
 multiarch='undef'
 myarchname='unknown'
 myuname='unknown'
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='const char *'
 netdb_name_type='const char *'
@@ -444,8 +473,8 @@ osname='unknown'
 phostname='hostname'
 pidtype=int
 pm_apiversion='5.005'
-privlib='/usr/local/lib/perl5/5.6'
-privlibexp='/usr/local/lib/perl5/5.6'
+privlib='/usr/local/lib/perl5/5.7'
+privlibexp='/usr/local/lib/perl5/5.7'
 prototype='undef'
 ptrsize=1
 quadkind='4'
@@ -466,6 +495,7 @@ sPRIi64='"Li"'
 sPRIo64='"Lo"'
 sPRIu64='"Lu"'
 sPRIx64='"Lx"'
+sSCNfldbl='"llf"'
 sched_yield='sched_yield()'
 scriptdir='/usr/local/bin'
 scriptdirexp='/usr/local/bin'
@@ -478,9 +508,9 @@ sig_count='64'
 sig_name_init='0'
 sig_num_init='0'
 signal_t=int
-sizetype=int
 sizesize=1
-sSCNfldbl='"llf"'
+sizetype=int
+socksizetype='int'
 ssizetype=int
 stdchar=char
 stdio_base='((fp)->_IO_read_base)'
@@ -505,12 +535,12 @@ uidsize='4'
 uidtype=int
 uquadtype='uint64_t'
 use5005threads='undef'
-use64bits='undef'
+use64bitall='undef'
+use64bitint='undef'
 usedl='undef'
 useithreads='undef'
 uselargefiles='undef'
 uselongdouble='undef'
-uselonglong='undef'
 usemorebits='undef'
 usemultiplicity='undef'
 usemymalloc='n'
@@ -532,28 +562,3 @@ uvxformat='"lx"'
 versiononly='undef'
 voidflags=1
 xs_apiversion='5.005'
-d_getfsstat='undef'
-d_int64_t='undef'
-d_lseekproto='undef'
-d_madvise='undef'
-d_mmap='undef'
-use64bitint='undef'
-use64bitall='undef'
-d_vendorarch='undef'
-d_vendorarch='undef'
-i_ieeefp='undef'
-i_sunmath='undef'
-i_sysmode='undef'
-i_sysutsname='undef'
-d_frexpl='undef'
-d_modfl='undef'
-d_getespwnam='undef'
-d_getprpwnam='undef'
-d_isnan='undef'
-d_isnanl='undef'
-i_prot='undef'
-d_perl_otherlibdirs='undef'
-inc_version_list_init='NULL'
-socksizetype='int'
-
-
index 0899b1a..12d31e5 100644 (file)
@@ -74,7 +74,6 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
                SV* sv = *svp++;
                HV* basestash = gv_stashsv(sv, FALSE);
                if (!basestash) {
-                   dTHR;
                    if (ckWARN(WARN_MISC))
                        Perl_warner(aTHX_ WARN_SYNTAX,
                             "Can't locate package %s for @%s::ISA",
index 5815a19..f6923b7 100644 (file)
--- a/unixish.h
+++ b/unixish.h
 #  ifdef POSIX_BC
 #    define PERL_SYS_INIT(c,v) sigignore(SIGFPE); MALLOC_INIT
 #  else
-#    ifdef __CYGWIN__
-#      define PERL_SYS_INIT(c,v) Perl_my_setenv_init(&environ); MALLOC_INIT
-#    else
-#      define PERL_SYS_INIT(c,v) MALLOC_INIT
-#    endif
+#    define PERL_SYS_INIT(c,v) MALLOC_INIT
 #  endif
 #endif
 #endif
diff --git a/utf8.c b/utf8.c
index a713ea1..e82725e 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -1,6 +1,6 @@
 /*    utf8.c
  *
- *    Copyright (c) 1998-2000, Larry Wall
+ *    Copyright (c) 1998-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 /* Unicode support */
 
 U8 *
-Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
+Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
 {
     if (uv < 0x80) {
        *d++ = uv;
+       *d   = 0;
        return d;
     }
     if (uv < 0x800) {
        *d++ = (( uv >>  6)         | 0xc0);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x10000) {
        *d++ = (( uv >> 12)         | 0xe0);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x200000) {
@@ -49,6 +52,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x4000000) {
@@ -57,6 +61,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
     if (uv < 0x80000000) {
@@ -66,10 +71,11 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
-    if (uv < 0x1000000000LL)
+    if (uv < UTF8_QUAD_MAX)
 #endif
     {
        *d++ =                        0xfe;     /* Can't match U+FEFF! */
@@ -79,6 +85,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
@@ -96,6 +103,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
+       *d   = 0;
        return d;
     }
 #endif
@@ -104,27 +112,41 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
 /* Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
  * The actual number of bytes in the UTF-8 character will be returned if it
  * is valid, otherwise 0. */
-int
+STRLEN
 Perl_is_utf8_char(pTHX_ U8 *s)
 {
     U8 u = *s;
-    int slen, len;
+    STRLEN slen, len;
+    UV uv, ouv;
 
-    if (!(u & 0x80))
+    if (UTF8_IS_ASCII(u))
        return 1;
 
-    if (!(u & 0x40))
+    if (!UTF8_IS_START(u))
        return 0;
 
     len = UTF8SKIP(s);
 
+    if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
+       return 0;
+
     slen = len - 1;
     s++;
+    uv = u;
+    ouv = uv;
     while (slen--) {
-       if ((*s & 0xc0) != 0x80)
+       if (!UTF8_IS_CONTINUATION(*s))
            return 0;
+       uv = UTF8_ACCUMULATE(uv, *s);
+       if (uv < ouv)
+           return 0;
+       ouv = uv;
        s++;
     }
+
+    if (UNISKIP(uv) < len)
+       return 0;
+
     return len;
 }
 
@@ -140,138 +162,356 @@ string, false otherwise.
 bool
 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 {
-    U8* x=s;
-    U8* send=s+len;
-    int c;
+    U8* x = s;
+    U8* send;
+    STRLEN c;
+
+    if (!len)
+       len = strlen((char *)s);
+    send = s + len;
+
     while (x < send) {
         c = is_utf8_char(x);
+       if (!c)
+           return FALSE;
         x += c;
-        if (!c || x > send)
-            return 0;
     }
-    return 1;
+    if (x != send)
+       return FALSE;
+
+    return TRUE;
 }
 
 /*
-=for apidoc Am|U8* s|utf8_to_uv_chk|I32 *retlen|I32 checking
+=for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags
 
 Returns the character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
-length, in bytes, of that character, and the pointer C<s> will be
-advanced to the end of the character.
+which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+C<retlen> will be set to the length, in bytes, of that character.
 
 If C<s> does not point to a well-formed UTF8 character, the behaviour
-is dependent on the value of C<checking>: if this is true, it is
-assumed that the caller will raise a warning, and this function will
-set C<retlen> to C<-1> and return. If C<checking> is not true, an optional UTF8
-warning is produced.
+is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
+it is assumed that the caller will raise a warning, and this function
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
 
-=cut
-*/
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
+
+=cut */
 
 UV
-Perl_utf8_to_uv_chk(pTHX_ U8* s, I32* retlen, bool checking)
-{
-    UV uv = *s;
-    int len;
-    if (!(uv & 0x80)) {
-       if (retlen)
-           *retlen = 1;
-       return *s;
+Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
+{
+    UV uv = *s, ouv;
+    STRLEN len = 1;
+#ifdef EBCDIC
+    bool dowarn = 0;
+#else
+    bool dowarn = ckWARN_d(WARN_UTF8);
+#endif
+    STRLEN expectlen = 0;
+    U32 warning = 0;
+
+/* This list is a superset of the UTF8_ALLOW_XXX. */
+
+#define UTF8_WARN_EMPTY                                 1
+#define UTF8_WARN_CONTINUATION                  2
+#define UTF8_WARN_NON_CONTINUATION              3
+#define UTF8_WARN_FE_FF                                 4
+#define UTF8_WARN_SHORT                                 5
+#define UTF8_WARN_OVERFLOW                      6
+#define UTF8_WARN_SURROGATE                     7
+#define UTF8_WARN_BOM                           8
+#define UTF8_WARN_LONG                          9
+#define UTF8_WARN_FFFF                         10
+
+    if (curlen == 0 &&
+       !(flags & UTF8_ALLOW_EMPTY)) {
+       warning = UTF8_WARN_EMPTY;
+       goto malformed;
     }
-    if (!(uv & 0x40)) {
-        dTHR;
-       if (checking && retlen) {
-           *retlen = -1;
-           return 0;
-       }
 
-       if (ckWARN_d(WARN_UTF8))
-           Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
+    if (UTF8_IS_ASCII(uv)) {
        if (retlen)
            *retlen = 1;
        return *s;
     }
 
-    if      (!(uv & 0x20))     { len = 2; uv &= 0x1f; }
-    else if (!(uv & 0x10))     { len = 3; uv &= 0x0f; }
-    else if (!(uv & 0x08))     { len = 4; uv &= 0x07; }
-    else if (!(uv & 0x04))     { len = 5; uv &= 0x03; }
-    else if (!(uv & 0x02))     { len = 6; uv &= 0x01; }
-    else if (!(uv & 0x01))     { len = 7;  uv = 0; }
-    else                       { len = 13; uv = 0; } /* whoa! */
+    if (UTF8_IS_CONTINUATION(uv) &&
+       !(flags & UTF8_ALLOW_CONTINUATION)) {
+       warning = UTF8_WARN_CONTINUATION;
+       goto malformed;
+    }
 
+    if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
+       !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
+       warning = UTF8_WARN_NON_CONTINUATION;
+       goto malformed;
+    }
+    
+    if ((uv == 0xfe || uv == 0xff) &&
+       !(flags & UTF8_ALLOW_FE_FF)) {
+       warning = UTF8_WARN_FE_FF;
+       goto malformed;
+    }
+       
+    if      (!(uv & 0x20))     { len =  2; uv &= 0x1f; }
+    else if (!(uv & 0x10))     { len =  3; uv &= 0x0f; }
+    else if (!(uv & 0x08))     { len =  4; uv &= 0x07; }
+    else if (!(uv & 0x04))     { len =  5; uv &= 0x03; }
+    else if (!(uv & 0x02))     { len =  6; uv &= 0x01; }
+    else if (!(uv & 0x01))     { len =  7; uv = 0; }
+    else                       { len = 13; uv = 0; } /* whoa! */
+       
     if (retlen)
        *retlen = len;
-    --len;
+    
+    expectlen = len;
+
+    if ((curlen < expectlen) &&
+       !(flags & UTF8_ALLOW_SHORT)) {
+       warning = UTF8_WARN_SHORT;
+       goto malformed;
+    }
+
+    len--;
     s++;
+    ouv = uv;
+
     while (len--) {
-       if ((*s & 0xc0) != 0x80) {
-            dTHR;
-           if (checking && retlen) {
-               *retlen = -1;
-               return 0;
-            }
-
-           if (ckWARN_d(WARN_UTF8))
-               Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
-           if (retlen)
-               *retlen -= len + 1;
-           return 0xfffd;
+       if (!UTF8_IS_CONTINUATION(*s) &&
+           !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
+           s--;
+           warning = UTF8_WARN_NON_CONTINUATION;
+           goto malformed;
        }
        else
-           uv = (uv << 6) | (*s++ & 0x3f);
+           uv = UTF8_ACCUMULATE(uv, *s);
+       if (!(uv > ouv)) {
+           /* These cannot be allowed. */
+           if (uv == ouv) {
+               if (!(flags & UTF8_ALLOW_LONG)) {
+                   warning = UTF8_WARN_LONG;
+                   goto malformed;
+               }
+           }
+           else { /* uv < ouv */
+               /* This cannot be allowed. */
+               warning = UTF8_WARN_OVERFLOW;
+               goto malformed;
+           }
+       }
+       s++;
+       ouv = uv;
     }
+
+    if (UNICODE_IS_SURROGATE(uv) &&
+       !(flags & UTF8_ALLOW_SURROGATE)) {
+       warning = UTF8_WARN_SURROGATE;
+       goto malformed;
+    } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
+              !(flags & UTF8_ALLOW_BOM)) {
+       warning = UTF8_WARN_BOM;
+       goto malformed;
+    } else if ((expectlen > UNISKIP(uv)) &&
+              !(flags & UTF8_ALLOW_LONG)) {
+       warning = UTF8_WARN_LONG;
+       goto malformed;
+    } else if (UNICODE_IS_ILLEGAL(uv) &&
+              !(flags & UTF8_ALLOW_FFFF)) {
+       warning = UTF8_WARN_FFFF;
+       goto malformed;
+    }
+
     return uv;
+
+malformed:
+
+    if (flags & UTF8_CHECK_ONLY) {
+       if (retlen)
+           *retlen = -1;
+       return 0;
+    }
+
+    if (dowarn) {
+       SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
+
+       switch (warning) {
+       case 0: /* Intentionally empty. */ break;
+       case UTF8_WARN_EMPTY:
+           Perl_sv_catpvf(aTHX_ sv, "(empty string)");
+           break;
+       case UTF8_WARN_CONTINUATION:
+           Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
+           break;
+       case UTF8_WARN_NON_CONTINUATION:
+           Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
+                           (UV)s[1], uv);
+           break;
+       case UTF8_WARN_FE_FF:
+           Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
+           break;
+       case UTF8_WARN_SHORT:
+           Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
+                           curlen, curlen == 1 ? "" : "s", expectlen);
+           break;
+       case UTF8_WARN_OVERFLOW:
+           Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
+                           ouv, *s);
+           break;
+       case UTF8_WARN_SURROGATE:
+           Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
+           break;
+       case UTF8_WARN_BOM:
+           Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
+           break;
+       case UTF8_WARN_LONG:
+           Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
+                          expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
+           break;
+       case UTF8_WARN_FFFF:
+           Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
+           break;
+       default:
+           Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
+           break;
+       }
+       
+       if (warning) {
+           char *s = SvPVX(sv);
+
+           if (PL_op)
+               Perl_warner(aTHX_ WARN_UTF8,
+                           "%s in %s", s,  PL_op_desc[PL_op->op_type]);
+           else
+               Perl_warner(aTHX_ WARN_UTF8, "%s", s);
+       }
+    }
+
+    if (retlen)
+       *retlen = expectlen ? expectlen : len;
+
+    return 0;
 }
 
 /*
-=for apidoc Am|U8* s|utf8_to_uv|I32 *retlen
+=for apidoc Am|U8* s|utf8_to_uv_simple|STRLEN *retlen
 
 Returns the character value of the first character in the string C<s>
 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
-length, in bytes, of that character, and the pointer C<s> will be
-advanced to the end of the character.
+length, in bytes, of that character.
 
-If C<s> does not point to a well-formed UTF8 character, an optional UTF8
-warning is produced.
+If C<s> does not point to a well-formed UTF8 character, zero is
+returned and retlen is set, if possible, to -1.
 
 =cut
 */
 
 UV
-Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
+Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
 {
- return Perl_utf8_to_uv_chk(aTHX_ s, retlen, 0);
+    return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0);
 }
 
-/* utf8_distance(a,b) returns the number of UTF8 characters between
-   the pointers a and b                                                        */
+/*
+=for apidoc Am|STRLEN|utf8_length|U8* s|U8 *e
+
+Return the length of the UTF-8 char encoded string C<s> in characters.
+Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
+up past C<e>, croaks.
+
+=cut
+*/
+
+STRLEN
+Perl_utf8_length(pTHX_ U8* s, U8* e)
+{
+    STRLEN len = 0;
+
+    /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
+    if (e < s)
+       Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
+    while (s < e) {
+       U8 t = UTF8SKIP(s);
+
+       if (e - s < t)
+           Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
+       s += t;
+       len++;
+    }
+
+    return len;
+}
+
+/*
+=for apidoc Am|IV|utf8_distance|U8 *a|U8 *b
+
+Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+and C<b>.
+
+WARNING: use only if you *know* that the pointers point inside the
+same UTF-8 buffer.
+
+=cut */
 
-I32
+IV
 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 {
-    I32 off = 0;
+    IV off = 0;
+
+    /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
     if (a < b) {
        while (a < b) {
-           a += UTF8SKIP(a);
+           U8 c = UTF8SKIP(a);
+
+           if (b - a < c)
+               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           a += c;
            off--;
        }
     }
     else {
        while (b < a) {
-           b += UTF8SKIP(b);
+           U8 c = UTF8SKIP(b);
+
+           if (a - b < c)
+               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           b += c;
            off++;
        }
     }
+
     return off;
 }
 
-/* WARNING: do not use the following unless you *know* off is within bounds */
+/*
+=for apidoc Am|U8*|utf8_hop|U8 *s|I32 off
+
+Return the UTF-8 pointer C<s> displaced by C<off> characters, either
+forward or backward.
+
+WARNING: do not use the following unless you *know* C<off> is within
+the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
+on the first byte of character or just after the last byte of a character.
+
+=cut */
 
 U8 *
 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 {
+    /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
+     * the bitops (especially ~) can create illegal UTF-8.
+     * In other words: in Perl UTF-8 is not just for Unicode. */
+
     if (off >= 0) {
        while (off--)
            s += UTF8SKIP(s);
@@ -279,10 +519,8 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off)
     else {
        while (off++) {
            s--;
-           if (*s & 0x80) {
-               while ((*s & 0xc0) == 0x80)
-                   s--;
-           }
+           while (UTF8_IS_CONTINUATION(*s))
+               s--;
        }
     }
     return s;
@@ -302,32 +540,27 @@ Returns zero on failure, setting C<len> to -1.
 U8 *
 Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
 {
-    dTHR;
     U8 *send;
     U8 *d;
-    U8 *save;
-
-    send = s + *len;
-    d = save = s;
+    U8 *save = s;
 
     /* ensure valid UTF8 and chars < 256 before updating string */
-    while (s < send) {
-       U8 c = *s++;
+    for (send = s + *len; s < send; ) {
+        U8 c = *s++;
+
         if (c >= 0x80 &&
-           ( (s >= send) || ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
-           *len = -1;
-           return 0;
-       }
+            ((s >= send) ||
+            ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
+            *len = -1;
+            return 0;
+        }
     }
-    s = save;
+
+    d = s = save;
     while (s < send) {
-        if (*s < 0x80)
-            *d++ = *s++;
-        else {
-            I32 ulen;
-            *d++ = (U8)utf8_to_uv(s, &ulen);
-            s += ulen;
-        }
+        STRLEN ulen;
+        *d++ = (U8)utf8_to_uv_simple(s, &ulen);
+        s += ulen;
     }
     *d = '\0';
     *len = d - save;
@@ -347,7 +580,6 @@ reflect the new length.
 U8*
 Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
 {
-    dTHR;
     U8 *send;
     U8 *d;
     U8 *dst;
@@ -400,7 +632,6 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
            continue;
        }
        if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
-            dTHR;
            UV low = *p++;
            if (low < 0xdc00 || low >= 0xdfff)
                Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
@@ -445,7 +676,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 bool
 Perl_is_uni_alnum(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnum(tmpbuf);
 }
@@ -453,7 +684,7 @@ Perl_is_uni_alnum(pTHX_ U32 c)
 bool
 Perl_is_uni_alnumc(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnumc(tmpbuf);
 }
@@ -461,7 +692,7 @@ Perl_is_uni_alnumc(pTHX_ U32 c)
 bool
 Perl_is_uni_idfirst(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_idfirst(tmpbuf);
 }
@@ -469,7 +700,7 @@ Perl_is_uni_idfirst(pTHX_ U32 c)
 bool
 Perl_is_uni_alpha(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alpha(tmpbuf);
 }
@@ -477,7 +708,7 @@ Perl_is_uni_alpha(pTHX_ U32 c)
 bool
 Perl_is_uni_ascii(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_ascii(tmpbuf);
 }
@@ -485,7 +716,7 @@ Perl_is_uni_ascii(pTHX_ U32 c)
 bool
 Perl_is_uni_space(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_space(tmpbuf);
 }
@@ -493,7 +724,7 @@ Perl_is_uni_space(pTHX_ U32 c)
 bool
 Perl_is_uni_digit(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_digit(tmpbuf);
 }
@@ -501,7 +732,7 @@ Perl_is_uni_digit(pTHX_ U32 c)
 bool
 Perl_is_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_upper(tmpbuf);
 }
@@ -509,7 +740,7 @@ Perl_is_uni_upper(pTHX_ U32 c)
 bool
 Perl_is_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_lower(tmpbuf);
 }
@@ -517,7 +748,7 @@ Perl_is_uni_lower(pTHX_ U32 c)
 bool
 Perl_is_uni_cntrl(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_cntrl(tmpbuf);
 }
@@ -525,7 +756,7 @@ Perl_is_uni_cntrl(pTHX_ U32 c)
 bool
 Perl_is_uni_graph(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_graph(tmpbuf);
 }
@@ -533,7 +764,7 @@ Perl_is_uni_graph(pTHX_ U32 c)
 bool
 Perl_is_uni_print(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_print(tmpbuf);
 }
@@ -541,7 +772,7 @@ Perl_is_uni_print(pTHX_ U32 c)
 bool
 Perl_is_uni_punct(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_punct(tmpbuf);
 }
@@ -549,7 +780,7 @@ Perl_is_uni_punct(pTHX_ U32 c)
 bool
 Perl_is_uni_xdigit(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_xdigit(tmpbuf);
 }
@@ -557,7 +788,7 @@ Perl_is_uni_xdigit(pTHX_ U32 c)
 U32
 Perl_to_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_upper(tmpbuf);
 }
@@ -565,7 +796,7 @@ Perl_to_uni_upper(pTHX_ U32 c)
 U32
 Perl_to_uni_title(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_title(tmpbuf);
 }
@@ -573,7 +804,7 @@ Perl_to_uni_title(pTHX_ U32 c)
 U32
 Perl_to_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN];
+    U8 tmpbuf[UTF8_MAXLEN+1];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_lower(tmpbuf);
 }
@@ -751,7 +982,7 @@ Perl_is_utf8_space(pTHX_ U8 *p)
     if (!is_utf8_char(p))
        return FALSE;
     if (!PL_utf8_space)
-       PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0);
+       PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_space, p);
 }
 
@@ -853,7 +1084,7 @@ Perl_to_utf8_upper(pTHX_ U8 *p)
     if (!PL_utf8_toupper)
        PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_toupper, p);
-    return uv ? uv : utf8_to_uv_chk(p,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 UV
@@ -864,7 +1095,7 @@ Perl_to_utf8_title(pTHX_ U8 *p)
     if (!PL_utf8_totitle)
        PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_totitle, p);
-    return uv ? uv : utf8_to_uv_chk(p,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 UV
@@ -875,7 +1106,7 @@ Perl_to_utf8_lower(pTHX_ U8 *p)
     if (!PL_utf8_tolower)
        PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
     uv = swash_fetch(PL_utf8_tolower, p);
-    return uv ? uv : utf8_to_uv_chk(p,0,0);
+    return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
 }
 
 /* a "swash" is a swatch hash */
@@ -884,7 +1115,7 @@ SV*
 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
 {
     SV* retval;
-    char tmpbuf[256];
+    SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
     dSP;
 
     if (!gv_stashpv(pkg, 0)) { /* demand load utf8 */
@@ -906,8 +1137,9 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     SAVEI32(PL_hints);
     PL_hints = 0;
     save_re_context();
-    if (PL_curcop == &PL_compiling)    /* XXX ought to be handled by lex_start */
-       strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf);
+    if (PL_curcop == &PL_compiling)
+       /* XXX ought to be handled by lex_start */
+       sv_setpv(tokenbufsv, PL_tokenbuf);
     if (call_method("SWASHNEW", G_SCALAR))
        retval = newSVsv(*PL_stack_sp--);
     else
@@ -915,7 +1147,10 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     LEAVE;
     POPSTACK;
     if (PL_curcop == &PL_compiling) {
-       strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf);
+       STRLEN len;
+       char* pv = SvPV(tokenbufsv, len);
+
+       Copy(pv, PL_tokenbuf, len+1, char);
        PL_curcop->op_private = PL_hints;
     }
     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
@@ -965,7 +1200,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
            PUSHMARK(SP);
            EXTEND(SP,3);
            PUSHs((SV*)sv);
-           PUSHs(sv_2mortal(newSViv(utf8_to_uv_chk(ptr, 0, 0) & ~(needents - 1))));
+           PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1))));
            PUSHs(sv_2mortal(newSViv(needents)));
            PUTBACK;
            if (call_method("SWASHGET", G_SCALAR))
@@ -992,7 +1227,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
            Copy(ptr, PL_last_swash_key, klen, U8);
     }
 
-    switch ((slen << 3) / needents) {
+    switch ((int)((slen << 3) / needents)) {
     case 1:
        bit = 1 << (off & 7);
        off >>= 3;
diff --git a/utf8.h b/utf8.h
index 7407335..28aa057 100644 (file)
--- a/utf8.h
+++ b/utf8.h
@@ -1,6 +1,6 @@
 /*    utf8.h
  *
- *    Copyright (c) 1998-2000, Larry Wall
+ *    Copyright (c) 1998-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -29,23 +29,64 @@ END_EXTERN_C
 
 #define UTF8_MAXLEN 13 /* how wide can a single UTF8 encoded character become */
 
-/*#define IN_UTF8 (PL_curcop->op_private & HINT_UTF8)*/
+/* #define IN_UTF8 (PL_curcop->op_private & HINT_UTF8) */
 #define IN_BYTE (PL_curcop->op_private & HINT_BYTE)
 #define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTE)
 
+#define UTF8_ALLOW_EMPTY               0x0001
+#define UTF8_ALLOW_CONTINUATION                0x0002
+#define UTF8_ALLOW_NON_CONTINUATION    0x0004
+#define UTF8_ALLOW_FE_FF               0x0008
+#define UTF8_ALLOW_SHORT               0x0010
+#define UTF8_ALLOW_SURROGATE           0x0020
+#define UTF8_ALLOW_BOM                 0x0040
+#define UTF8_ALLOW_FFFF                        0x0080
+#define UTF8_ALLOW_LONG                        0x0100
+#define UTF8_ALLOW_ANYUV               (UTF8_ALLOW_EMPTY|UTF8_ALLOW_FE_FF|\
+                                        UTF8_ALLOW_SURROGATE|UTF8_ALLOW_BOM|\
+                                        UTF8_ALLOW_FFFF|UTF8_ALLOW_LONG)
+#define UTF8_ALLOW_ANY                 0x00ff
+#define UTF8_CHECK_ONLY                        0x0100
+
+#define UNICODE_SURROGATE_FIRST                0xd800
+#define UNICODE_SURROGATE_LAST         0xdfff
+#define UNICODE_REPLACEMENT            0xfffd
+#define UNICODE_BYTER_ORDER_MARK       0xfffe
+#define UNICODE_ILLEGAL                        0xffff
+
+#define UNICODE_IS_SURROGATE(c)                ((c) >= UNICODE_SURROGATE_FIRST && \
+                                        (c) <= UNICODE_SURROGATE_LAST)
+#define UNICODE_IS_REPLACEMENT(c)      ((c) == UNICODE_REPLACMENT)
+#define UNICODE_IS_BYTE_ORDER_MARK(c)  ((c) == UNICODE_BYTER_ORDER_MARK)
+#define UNICODE_IS_ILLEGAL(c)          ((c) == UNICODE_ILLEGAL)
+
 #define UTF8SKIP(s) PL_utf8skip[*(U8*)s]
 
+#define UTF8_QUAD_MAX  UINT64_C(0x1000000000)
+
+#define UTF8_IS_ASCII(c)               (((U8)c) <  0x80)
+#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)
+
+#define UTF8_CONTINUATION_MASK         ((U8)0x3f)
+#define UTF8_ACCUMULATION_SHIFT                6
+#define UTF8_ACCUMULATE(old, new)      ((old) << UTF8_ACCUMULATION_SHIFT | (((U8)new) & UTF8_CONTINUATION_MASK))
+
+#define UTF8_EIGHT_BIT_HI(c)   ( (((U8)(c))>>6)      |0xc0)
+#define UTF8_EIGHT_BIT_LO(c)   (((((U8)(c))   )&0x3f)|0x80)
+
 #ifdef HAS_QUAD
-#define UTF8LEN(uv) ( (uv) < 0x80           ? 1 : \
+#define UNISKIP(uv) ( (uv) < 0x80           ? 1 : \
                      (uv) < 0x800          ? 2 : \
                      (uv) < 0x10000        ? 3 : \
                      (uv) < 0x200000       ? 4 : \
                      (uv) < 0x4000000      ? 5 : \
                      (uv) < 0x80000000     ? 6 : \
-                      (uv) < 0x1000000000LL ? 7 : 13 ) 
+                      (uv) < UTF8_QUAD_MAX ? 7 : 13 ) 
 #else
 /* No, I'm not even going to *TRY* putting #ifdef inside a #define */
-#define UTF8LEN(uv) ( (uv) < 0x80           ? 1 : \
+#define UNISKIP(uv) ( (uv) < 0x80           ? 1 : \
                      (uv) < 0x800          ? 2 : \
                      (uv) < 0x10000        ? 3 : \
                      (uv) < 0x200000       ? 4 : \
@@ -53,6 +94,7 @@ END_EXTERN_C
                      (uv) < 0x80000000     ? 6 : 7 )
 #endif
 
+
 /*
  * 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
diff --git a/util.c b/util.c
index 6c949c7..1261b98 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,6 +1,6 @@
 /*    util.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
 #endif
 #endif
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-#  include <unistd.h>
-#endif
-
 #ifdef I_VFORK
 #  include <vfork.h>
 #endif
@@ -115,7 +110,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     Malloc_t PerlMem_realloc();
 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 
-#ifdef HAS_64K_LIMIT 
+#ifdef HAS_64K_LIMIT
     if (size > 0xffff) {
        PerlIO_printf(Perl_error_log,
                      "Reallocation too large: %lx\n", size) FLUSH;
@@ -135,7 +130,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
+
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 
@@ -245,12 +240,12 @@ Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
 
     if (!wh)
        return safexmalloc(0,size);
-    
+
     {
        MEM_SIZE old = sizeof_chunk(where - ALIGN);
        int t = typeof_chunk(where - ALIGN);
        register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
-    
+
        xycount[t][SIZE_TO_Y(old)]--;
        xycount[t][SIZE_TO_Y(size)]++;
        xcount[t] += size - old;
@@ -265,7 +260,7 @@ Perl_safexfree(Malloc_t wh)
     I32 x;
     char *where = (char*)wh;
     MEM_SIZE size;
-    
+
     if (!where)
        return;
     where -= ALIGN;
@@ -297,7 +292,7 @@ S_xstat(pTHX_ int flag)
     for (j = 0; j < MAXYCOUNT; j++) {
        subtot[j] = 0;
     }
-    
+
     PerlIO_printf(Perl_debug_log, "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
     for (i = 0; i < MAXXCOUNT; i++) {
        total += xcount[i];
@@ -306,21 +301,21 @@ S_xstat(pTHX_ int flag)
        }
        if (flag == 0
            ? xcount[i]                 /* Have something */
-           : (flag == 2 
+           : (flag == 2
               ? xcount[i] != lastxcount[i] /* Changed */
               : xcount[i] > lastxcount[i])) { /* Growed */
-           PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, 
+           PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
                          flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
            lastxcount[i] = xcount[i];
            for (j = 0; j < MAXYCOUNT; j++) {
-               if ( flag == 0 
+               if ( flag == 0
                     ? xycount[i][j]    /* Have something */
-                    : (flag == 2 
+                    : (flag == 2
                        ? xycount[i][j] != lastxycount[i][j] /* Changed */
                        : xycount[i][j] > lastxycount[i][j])) { /* Growed */
-                   PerlIO_printf(Perl_debug_log,"%3ld ", 
-                                 flag == 2 
-                                 ? xycount[i][j] - lastxycount[i][j] 
+                   PerlIO_printf(Perl_debug_log,"%3ld ",
+                                 flag == 2
+                                 ? xycount[i][j] - lastxycount[i][j]
                                  : xycount[i][j]);
                    lastxycount[i][j] = xycount[i][j];
                } else {
@@ -466,7 +461,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
  * Set up for a new ctype locale.
  */
 void
-Perl_new_ctype(pTHX_ const char *newctype)
+Perl_new_ctype(pTHX_ char *newctype)
 {
 #ifdef USE_LOCALE_CTYPE
 
@@ -485,10 +480,54 @@ Perl_new_ctype(pTHX_ const char *newctype)
 }
 
 /*
+ * Standardize the locale name from a string returned by 'setlocale'.
+ *
+ * The standard return value of setlocale() is either
+ * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
+ * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
+ *     (the space-separated values represent the various sublocales,
+ *      in some unspecificed order)
+ *
+ * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
+ * which is harmful for further use of the string in setlocale().
+ *
+ */
+STATIC char *
+S_stdize_locale(pTHX_ char *locs)
+{
+    char *s;
+    bool okay = TRUE;
+
+    if ((s = strchr(locs, '='))) {
+       char *t;
+
+       okay = FALSE;
+       if ((t = strchr(s, '.'))) {
+           char *u;
+
+           if ((u = strchr(t, '\n'))) {
+
+               if (u[1] == 0) {
+                   STRLEN len = u - s;
+                   Move(s + 1, locs, len, char);
+                   locs[len] = 0;
+                   okay = TRUE;
+               }
+           }
+       }
+    }
+
+    if (!okay)
+       Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
+
+    return locs;
+}
+
+/*
  * Set up for a new collation locale.
  */
 void
-Perl_new_collate(pTHX_ const char *newcoll)
+Perl_new_collate(pTHX_ char *newcoll)
 {
 #ifdef USE_LOCALE_COLLATE
 
@@ -497,17 +536,17 @@ Perl_new_collate(pTHX_ const char *newcoll)
            ++PL_collation_ix;
            Safefree(PL_collation_name);
            PL_collation_name = NULL;
-           PL_collation_standard = TRUE;
-           PL_collxfrm_base = 0;
-           PL_collxfrm_mult = 2;
        }
+       PL_collation_standard = TRUE;
+       PL_collxfrm_base = 0;
+       PL_collxfrm_mult = 2;
        return;
     }
 
     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
        ++PL_collation_ix;
        Safefree(PL_collation_name);
-       PL_collation_name = savepv(newcoll);
+       PL_collation_name = stdize_locale(savepv(newcoll));
        PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
 
        {
@@ -551,7 +590,7 @@ Perl_set_numeric_radix(pTHX)
  * Set up for a new numeric locale.
  */
 void
-Perl_new_numeric(pTHX_ const char *newnum)
+Perl_new_numeric(pTHX_ char *newnum)
 {
 #ifdef USE_LOCALE_NUMERIC
 
@@ -559,15 +598,15 @@ Perl_new_numeric(pTHX_ const char *newnum)
        if (PL_numeric_name) {
            Safefree(PL_numeric_name);
            PL_numeric_name = NULL;
-           PL_numeric_standard = TRUE;
-           PL_numeric_local = TRUE;
        }
+       PL_numeric_standard = TRUE;
+       PL_numeric_local = TRUE;
        return;
     }
 
     if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
        Safefree(PL_numeric_name);
-       PL_numeric_name = savepv(newnum);
+       PL_numeric_name = stdize_locale(savepv(newnum));
        PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
        PL_numeric_local = TRUE;
        set_numeric_radix();
@@ -585,6 +624,7 @@ Perl_set_numeric_standard(pTHX)
        setlocale(LC_NUMERIC, "C");
        PL_numeric_standard = TRUE;
        PL_numeric_local = FALSE;
+       set_numeric_radix();
     }
 
 #endif /* USE_LOCALE_NUMERIC */
@@ -714,18 +754,18 @@ Perl_init_i18nl10n(pTHX_ int printwarn)
 
     if (setlocale_failure) {
        char *p;
-       bool locwarn = (printwarn > 1 || 
+       bool locwarn = (printwarn > 1 ||
                        (printwarn &&
                         (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
 
        if (locwarn) {
 #ifdef LC_ALL
-  
+
            PerlIO_printf(Perl_error_log,
               "perl: warning: Setting locale failed.\n");
 
 #else /* !LC_ALL */
-  
+
            PerlIO_printf(Perl_error_log,
               "perl: warning: Setting locale failed for the categories:\n\t");
 #ifdef USE_LOCALE_CTYPE
@@ -1025,9 +1065,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     register I32 multiline = flags & FBMrf_MULTILINE;
 
     if (bigend - big < littlelen) {
-       if ( SvTAIL(littlestr) 
+       if ( SvTAIL(littlestr)
             && (bigend - big == littlelen - 1)
-            && (littlelen == 1 
+            && (littlelen == 1
                 || (*big == *little &&
                     memEQ((char *)big, (char *)little, littlelen - 1))))
            return (char*)big;
@@ -1119,7 +1159,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     }
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
-       if (s >= big && bigend[-1] == '\n' && *s == *little 
+       if (s >= big && bigend[-1] == '\n' && *s == *little
            /* Automatically of length > 2 */
            && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
        {
@@ -1148,7 +1188,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
        return b;
     }
-    
+
     {  /* Do actual FBM.  */
        register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
        register unsigned char *oldlittle;
@@ -1208,7 +1248,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
    of ends of some substring of bigstr.
    If `last' we want the last occurence.
    old_posp is the way of communication between consequent calls if
-   the next call needs to find the . 
+   the next call needs to find the .
    The initial *old_posp should be -1.
 
    Note that we take into account SvTAIL, so one can get extra
@@ -1222,7 +1262,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 char *
 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 {
-    dTHR;
     register unsigned char *s, *x;
     register unsigned char *big;
     register I32 pos;
@@ -1237,7 +1276,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
-       if ( BmRARE(littlestr) == '\n' 
+       if ( BmRARE(littlestr) == '\n'
             && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
            little = (unsigned char *)(SvPVX(littlestr));
            littleend = little + SvCUR(littlestr);
@@ -1300,7 +1339,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
            found = 1;
        }
     } while ( pos += PL_screamnext[pos] );
-    if (last && found) 
+    if (last && found)
        return (char *)(big+(*old_posp));
 #endif /* POINTERRIGOR */
   check_tail:
@@ -1392,7 +1431,6 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len)
 STATIC SV *
 S_mess_alloc(pTHX)
 {
-    dTHR;
     SV *sv;
     XPVMG *any;
 
@@ -1478,7 +1516,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-       dTHR;
        if (CopLINE(PL_curcop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
                           CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
@@ -1487,7 +1524,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
                      PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
-                     line_mode ? "line" : "chunk", 
+                     line_mode ? "line" : "chunk",
                      (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
 #ifdef USE_THREADS
@@ -1502,7 +1539,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
 OP *
 Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
-    dTHR;
     char *message;
     int was_in_eval = PL_in_eval;
     HV *stash;
@@ -1603,7 +1639,6 @@ Perl_die(pTHX_ const char* pat, ...)
 void
 Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
-    dTHR;
     char *message;
     HV *stash;
     GV *gv;
@@ -1736,7 +1771,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 
     if (PL_warnhook) {
        /* sv_2cv might call Perl_warn() */
-       dTHR;
        SV *oldwarnhook = PL_warnhook;
        ENTER;
        SAVESPTR(PL_warnhook);
@@ -1768,7 +1802,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 
        PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-       DEBUG_L(*message == '!' 
+       DEBUG_L(*message == '!'
                ? (xstat(message[1]=='!'
                         ? (message[2]=='!' ? 2 : 1)
                         : 0)
@@ -1834,7 +1868,6 @@ Perl_warner(pTHX_ U32  err, const char* pat,...)
 void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
-    dTHR;
     char *message;
     HV *stash;
     GV *gv;
@@ -1860,13 +1893,13 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
                 dSP;
                 SV *msg;
+
                 ENTER;
                save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
+
                PUSHSTACKi(PERLSI_DIEHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
@@ -1891,7 +1924,6 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     else {
         if (PL_warnhook) {
             /* sv_2cv might call Perl_warn() */
-            dTHR;
             SV *oldwarnhook = PL_warnhook;
             ENTER;
             SAVESPTR(PL_warnhook);
@@ -1901,13 +1933,13 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
                 dSP;
                 SV *msg;
+
                 ENTER;
                save_re_context();
                 msg = newSVpvn(message, msglen);
                 SvREADONLY_on(msg);
                 SAVEFREESV(msg);
+
                PUSHSTACKi(PERLSI_WARNHOOK);
                 PUSHMARK(sp);
                 XPUSHs(msg);
@@ -1922,7 +1954,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
            PerlIO *serr = Perl_error_log;
            PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-           DEBUG_L(*message == '!' 
+           DEBUG_L(*message == '!'
                ? (xstat(message[1]=='!'
                         ? (message[2]=='!' ? 2 : 1)
                         : 0)
@@ -1936,7 +1968,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 
 #ifdef USE_ENVIRON_ARRAY
        /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
-#if !defined(WIN32) && !defined(__CYGWIN__)
+#if !defined(WIN32)
 void
 Perl_my_setenv(pTHX_ char *nam, char *val)
 {
@@ -1978,50 +2010,19 @@ Perl_my_setenv(pTHX_ char *nam, char *val)
     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
 
 #else   /* PERL_USE_SAFE_PUTENV */
+#   if defined(__CYGWIN__)
+    setenv(nam, val, 1);
+#   else
     char *new_env;
 
     new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
     (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
     (void)putenv(new_env);
+#   endif /* __CYGWIN__ */
 #endif  /* PERL_USE_SAFE_PUTENV */
 }
 
-#else /* WIN32 || __CYGWIN__ */
-#if defined(__CYGWIN__)
-/*
- * Save environ of perl.exe, currently Cygwin links in separate environ's
- * for each exe/dll.  Probably should be a member of impure_ptr.
- */
-static char ***Perl_main_environ;
-
-EXTERN_C void
-Perl_my_setenv_init(char ***penviron)
-{
-    Perl_main_environ = penviron;
-}
-
-void
-Perl_my_setenv(pTHX_ char *nam, char *val)
-{
-    /* You can not directly manipulate the environ[] array because
-     * the routines do some additional work that syncs the Cygwin
-     * environment with the Windows environment.
-     */
-    char *oldstr = environ[setenv_getix(nam)];
-
-    if (!val) {
-       if (!oldstr)
-           return;
-       unsetenv(nam);
-       safesysfree(oldstr);
-       return;
-    }
-    setenv(nam, val, 1);
-    environ = *Perl_main_environ; /* environ realloc can occur in setenv */
-    if(oldstr && environ[setenv_getix(nam)] != oldstr)
-       safesysfree(oldstr);
-}
-#else /* if WIN32 */
+#else /* WIN32 */
 
 void
 Perl_my_setenv(pTHX_ char *nam,char *val)
@@ -2082,7 +2083,6 @@ Perl_my_setenv(pTHX_ char *nam,char *val)
 }
 
 #endif /* WIN32 */
-#endif
 
 I32
 Perl_setenv_getix(pTHX_ char *nam)
@@ -2358,7 +2358,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     if (doexec) {
        return my_syspopen(aTHX_ cmd,mode);
     }
-#endif 
+#endif
     This = (*mode == 'w');
     that = !This;
     if (doexec && PL_tainting) {
@@ -2455,8 +2455,12 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
        PerlLIO_close(pp[0]);
        did_pipes = 0;
        if (n) {                        /* Error */
+           int pid2, status;
            if (n != sizeof(int))
                Perl_croak(aTHX_ "panic: kid popen errno read");
+           do {
+               pid2 = wait4pid(pid, &status, 0);
+           } while (pid2 == -1 && errno == EINTR);
            errno = errkid;             /* Propagate errno from kid */
            return Nullfp;
        }
@@ -2471,10 +2475,12 @@ FILE *popen();
 PerlIO *
 Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
-    /* Needs work for PerlIO ! */
-    /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
     PERL_FLUSHALL_FOR_CHILD;
-    return popen(PerlIO_exportFILE(cmd, 0), mode);
+    /* Call system's popen() to get a FILE *, then import it.
+       used 0 for 2nd parameter to PerlIO_importFILE;
+       apparently not used
+    */
+    return PerlIO_importFILE(popen(cmd, mode), 0);
 }
 #endif
 
@@ -2664,7 +2670,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     if (pid == -1) {                   /* Opened by popen. */
        return my_syspclose(ptr);
     }
-#endif 
+#endif
     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
        saved_errno = errno;
 #ifdef VMS
@@ -2783,7 +2789,7 @@ my_syspclose(PerlIO *ptr)
 #else
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
-#endif 
+#endif
 {
     /* Needs work for PerlIO ! */
     FILE *f = PerlIO_findFILE(ptr);
@@ -2847,7 +2853,7 @@ Perl_cast_ulong(pTHX_ NV f)
 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
    of LONG_(MIN/MAX).
                            -- Kenneth Albanowski <kjahds@kjahds.com>
-*/                                      
+*/
 
 #ifndef MY_UV_MAX
 #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
@@ -2933,7 +2939,7 @@ Perl_same_dirent(pTHX_ char *a, char *b)
 #endif /* !HAS_RENAME */
 
 NV
-Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 {
     register char *s = start;
     register NV rnv = 0.0;
@@ -2955,7 +2961,6 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
                continue;
            }
            else {
-               dTHR;
                if (ckWARN(WARN_DIGIT))
                    Perl_warner(aTHX_ WARN_DIGIT,
                                "Illegal binary digit '%c' ignored", *s);
@@ -2966,7 +2971,6 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
            register UV xuv = ruv << 1;
 
            if ((xuv >> 1) != ruv) {
-               dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
                if (ckWARN_d(WARN_OVERFLOW))
@@ -2993,8 +2997,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
 #if UVSIZE > 4
        || (!overflowed && ruv > 0xffffffff  )
 #endif
-       ) { 
-       dTHR;
+       ) {
        if (ckWARN(WARN_PORTABLE))
            Perl_warner(aTHX_ WARN_PORTABLE,
                        "Binary number > 0b11111111111111111111111111111111 non-portable");
@@ -3004,7 +3007,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
 }
 
 NV
-Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 {
     register char *s = start;
     register NV rnv = 0.0;
@@ -3024,7 +3027,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
                 * as soon as non-octal characters are seen, complain only iff
                 * someone seems to want to use the digits eight and nine). */
                if (*s == '8' || *s == '9') {
-                   dTHR;
                    if (ckWARN(WARN_DIGIT))
                        Perl_warner(aTHX_ WARN_DIGIT,
                                    "Illegal octal digit '%c' ignored", *s);
@@ -3036,7 +3038,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
            register UV xuv = ruv << 3;
 
            if ((xuv >> 3) != ruv) {
-               dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
                if (ckWARN_d(WARN_OVERFLOW))
@@ -3064,7 +3065,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
        || (!overflowed && ruv > 0xffffffff  )
 #endif
        ) {
-       dTHR;
        if (ckWARN(WARN_PORTABLE))
            Perl_warner(aTHX_ WARN_PORTABLE,
                        "Octal number > 037777777777 non-portable");
@@ -3074,15 +3074,25 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
 }
 
 NV
-Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
 {
     register char *s = start;
     register NV rnv = 0.0;
     register UV ruv = 0;
-    register bool seenx = FALSE;
     register bool overflowed = FALSE;
     char *hexdigit;
 
+    if (len > 2) {
+       if (s[0] == 'x') {
+           s++;
+           len--;
+       }
+       else if (len > 3 && s[0] == '0' && s[1] == 'x') {
+           s+=2;
+           len-=2;
+       }
+    }
+
     for (; len-- && *s; s++) {
        hexdigit = strchr((char *) PL_hexdigit, *s);
        if (!hexdigit) {
@@ -3092,13 +3102,7 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
                --len;
                ++s;
            }
-           else if (seenx == FALSE && *s == 'x' && ruv == 0) {
-               /* Disallow 0xxx0x0xxx... */
-               seenx = TRUE;
-               continue;
-           }
            else {
-               dTHR;
                if (ckWARN(WARN_DIGIT))
                    Perl_warner(aTHX_ WARN_DIGIT,
                                "Illegal hexadecimal digit '%c' ignored", *s);
@@ -3109,7 +3113,6 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
            register UV xuv = ruv << 4;
 
            if ((xuv >> 4) != ruv) {
-               dTHR;
                overflowed = TRUE;
                rnv = (NV) ruv;
                if (ckWARN_d(WARN_OVERFLOW))
@@ -3136,8 +3139,7 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
 #if UVSIZE > 4
        || (!overflowed && ruv > 0xffffffff  )
 #endif
-       ) { 
-       dTHR;
+       ) {
        if (ckWARN(WARN_PORTABLE))
            Perl_warner(aTHX_ WARN_PORTABLE,
                        "Hexadecimal number > 0xffffffff non-portable");
@@ -3149,7 +3151,6 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
 char*
 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
 {
-    dTHR;
     char *xfound = Nullch;
     char *xfailed = Nullch;
     char tmpbuf[MAXPATHLEN];
@@ -3357,7 +3358,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
        }
 #ifndef DOSISH
        if (!xfound && !seen_dot && !xfailed &&
-           (PerlLIO_stat(scriptname,&PL_statbuf) < 0 
+           (PerlLIO_stat(scriptname,&PL_statbuf) < 0
             || S_ISDIR(PL_statbuf.st_mode)))
 #endif
            seen_dot = 1;                       /* Disable message. */
@@ -3437,7 +3438,7 @@ Perl_cond_signal(pTHX_ perl_cond *cp)
 {
     perl_os_thread t;
     perl_cond cond = *cp;
-    
+
     if (!cond)
        return;
     t = cond->thread;
@@ -3457,7 +3458,7 @@ Perl_cond_broadcast(pTHX_ perl_cond *cp)
 {
     perl_os_thread t;
     perl_cond cond, cond_next;
-    
+
     for (cond = *cp; cond; cond = cond_next) {
        t = cond->thread;
        /* Insert t in the runnable queue just ahead of us */
@@ -3480,7 +3481,7 @@ Perl_cond_wait(pTHX_ perl_cond *cp)
 
     if (thr->i.next_run == thr)
        Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
-    
+
     New(666, cond, 1, struct perl_wait_queue);
     cond->thread = thr;
     cond->next = *cp;
@@ -3496,7 +3497,7 @@ MAGIC *
 Perl_condpair_magic(pTHX_ SV *sv)
 {
     MAGIC *mg;
-    
+
     SvUPGRADE(sv, SVt_PVMG);
     mg = mg_find(sv, 'm');
     if (!mg) {
@@ -3605,6 +3606,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     thr->specific = newAV();
     thr->errsv = newSVpvn("", 0);
     thr->flags = THRf_R_JOINABLE;
+    thr->thr_done = 0;
     MUTEX_INIT(&thr->mutex);
 
     JMPENV_BOOTSTRAP;
@@ -3645,8 +3647,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     PL_nrs = newSVsv(t->Tnrs);
     PL_rs = SvREFCNT_inc(PL_nrs);
     PL_last_in_gv = Nullgv;
-    PL_ofslen = t->Tofslen;
-    PL_ofs = savepvn(t->Tofs, PL_ofslen);
+    PL_ofs_sv = SvREFCNT_inc(PL_ofs_sv);
     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
     PL_chopset = t->Tchopset;
     PL_bodytarget = newSVsv(t->Tbodytarget);
@@ -3667,7 +3668,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
                "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
                                  (IV)i, t, thr));
        }
-    } 
+    }
     thr->threadsvp = AvARRAY(thr->threadsv);
 
     MUTEX_LOCK(&PL_threads_mutex);
@@ -3692,10 +3693,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
 /*
  * This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use. 
+ * So it is in perl for (say) POSIX to use.
  * Needed for SunOS with Sun's 'acc' for example.
  */
-NV 
+NV
 Perl_huge(void)
 {
 #   if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
@@ -3862,30 +3863,36 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
 I32
 Perl_my_fflush_all(pTHX)
 {
-#ifdef FFLUSH_NULL
+#if defined(FFLUSH_NULL)
     return PerlIO_flush(NULL);
 #else
+# if defined(HAS__FWALK)
+    /* undocumented, unprototyped, but very useful BSDism */
+    extern void _fwalk(int (*)(FILE *));
+    _fwalk(&fflush);
+    return 0;
+#   else
     long open_max = -1;
-# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
-#  ifdef PERL_FFLUSH_ALL_FOPEN_MAX
+#  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
+#   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
-#  else
-#  if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+#   else
+#   if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
     open_max = sysconf(_SC_OPEN_MAX);
-#  else
-#   ifdef FOPEN_MAX
-    open_max = FOPEN_MAX;
 #   else
-#    ifdef OPEN_MAX
-    open_max = OPEN_MAX;
+#    ifdef FOPEN_MAX
+    open_max = FOPEN_MAX;
 #    else
-#     ifdef _NFILE
+#     ifdef OPEN_MAX
+    open_max = OPEN_MAX;
+#     else
+#      ifdef _NFILE
     open_max = _NFILE;
+#      endif
 #     endif
 #    endif
 #   endif
-#  endif
-#  endif
+#   endif
     if (open_max > 0) {
       long i;
       for (i = 0; i < open_max; i++)
@@ -3895,9 +3902,10 @@ Perl_my_fflush_all(pTHX)
                PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
       return 0;
     }
-# endif
+#  endif
     SETERRNO(EBADF,RMS$_IFI);
     return EOF;
+# endif
 #endif
 }
 
@@ -3953,7 +3961,15 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
        name = SvPVX(sv);
     }
 
-    if (name && *name) {
+    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
+       if (name && *name)
+           Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput",
+                       name,
+                       (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+       else
+           Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput",
+                       (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+    } else if (name && *name) {
        Perl_warner(aTHX_ warn_type,
                    "%s%s on %s %s %s", func, pars, vile, type, name);
        if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
diff --git a/util.h b/util.h
index bcf6b58..e01f0ec 100644 (file)
--- a/util.h
+++ b/util.h
@@ -1,6 +1,6 @@
 /*    util.h
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 44b9ac8..88ac482 100644 (file)
@@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions
 
 =head1 SYNOPSIS
 
-B<h2xs> [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [headerfile ... [extra_libraries]]
+B<h2xs> [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [B<-b> compat_version] [headerfile ... [extra_libraries]]
 
 B<h2xs> B<-h>
 
@@ -403,7 +403,7 @@ See L<perlxs> and L<perlxstut> for additional details.
 use strict;
 
 
-my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
+my( $H2XS_VERSION ) = ' $Revision: 1.21 $ ' =~ /\$Revision:\s+([^\s]+)/;
 my $TEMPLATE_VERSION = '0.01';
 my @ARGS = @ARGV;
 my $compat_version = $];
@@ -524,6 +524,8 @@ EOD
 my @path_h_ini = @path_h;
 my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 
+my $module = $opt_n;
+
 if( @path_h ){
     use Config;
     use File::Spec;
@@ -542,6 +544,15 @@ if( @path_h ){
     }
     foreach my $path_h (@path_h) {
         $name ||= $path_h;
+    $module ||= do {
+      $name =~ s/\.h$//;
+      if ( $name !~ /::/ ) {
+       $name =~ s#^.*/##;
+       $name = "\u$name";
+      }
+      $name;
+    };
+
     if( $path_h =~ s#::#/#g && $opt_n ){
        warn "Nesting of headerfile ignored with -n\n";
     }
@@ -550,19 +561,36 @@ if( @path_h ){
     $path_h =~ s/,.*$// if $opt_x;
     $fullpath{$path_h} = $fullpath;
 
+    # Minor trickery: we can't chdir() before we processed the headers
+    # (so know the name of the extension), but the header may be in the
+    # extension directory...
+    my $tmp_path_h = $path_h;
+    my $rel_path_h = $path_h;
+    my @dirs = @paths;
     if (not -f $path_h) {
-      my $tmp_path_h = $path_h;
+      my $found;
       for my $dir (@paths) {
-       last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+       $found++, last
+         if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+      }
+      if ($found) {
+       $rel_path_h = $path_h;
+      } else {
+       (my $epath = $module) =~ s,::,/,g;
+       $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
+       $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
+       $path_h = $tmp_path_h;  # Used during -x
+       push @dirs, $epath;
       }
     }
 
     if (!$opt_c) {
-      die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
+      die "Can't find $tmp_path_h in @dirs\n" 
+       if ( ! $opt_f && ! -f "$rel_path_h" );
       # Scan the header file (we should deal with nested header files)
       # Record the names of simple #define constants into const_names
             # Function prototypes are processed below.
-      open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
+      open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
     defines:
       while (<CH>) {
        if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
@@ -603,14 +631,6 @@ if( @path_h ){
 }
 
 
-my $module = $opt_n || do {
-       $name =~ s/\.h$//;
-       if( $name !~ /::/ ){
-               $name =~ s#^.*/##;
-               $name = "\u$name";
-       }
-       $name;
-};
 
 my ($ext, $nested, @modparts, $modfname, $modpname);
 (chdir 'ext', $ext = 'ext/') if -d 'ext';
@@ -1023,7 +1043,7 @@ my $pod = <<"END" unless $opt_P;
 $exp_doc$meth_doc$revhist
 #=head1 AUTHOR
 #
-#$author, $email
+#$author, E<lt>${email}E<gt>
 #
 #=head1 SEE ALSO
 #
@@ -1697,6 +1717,9 @@ WriteMakefile(
     'NAME'             => '$module',
     'VERSION_FROM'     => '$modfname.pm', # finds \$VERSION
     'PREREQ_PM'                => {}, # e.g., Module::Name => 1.1
+    (\$] >= 5.005 ?    ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM => '$modfname.pm', # retrieve abstract from module
+       AUTHOR     => '$author <$email>') : ()),
 END
 if (!$opt_X) { # print C stuff, unless XS is disabled
   $opt_F = '' unless defined $opt_F;
@@ -1725,32 +1748,75 @@ END
 print PL ");\n";
 close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
 
+# Create a simple README since this is a CPAN requirement
+# and it doesnt hurt to have one
+warn "Writing $ext$modpname/README\n";
+open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
+my $thisyear = (gmtime)[5] + 1900;
+my $rmhead = "$modpname version $TEMPLATE_VERSION";
+my $rmheadeq = "=" x length($rmhead);
+print RM <<_RMEND_;
+$rmhead
+$rmheadeq
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+  blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) $thisyear $author blah blah blah
+
+_RMEND_
+close(RM) || die "Can't close $ext$modpname/README: $!\n";
+
 warn "Writing $ext$modpname/test.pl\n";
 open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
 print EX <<'_END_';
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
-######################### We start with some black magic to print on failure.
+#########################
 
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
+# change 'tests => 1' to 'tests => last_test_to_print';
 
-BEGIN { $| = 1; print "1..1\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test;
+BEGIN { plan tests => 1 };
 _END_
 print EX <<_END_;
 use $module;
 _END_
 print EX <<'_END_';
-$loaded = 1;
-print "ok 1\n";
+ok(1); # If we made it this far, we're ok.
 
-######################### End of black magic.
+#########################
 
-# Insert your test code below (better if it prints "ok 13"
-# (correspondingly "not ok 13") depending on the success of chunk 13
-# of the test code):
+# Insert your test code below, the Test module is use()ed here so read
+# its man page ( perldoc Test ) for help writing this test script.
 
 _END_
 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
index 6c92254..c4289f8 100644 (file)
@@ -91,7 +91,7 @@ BEGIN {
     $::HaveUtil = ($@ eq "");
 };
 
-my $Version = "1.32";
+my $Version = "1.33";
 
 # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
 # Changed in 1.07 to see more sendmail execs, and added pipe output.
@@ -128,6 +128,7 @@ my $Version = "1.32";
 # Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
 # Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
 # Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
 
 # TODO: - Allow the user to re-name the file on mail failure, and
 #       make sure failure (transmission-wise) of Mail::Send is
@@ -153,7 +154,6 @@ include a file, you can use the -f switch.
 EOF
     die "\n";
 }
-if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; }
 
 Query();
 Edit() unless $usefile || ($ok and not $::opt_n);
@@ -215,7 +215,7 @@ sub Init {
         MacPerl::Ask('Provide command-line args here (-h for help):')
         if $Is_MacOS && $MacPerl::Version =~ /App/;
 
-    if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
+    if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
 
     # This comment is needed to notify metaconfig that we are
     # using the $perladmin, $cf_by, and $cf_time definitions.
@@ -574,6 +574,13 @@ sub Dump {
 Flags:
     category=$category
     severity=$severity
+EFF
+    if ($::opt_A) {
+       print OUT <<EFF;
+    ack=no
+EFF
+    }
+    print OUT <<EFF;
 ---
 EFF
     print OUT "This perlbug was built using Perl $config_tag1\n",
@@ -724,10 +731,11 @@ EOF
            chop $action;
 
            if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
-               print "\n\nName of file to save message in [perlbug.rep]: ";
+               my $file_save = $outfile || "perlbug.rep";
+               print "\n\nName of file to save message in [$file_save]: ";
                my $file = scalar <>;
                chop $file;
-               $file = "perlbug.rep" if $file eq "";
+               $file = $file_save if $file eq "";
 
                unless (open(FILE, ">$file")) {
                    print "\nError opening $file: $!\n\n";
@@ -769,7 +777,7 @@ EOF
                Edit();
            } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
                Cancel();
-           } elsif ($action =~ /^s/) {
+           } elsif ($action =~ /^s/i) {
                paraprint <<EOF;
 I'm sorry, but I didn't understand that. Please type "send" or "save".
 EOF
@@ -837,7 +845,7 @@ report. We apologize for the inconvenience.
 So you may attempt to find some way of sending your message, it has
 been left in the file `$filename'.
 EOF
-       open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!";
+       open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!";
 sendout:
        print SENDMAIL "To: $address\n";
        print SENDMAIL "Subject: $subject\n";
@@ -867,7 +875,7 @@ be needed.
 Usage:
 $0  [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
     [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
-$0  [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay]
+$0  [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
 
 Simplest usage:  run "$0", and follow the prompts.
 
@@ -889,9 +897,9 @@ Options:
         this if you don't give it here.
   -e    Editor to use.
   -t    Test mode. The target address defaults to `$testaddress'.
-  -d    Data mode (the default if you redirect or pipe output.)
-        This prints out your configuration data, without mailing
+  -d    Data mode.  This prints out your configuration data, without mailing
         anything. You can use this with -v to get more complete data.
+  -A    Don't send a bug received acknowledgement to the return address.
   -ok   Report successful build on this system to perl porters
         (use alone or with -v). Only use -ok if *everything* was ok:
         if there were *any* problems at all, use -nok.
@@ -939,10 +947,10 @@ B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
 S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
 S<[ B<-r> I<returnaddress> ]>
 S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
-S<[ B<-S> ]> S<[ B<-t> ]>  S<[ B<-d> ]>  S<[ B<-h> ]>
+S<[ B<-S> ]> S<[ B<-t> ]>  S<[ B<-d> ]>  S<[ B<-A> ]>  S<[ B<-h> ]>
 
 B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
-S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
 
 =head1 DESCRIPTION
 
@@ -1087,6 +1095,13 @@ version of perl comes out and your bug is still present.
 
 Address to send the report to.  Defaults to `perlbug@perl.org'.
 
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
 =item B<-b>
 
 Body of the report.  If not included on the command line, or
index 0c4b726..a950130 100644 (file)
@@ -308,10 +308,10 @@ sub cc_harness {
        my ($cfile,$stash)=@_;
        use ExtUtils::Embed ();
        my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
-       $command .= join " -I", split /\s+/, opt(I);
-       $command .= join " -L", split /\s+/, opt(L);
+       $command .= " -I".$_ for split /\s+/, opt(I);
+       $command .= " -L".$_ for split /\s+/, opt(L);
        my @mods = split /-?u /, $stash;
-       $command .= ExtUtils::Embed::ldopts("-std", \@mods);
+       $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
        vprint 3, "running cc $command";
        system("cc $command");
 }
index e1dd783..313be20 100644 (file)
@@ -409,7 +409,11 @@ sub page {
     }
     else {
        foreach my $pager (@pagers) {
+          if ($Is_VMS) {
+           last if system("$pager $tmp") == 0; # quoting prevents logical expansion
+          } else {
            last if system("$pager \"$tmp\"") == 0;
+          }
        }
     }
 }
index 0e4ad86..8bc733b 100644 (file)
@@ -121,7 +121,6 @@ do_aspawn(SV* really, SV **mark, SV **sp)
     status = FAIL;
     if (sp > mark)
     {
-       dTHR;
        New(401,PL_Argv, sp - mark + 1, char*);
        a = PL_Argv;
        while (++mark <= sp)
@@ -286,7 +285,6 @@ do_spawn(char *cmd, int execf)
                     (const char **) environ);
        if (pid < 0)
        {
-          dTHR;
           status = FAIL;
           if (ckWARN(WARN_EXEC))
              warner(WARN_EXEC,"Can't exec \"%s\": %s",
index c34be75..35f6676 100644 (file)
@@ -1211,6 +1211,11 @@ cleanlis :
        - If F$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
        - If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
 
+cleantest :
+        - If F$Search("[.t]Perl.").nes."" Then Delete/NoConfirm/Log [.t]Perl.;*
+        - If F$Search("[.t]VMSPIPE.COM").nes."" Then Delete/NoConfirm/Log [.t]VMSPIPE.COM;*
+        - If F$Search("[.t]Echo.exe").nes."" Then Delete/NoConfirm/Log [.t]Echo.exe;*
+
 tidy : cleanlis
        - If F$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log [...]*.Opt
        - If F$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [...]*$(O)
@@ -1247,7 +1252,7 @@ tidy : cleanlis
        - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com
        - If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com
 
-clean : tidy
+clean : tidy cleantest
        - @make_ext "$(dynamic_ext)" "$(MINIPERL_EXE)" "$(MMS)" clean
        - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
        - If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*
index 84ab2be..28e2fa3 100644 (file)
@@ -1,4 +1,4 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm',
-               'MAN3PODS'     => ' ');
+               'MAN3PODS'     => {});
index f5599f8..4e17a48 100644 (file)
@@ -1,5 +1,5 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile( 'VERSION_FROM' => 'Stdio.pm',
-               'MAN3PODS'     => ' ', # pods will be built later
+               'MAN3PODS'     => {}, # pods will be built later
              );
index b51f2c9..446b078 100644 (file)
@@ -134,7 +134,7 @@ This package C<ISA> IO::File, so that you can call IO::File
 methods on the handles returned by C<vmsopen> and C<vmssysopen>.
 The IO::File package is not initialized, however, until you
 actually call a method that VMS::Stdio doesn't provide.  This
-is doen to save startup time for users who don't wish to use
+is done to save startup time for users who don't wish to use
 the IO::File methods.
 
 B<Note:>  In order to conform to naming conventions for Perl
@@ -201,7 +201,7 @@ true value if successful, and C<undef> if it fails.
 This function sets the default device and directory for the process.
 It is identical to the built-in chdir() operator, except that the change
 persists after Perl exits.  It returns a true value on success, and
-C<undef> if it encounters and error.
+C<undef> if it encounters an error.
 
 =item sync
 
index 22d9a72..d82b17d 100644 (file)
@@ -87,7 +87,6 @@ newFH(FILE *fp, char type) {
     HV *stash;
     IO *io;
 
-    dTHR;
     /* Find stash for VMS::Stdio.  We don't do this once at boot
      * to allow for possibility of threaded Perl with per-thread
      * symbol tables.  This code (through io = ...) is really
index 68bb6e8..48499d4 100644 (file)
@@ -68,16 +68,21 @@ if ($docc) {
   elsif (-f '[-]perl.h') { $dir = '[-]'; }
   else { die "$0: Can't find perl.h\n"; }
 
-  # Go see if debugging is enabled in config.h
-  $config = $dir . "config.h";
+  $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
+  $hide_mymalloc = $isgcc = 0;
+
+  # Go see what is enabled in config.sh
+  $config = $dir . "config.sh";
   open CONFIG, "< $config";
   while(<CONFIG>) {
-    $debugging_enabled++ if /define\s+DEBUGGING/;
-    $use_mymalloc++ if /define\s+MYMALLOC/;
-    $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/;
-    $use_threads++ if /define\s+USE_THREADS/;
-    $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/;
+    $use_threads++ if /usethreads='define'/;
+    $use_mymalloc++ if /usemymalloc='Y'/;
+    $care_about_case++ if /d_vms_case_sensitive_symbols='define'/;
+    $debugging_enabled++ if /usedebugging_perl='Y'/;
+    $hide_mymalloc++ if /embedmymalloc='Y'/;
+    $isgcc++ if /gccversion='[^']/;
   }
+  close CONFIG;
   
   # put quotes back onto defines - they were removed by DCL on the way in
   if (($prefix,$defines,$suffix) =
@@ -92,8 +97,7 @@ if ($docc) {
 
   # check for gcc - if present, we'll need to use MACRO hack to
   # define global symbols for shared variables
-  $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/
-           or 0; # make debug output nice
+
   print "\$isgcc: $isgcc\n" if $debug;
   print "\$debugging_enabled: $debugging_enabled\n" if $debug;
 
@@ -168,7 +172,7 @@ if ($docc) {
 else {
   open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
 }
-%checkh = map { $_,1 } qw( thread bytecode byterun proto );
+%checkh = map { $_,1 } qw( thread bytecode byterun proto perlio );
 $ckfunc = 0;
 LINE: while (<CPP>) {
   while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
index e500e76..ef1d5ad 100644 (file)
@@ -229,6 +229,8 @@ foreach (@ARGV) {
                  d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) {
       print OUT "$_='$rtlhas'\n";
     }
+    print OUT "d_stdio_ptr_lval_sets_cnt='undef'\n";
+    print OUT "d_stdio_ptr_lval_nochange_cnt='undef'\n";
     foreach (qw[ d_gettimeod d_uname d_truncate d_wait4 d_index
                  d_pathconf d_fpathconf d_sysconf d_sigsetjmp ]) {
       print OUT "$_='$rtlnew'\n";
index 17e83e5..f43cbb0 100644 (file)
@@ -788,6 +788,14 @@ by saying
 (You can't just say C<$ENV{$key} = $ENV{$key}>, since the
 Perl optimizer is smart enough to elide the expression.)
 
+Don't try to clear C<%ENV> by saying C<%ENV = ();>, it will throw
+a fatal error.  This is equivalent to doing the following from DCL:
+
+    DELETE/LOGICAL *
+
+You can imagine how bad things would be if, for example, the SYS$MANAGER
+or SYS$SYSTEM logicals were deleted.
+
 At present, the first time you iterate over %ENV using
 C<keys>, or C<values>,  you will incur a time penalty as all
 logical names are read, in order to fully populate %ENV.
index 0676ebd..640780a 100644 (file)
@@ -1749,7 +1749,7 @@ case 35:
 break;
 case 37:
 #line 269 "perly.y"
-{ (void)scan_num("1"); yyval.opval = yylval.opval; }
+{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; }
 break;
 case 39:
 #line 274 "perly.y"
index 7b4ebce..a0569a6 100644 (file)
@@ -43,7 +43,11 @@ $!
 $!  Pick up a copy of perl to use for the tests
 $   If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;*
 $   Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl.
-$
+$!
+$!  Pick up a copy of vmspipe.com to use for the tests
+$   If F$Search("VMSPIPE.COM").nes."" then Delete/Log/Noconfirm VMSPIPE.COM;*
+$   Copy/Log/NoConfirm [-]VMSPIPE.COM []
+$!
 $!  Make the environment look a little friendlier to tests which assume Unix
 $   cat == "Type"
 $   Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
@@ -86,6 +90,7 @@ $   Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
                movl    #1,r0
                ret     
                .end echo
+$   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
 $   Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
 $   Delete/Log/NoConfirm Echo.Obj;*
 $   echo == "$" + F$Parse("Echo.Exe")
@@ -114,7 +119,7 @@ use Config;
 @libexcl=('db-btree.t','db-hash.t','db-recno.t',
           'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
           'io_sock.t', 'io_unix.t',
-          'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t');
+          'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
 
 # Note: POSIX is not part of basic build, but can be built
 # separately if you're using DECC
@@ -238,7 +243,7 @@ if ($bad == 0) {
     }
 }
 ($user,$sys,$cuser,$csys) = times;
-print sprintf("u=%g  s=%g  cu=%g  cs=%g  files=%d  tests=%d\n",
+print sprintf("u=%g  s=%g  cu=%g  cs=%g  scripts=%d  tests=%d\n",
     $user,$sys,$cuser,$csys,$files,$totmax);
 $$END-OF-TEST$$
 $ wrapup:
@@ -250,7 +255,6 @@ $   Else
 $     Deassign 'dbg'PerlShr
 $   EndIf
 $   Show Process/Accounting
-$   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
 $   Set Default &olddef
 $   Set Message 'oldmsg'
 $   Exit
index 8fe4f5f..7872bdd 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -98,6 +98,9 @@ struct itmlst_3 {
 #define expand_wild_cards(a,b,c,d)     mp_expand_wild_cards(aTHX_ a,b,c,d)
 #define getredirection(a,b)            mp_getredirection(aTHX_ a,b)
 
+/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
+#define PERL_LNM_MAX_ALLOWED_INDEX 127
+
 static char *__mystrtolower(char *str)
 {
   if (str) for (; *str; ++str) *str= tolower(*str);
@@ -152,7 +155,7 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx,
     }
 #endif
 
-    if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
+    if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
     }
     for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
@@ -596,7 +599,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
             if ((cp1 = strchr(environ[i],'=')) && 
                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
 #ifdef HAS_SETENV
-              return setenv(lnm,eqv,1) ? vaxc$errno : 0;
+              return setenv(lnm,"",1) ? vaxc$errno : 0;
             }
           }
           ivenv = 1; retsts = SS$_NOLOGNAM;
@@ -730,6 +733,30 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 }
 /*}}}*/
 
+/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/*  vmssetuserlnm
+ *  sets a user-mode logical in the process logical name table
+ *  used for redirection of sys$error
+ */
+void
+Perl_vmssetuserlnm(char *name, char *eqv)
+{
+    $DESCRIPTOR(d_tab, "LNM$PROCESS");
+    struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+    unsigned long int iss, attr = 0;
+    unsigned char acmode = PSL$C_USER;
+    struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
+                                 {0, 0, 0, 0}};
+    d_name.dsc$a_pointer = name;
+    d_name.dsc$w_length = strlen(name);
+
+    lnmlst[0].buflen = strlen(eqv);
+    lnmlst[0].bufadr = eqv;
+
+    iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
+    if (!(iss&1)) lib$signal(iss);
+}
+/*}}}*/
 
 
 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
@@ -1843,17 +1870,19 @@ vmspipe_tempfile(void)
     fprintf(fp,"$ perl_del    = \"delete\"\n");
     fprintf(fp,"$ pif         = \"if\"\n");
     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
-    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define sys$input  'perl_popen_in'\n");
-    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error  'perl_popen_err'\n");
+    fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user sys$input  'perl_popen_in'\n");
+    fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user sys$error  'perl_popen_err'\n");
+    fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
     fprintf(fp,"$ cmd = perl_popen_cmd\n");
     fprintf(fp,"$!  --- get rid of global symbols\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
+    fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
     fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
     fprintf(fp,"$ perl_on\n");
     fprintf(fp,"$ 'cmd\n");
     fprintf(fp,"$ perl_status = $STATUS\n");
-    fprintf(fp,"$ perl_del 'perl_cfile'\n");
+    fprintf(fp,"$ perl_del  'perl_cfile'\n");
     fprintf(fp,"$ perl_exit 'perl_status'\n");
     fsync(fileno(fp));
 
@@ -1892,12 +1921,12 @@ safe_popen(char *cmd, char *mode)
     pInfo info;
     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, symbol};
-    struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
-                                      DSC$K_CLASS_S, out};
     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, 0};
+
     $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
+    $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
                             
     /* once-per-program initialization...
@@ -1958,9 +1987,9 @@ safe_popen(char *cmd, char *mode)
     info->in_done    = TRUE;
     info->out_done   = TRUE;
     info->err_done   = TRUE;
+    in[0] = out[0] = err[0] = '\0';
 
     if (*mode == 'r') {             /* piping from subroutine */
-        in[0] = '\0';
 
         info->out = pipe_infromchild_setup(mbx,out);
         if (info->out) {
@@ -1979,13 +2008,13 @@ safe_popen(char *cmd, char *mode)
                 if (!done) _ckvmssts(sys$clref(pipe_ef));
                 _ckvmssts(sys$setast(1));
                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
-    }
+            }
 
             if (info->out->buf) Safefree(info->out->buf);
             Safefree(info->out);
             Safefree(info);
             return Nullfp;
-    }
+        }
 
         info->err = pipe_mbxtofd_setup(fileno(stderr), err);
         if (info->err) {
@@ -1995,7 +2024,6 @@ safe_popen(char *cmd, char *mode)
         }
 
     } else {                        /* piping to subroutine , mode=w*/
-        int melded;
 
         info->in = pipe_tochild_setup(in,mbx);
         info->fp  = PerlIO_open(mbx, mode);
@@ -2023,21 +2051,9 @@ safe_popen(char *cmd, char *mode)
             if (info->in->buf) Safefree(info->in->buf);
             Safefree(info->in);
             Safefree(info);
-        return Nullfp;
+            return Nullfp;
         }
         
-        /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
-        
-        melded = FALSE;
-        fgetname(stderr, err);
-        if (strncmp(err,"SYS$ERROR:",10) == 0) {
-            fgetname(stdout, out);
-            if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
-                if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
-                    melded = TRUE;
-                }
-    }
-    }
 
         info->out = pipe_mbxtofd_setup(fileno(stdout), out);
         if (info->out) {
@@ -2045,18 +2061,14 @@ safe_popen(char *cmd, char *mode)
             info->out_done = FALSE;
             info->out->info = info;
         }
-        if (!melded) {
-            info->err = pipe_mbxtofd_setup(fileno(stderr), err);
-            if (info->err) {
-                info->err->pipe_done = &info->err_done;
-                info->err_done = FALSE;
-                info->err->info = info;
-    }
-        } else {
-            err[0] = '\0';
-    }
+
+        info->err = pipe_mbxtofd_setup(fileno(stderr), err);
+        if (info->err) {
+            info->err->pipe_done = &info->err_done;
+            info->err_done = FALSE;
+            info->err->info = info;
+        }
     }
-    d_out.dsc$w_length = strlen(out);   /* lib$spawn sets SYS$OUTPUT so can meld*/
 
     symbol[MAX_DCL_SYMBOL] = '\0';
 
@@ -2068,6 +2080,9 @@ safe_popen(char *cmd, char *mode)
     d_symbol.dsc$w_length = strlen(symbol);
     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
 
+    strncpy(symbol, out, MAX_DCL_SYMBOL);
+    d_symbol.dsc$w_length = strlen(symbol);
+    _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
 
     p = VMScmd.dsc$a_pointer;
     while (*p && *p != '\n') p++;
@@ -2084,7 +2099,7 @@ safe_popen(char *cmd, char *mode)
     info->next=open_pipes;  /* prepend to list */
     open_pipes=info;
     _ckvmssts(sys$setast(1));
-    _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
+    _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
                       0, &info->pid, &info->completion,
                       0, popen_completion_ast,info,0,0,0));
 
@@ -2098,7 +2113,7 @@ safe_popen(char *cmd, char *mode)
     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
-
+    _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
     vms_execfree(aTHX);
         
     PL_forkprocess = info->pid;
@@ -3572,9 +3587,12 @@ mp_getredirection(pTHX_ int *ac, char ***av)
        PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
        exit(vaxc$errno);
        }
+       if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
+
     if (err != NULL) {
         if (strcmp(err,"&1") == 0) {
             dup2(fileno(stdout), fileno(Perl_debug_log));
+            Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
         } else {
        FILE *tmperr;
        if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
@@ -3587,6 +3605,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
                {
                exit(vaxc$errno);
                }
+           Perl_vmssetuserlnm("SYS$ERROR",err);
        }
         }
 #ifdef ARGPROC_DEBUG
index 8d2a628..17c5a00 100644 (file)
@@ -709,6 +709,7 @@ int Perl_rmscopy (pTHX_ char *, char *, int);
 #endif
 char * my_getenv_len (const char *, unsigned long *, bool);
 int    vmssetenv (char *, char *, struct dsc$descriptor_s **);
+void   Perl_vmssetuserlnm(char *name, char *eqv);
 char * my_crypt (const char *, const char *);
 Pid_t  my_waitpid (Pid_t, int *, int);
 char * my_gconvert (double, int, int, char *);
index bbb4461..652783e 100644 (file)
@@ -6,12 +6,14 @@ $ perl_exit   = "exit"
 $ perl_del    = "delete"
 $ pif         = "if"
 $!  --- define i/o redirection (sys$output set by lib$spawn)
-$ pif perl_popen_in  .nes. "" then perl_define sys$input  'perl_popen_in'
-$ pif perl_popen_err .nes. "" then perl_define sys$error  'perl_popen_err'
+$ pif perl_popen_in  .nes. "" then perl_define/user sys$input  'perl_popen_in'
+$ pif perl_popen_err .nes. "" then perl_define/user sys$error  'perl_popen_err'
+$ pif perl_popen_out .nes. "" then perl_define      sys$output 'perl_popen_out'
 $ cmd = perl_popen_cmd
 $!  --- get rid of global symbols
 $ perl_del/symbol/global perl_popen_in
 $ perl_del/symbol/global perl_popen_err
+$ perl_del/symbol/global perl_popen_out
 $ perl_del/symbol/global perl_popen_cmd
 $ perl_on
 $ 'cmd
index 9af03d1..ba0856a 100644 (file)
@@ -1,6 +1,32 @@
 This file documents the changes made to port Perl to the Stratus
 VOS operating system.
 
+For 5.7:
+     Updated "build.cm" to build perl using either the alpha or GA
+          version of POSIX.
+     Updated "Changes".
+     Updated "compile_perl.cm" to use either the alpha or GA
+          version of POSIX.
+     Split "config.def" into config.alpha.def and config.ga.def;
+          one for each version. Use the configure_perl.cm macro
+          to select the appropriate version.
+     Split "config.h" into config.alpha.h and config.ga.h. Use the
+          configure_perl.cm macro to select the appropriate version.
+     Updated "config.pl". It now diagnoses undefined (missing) and
+          unused substitution variables. When a new version of
+          Perl comes out, run "configure_perl.cm", add any missing
+          definitions to config.*.def, and remove any unused
+          definitions.
+     Removed "config_h.SH_orig". It is no longer needed.
+     Added "configure_perl.cm". It is used to configure perl so that
+          it can be built with either version of VOS POSIX.1 support.
+     Added "install_perl.cm" to install Perl into the appropriate
+          system directories.
+     Updated "perl.bind" to work with either the alpha or GA
+          version of POSIX.
+     Updated "vosish.h" to just use the standard "unixish.h" since
+          there are no changes needed at this time.
+
 After 5.005_63:
      Supplied "config.pl" perl script that takes "config_h.SH_orig"
           and "config.def" as input and produces "config.h.new".
index 8719d05..f749538 100644 (file)
@@ -2,6 +2,8 @@
      cpu       option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020
      recompile switch(-recompile),=1
      rebind    switch(-rebind),=1
+     tgt_mod   option(-target_module)module_name,='(current_module)'
+     version   option(-version)name,allow(alpha,ga),=ga
 &end_parameters
 &echo command_lines
 &
 & necessary, to assign the correct pathname of the directory that
 & contains VOS POSIX.1 support.
 &
-&set_string POSIX >vos_ftp_site>pub>vos>alpha>posix
+&if &version& = alpha
+&then &set_string POSIX >vos_ftp_site>pub>vos>alpha>posix
+&else &set_string POSIX >system>posix_object_library
 &
 & See if the site has VOS POSIX.1 support loaded. If not, quit now.
 &
 &if ^ (exists &POSIX& -directory)
 &then &do
       &display_line build: VOS POSIX.1 support not found. &POSIX&
-      &return
+      &return 1
+      &end
+&
+&if &cpu& = mc68020 & &version& = ga | &cpu& = i80860 & &version& = ga
+&then &do
+      &display_line build: "-version ga" is incompatible with "-processor mc68020 or i80860"
+      &return 1
       &end
 &
 & Set up the appropriate directory suffix for each architecture.
 &if &recompile& = 0
 &then &goto CHECK_REBIND
 &
-!set_library_paths include << < &POSIX&>incl &+
+&if &version& = alpha
+&then !set_library_paths include << < &POSIX&>incl &+
+     (master_disk)>system>include_library
+&else !set_library_paths include << < &+
+     (master_disk)>system>stcp>include_library &+
      (master_disk)>system>include_library
 &
 &if (exists *.obj -link)
 & Suppress several harmless compiler warning and advice messages.
 & Use -list -show_include all -show_macros both_ways when debugging.
 &
-&set_string cflags '-u -O4 -D_POSIX_C_SOURCE=199309L -DPERL_CORE'
+&set_string cflags '-u -O4 -D_POSIX_C_SOURCE=199506L -DPERL_CORE'
+&
+& The following is a work-around for stcp-1437,8,9
+&
+&if &version& = ga
+&then &set_string cflags &cflags& -D_BSD_SOURCE
 &
 !cc <<av.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
 &   &if (command_status) ^= 0 &then &return
 !cc <<mg.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
-!cc <<miniperlmain.c -suppress_diag 2006 &cpu& &cflags&
+!cc <<miniperlmain.c -suppress_diag 2006 2065 &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
 !cc <<op.c -suppress_diag 2006 2064 2065 &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
+&
+& We are essentially building miniperl for now. Until we
+& get a POSIX shell on VOS we won't add any of the extensions.
+&
+& !link <<op.c opmini.c -delete
+& &if (command_status) ^= 0 &then &return
+& !cc opmini.c -suppress_diag 2006 2064 2065 &cpu& &cflags& -DPERL_EXTERNAL_GLOB
+& &if (command_status) ^= 0 &then &return
+& !unlink opmini.c
+& &if (command_status) ^= 0 &then &return
+&
 !cc <<perl.c -suppress_diag 2006 2053 2065 &cpu& &cflags& &+
-     -DARCHLIB="/system/ported/perl/lib/5.005&obj2&" &+
-     -DARCHLIB_EXP="/system/ported/perl/lib/5.005&obj2&" &+
-     -DSITEARCH="/system/ported/perl/lib/site/5.005&obj2&" &+
-     -DSITEARCH_EXP="/system/ported/perl/lib/site/5.005&obj2&"
+     -DARCHLIB="/system/ported/perl/lib/5.7&obj2&" &+
+     -DARCHLIB_EXP="/system/ported/perl/lib/5.7&obj2&" &+
+     -DSITEARCH="/system/ported/perl/lib/site/5.7&obj2&" &+
+     -DSITEARCH_EXP="/system/ported/perl/lib/site/5.7&obj2&"
 &if (command_status) ^= 0 &then &return
 !cc <<perlapi.c &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
 &if (command_status) ^= 0 &then &return
 !cc <<xsutils.c &cpu& &cflags&
 &if (command_status) ^= 0 &then &return
+&if &version& = alpha
+&then &do
 !cc <vos_dummies.c &cpu& -O4
 &if (command_status) ^= 0 &then &return
+&end
 &
 & If requested, bind the executable program module.
 &
 &then &set_string tcp_objlib (master_disk)>system>tcp_os>object_library&obj2&
 &else &set_string tcp_objlib (master_disk)>system>tcp_os>object_library
 &
+&if (exists -directory (master_disk)>system>stcp>object_library&obj2&)
+&then &set_string stcp_objlib (master_disk)>system>stcp>object_library&obj2&
+&else &set_string stcp_objlib (master_disk)>system>stcp>object_library
+&
 &if (exists -directory (master_disk)>system>object_library&obj2&)
 &then &set_string objlib (master_disk)>system>object_library&obj2&
 &else &set_string objlib (master_disk)>system>object_library
 &then &set_string c_objlib (master_disk)>system>c_object_library&obj2&
 &else &set_string c_objlib (master_disk)>system>c_object_library
 &
-!set_library_paths object . &+
-     &POSIX&>c>runtime>obj&obj& &+
+&if (exists -directory (master_disk)>system>posix_object_library&obj2&)
+&then &set_string posix_objlib (master_disk)>system>posix_object_library&obj2&
+&else &set_string posix_objlib (master_disk)>system>posix_object_library
+&
+&if &version& = alpha
+&then !set_library_paths object . &tcp_objlib& &+
      &POSIX&>c>sysv_runtime>obj&obj& &+
-     &tcp_objlib& &objlib& &c_objlib&
-!bind -control <perl.bind &cpu& -map
+     &POSIX&>c>runtime>obj&obj& &+
+     &c_objlib& &objlib&
+&else !set_library_paths object . &stcp_objlib& &+
+     &stcp_objlib&>common &+
+     &stcp_objlib&>net &+
+     &stcp_objlib&>sbsd &+
+     &stcp_objlib&>socket &+
+     &posix_objlib&>bsd &+
+     &posix_objlib& &+
+     &c_objlib& &objlib&
+&if &version& = alpha
+&then !bind -control <perl.bind vos_dummies &+
+     &tcp_objlib&>tcp_runtime &tcp_objlib&>tcp_gethost &+
+     &cpu& -target_module &tgt_mod& -map
+&else !bind -control <perl.bind &cpu& -target_module &tgt_mod& -map
 &if (command_status) ^= 0 &then &return
 !delete_file *.obj -no_ask -brief
 !unlink *.obj -no_ask -brief
index 86a8d6a..f8ecf3b 100644 (file)
@@ -3,12 +3,15 @@
 & build macro in that subdirectory to create the perl
 & executable program module file.
 & Written 99-02-03 by Paul Green (Paul_Green@stratus.com)
+& Modified 00-10-24 by Paul Green
 &
 &begin_parameters
-     cpu       option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020
+     cpu       option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=pa7100
      recompile switch(-recompile),=1
      rebind    switch(-rebind),=1
      module    option(-module)module_name,='(current_module)'
+     tgt_mod   option(-target_module)module_name,='(current_module)'
+     version   option(-version)name,allow(alpha,ga),=ga
 &end_parameters
 &echo command_lines
 &
@@ -35,6 +38,9 @@
 &if ^ (exists obj&obj&>build.out)
 &then !create_file obj&obj&>build.out ; set_implicit_locking obj&obj&>build.out
 &
+!configure_perl -version &version&
+&
 !change_current_dir obj&obj&
-!start_process (string <build -processor &cpu& &recompile& &rebind&) -module &module&
+!start_process (string <build -processor &cpu& &recompile& &rebind& &+
+     -target_module &tgt_mod& -version &version&) -module &module&
 !change_current_dir <
similarity index 94%
copy from vos/config.def
copy to vos/config.alpha.def
index 4edc806..7a20937 100644 (file)
@@ -8,13 +8,15 @@ $binexp='/system/ported/command_library'
 $byteorder='4321'
 $castflags='0'
 $cf_by='Paul_Green@stratus.com'
-$cf_time='2000-02-03 19:13 UCT'
+$cf_time='2000-10-23 18:48 UCT'
+$CONFIG_SH='config.sh'
 $cpp_stuff='42'
 $cpplast='-'
 $cppminus='-'
 $cpprun='cc -E -'
 $cppstdin='cc -E'
 $crosscompile='undef'
+$d__fwalk='undef'
 $d_access='undef'
 $d_accessx='undef'
 $d_alarm='define'
@@ -57,6 +59,7 @@ $d_eofnblk='define'
 $d_fchmod='define'
 $d_fchown='undef'
 $d_fcntl='define'
+$d_fcntl_can_lock='define'
 $d_fd_set='undef'
 $d_fgetpos='define'
 $d_flexfnam='define'
@@ -70,6 +73,7 @@ $d_fseeko='undef'
 $d_fsetpos='define'
 $d_fstatfs='undef'
 $d_fstatvfs='undef'
+$d_fsync='undef'
 $d_ftello='undef'
 $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
 $d_getcwd='define'
@@ -89,6 +93,7 @@ $d_getnbyaddr='define'
 $d_getnbyname='define'
 $d_getnent='define'
 $d_getnetprotos='define'
+$d_getpagsz='undef'
 $d_getpbyname='define'
 $d_getpbynumber='define'
 $d_getpent='define'
@@ -115,7 +120,7 @@ $d_index='undef'
 $d_inetaton='undef'
 $d_int64_t='undef'
 $d_isascii='define'
-$d_isnan='define'
+$d_isnan='undef'
 $d_isnanl='undef'
 $d_killpg='undef'
 $d_lchown='undef'
@@ -170,9 +175,6 @@ $d_poll='define'
 $d_PRIeldbl='define'
 $d_PRIfldbl='define'
 $d_PRIgldbl='define'
-$d_PRIEUldbl='define'
-$d_PRIFUldbl='define'
-$d_PRIGUldbl='define'
 $d_pthread_yield='undef'
 $d_pwage='undef'
 $d_pwchange='undef'
@@ -182,7 +184,6 @@ $d_pwexpire='undef'
 $d_pwgecos='undef'
 $d_pwpasswd='undef'
 $d_pwquota='undef'
-$d_qgcvt='undef'
 $d_quad='undef'
 $d_readdir='define'
 $d_readlink='define'
@@ -192,8 +193,10 @@ $d_rmdir='define'
 $d_safebcpy='undef'
 $d_safemcpy='undef'
 $d_sanemcmp='define'
+$d_sbrkproto='undef'
 $d_sched_yield='undef'
 $d_scm_rights='undef'
+$d_SCNfldbl='define'
 $d_seekdir='undef'
 $d_select='define'
 $d_sem='undef'
@@ -228,7 +231,6 @@ $d_shm='undef'
 $d_shmatprototype='define'
 $d_sigaction='undef'
 $d_sigsetjmp='undef'
-$d_sitearch='undef'
 $d_socket='define'
 $d_sockpair='undef'
 $d_socks5_init='undef'
@@ -238,6 +240,8 @@ $d_statfs_f_flags='undef'
 $d_statfs_s='undef'
 $d_stdio_cnt_lval='define'
 $d_stdio_ptr_lval='define'
+$d_stdio_ptr_lval_sets_cnt='undef'
+$d_stdio_ptr_lval_nochange_cnt='undef'
 $d_stdio_stream_array='define'
 $d_stdiobase='define'
 $d_stdstdio='define'
@@ -250,6 +254,7 @@ $d_strtod='define'
 $d_strtol='define'
 $d_strtold='undef'
 $d_strtoll='undef'
+$d_strtoq='undef'
 $d_strtoul='define'
 $d_strtoull='undef'
 $d_strtouq='undef'
@@ -314,7 +319,7 @@ $i_dirent='define'
 $i_dlfcn='undef'
 $i_fcntl='define'
 $i_float='define'
-$i_grp='undef'
+$i_grp='define'
 $i_iconv='undef'
 $i_ieeefp='undef'
 $i_inttypes='undef'
@@ -333,7 +338,7 @@ $i_niin='define'
 $i_poll='undef'
 $i_prot='undef'
 $i_pthread='undef'
-$i_pwd='undef'
+$i_pwd='define'
 $i_rpcsvcdbm='undef'
 $i_sfio='undef'
 $i_sgtty='undef'
@@ -390,9 +395,11 @@ $longsize='4'
 $lseeksize='4'
 $lseektype='off_t'
 $malloctype='void *'
+$mmaptype='void *'
 $modetype='mode_t'
 $multiarch='undef'
 $myuname='VOS'
+$need_va_copy='undef'
 $netdb_hlen_type='int'
 $netdb_host_type='char *'
 $netdb_name_type='char *'
@@ -430,15 +437,17 @@ $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,
 $signal_t='void'
 $sitearch=''
 $sitearchexp=''
-$sitelib='/system/ported/perl/lib/site/5.005'
-$sitelibexp='/system/ported/perl/lib/site/5.005'
+$sitelib='/system/ported/perl/lib/site/5.7'
+$sitelibexp='/system/ported/perl/lib/site/5.7'
 $sitelib_stem='/system/ported/perl/lib/site'
 $sizesize='4'
 $sizetype='size_t'
 $socksizetype='int'
+$sPRIeldbl='"Le"'
 $sPRIfldbl='"Lf"'
 $sPRIgldbl='"Lg"'
-$src='%es#lang/vos_ftp_site/pub/vos/alpha/perl'
+$src='/vos_ftp_site/pub/vos/posix/(alpha|ga)/perl'
+$sSCNfldbl='"Lf"'
 $ssizetype='ssize_t'
 $startperl='!perl.pm'
 $stdchar='unsigned char'
@@ -460,6 +469,7 @@ $uidformat='"d"'
 $uidsize='4'
 $uidsign='-1'
 $uidtype='uid_t'
+$undef='$undef'
 $uquadtype='_error_'
 $use5005threads='undef'
 $use64bitall='undef'
@@ -472,7 +482,6 @@ $usemorebits='undef'
 $usemultiplicity='undef'
 $useperlio='undef'
 $usesocks='undef'
-$usethreads='undef'
 $uvoformat='"o"'
 $uvsize='4'
 $uvtype='unsigned int'
@@ -482,6 +491,5 @@ $vendorarch=''
 $vendorarchexp=''
 $vendorlib_stem=''
 $vendorlibexp=''
-$versiononly='undef'
 $voidflags='15'
 $xs_apiversion='5.00563'
similarity index 96%
rename from vos/config.h
rename to vos/config.alpha.h
index 985e6ea..aaeb129 100644 (file)
@@ -1,19 +1,19 @@
 /*
  * This file was produced by running the config_h.SH script, which
- * gets its values from $CONFIG_SH, which is generally produced by
+ * gets its values from config.sh, 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 $CONFIG_SH and rerun config_h.SH.
+ * For a more permanent change edit config.sh and rerun config_h.SH.
  *
  * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
  */
 
 /*
  * Package name      : perl5
- * Source directory  : %es#lang/vos_ftp_site/pub/vos/alpha/perl
- * Configuration time: 2000-02-03 19:13 UCT
+ * Source directory  : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
+ * Configuration time: 2000-10-23 18:48 UCT
  * Configured by     : Paul_Green@stratus.com
  * Target system     : VOS
  */
  */
 #define HAS_FCNTL              /**/
 
+/* 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           / **/
+
+/* 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_FGETPOS:
  *     This symbol, if defined, indicates that the fgetpos routine is
  *     available to get the file position indicator, similar to ftell().
  */
 #define HAS_GETLOGIN           /**/
 
+/* 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_GETPGID:
  *     This symbol, if defined, indicates to the C program that 
  *     the getpgid(pid) function is available to get the
  */
 /*#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).
  *     This symbol, if defined, indicates that the isnan routine is
  *     available to check whether a double is a NaN.
  */
-#define HAS_ISNAN              /**/
+/*#define HAS_ISNAN            /**/
 
 /* HAS_ISNANL:
  *     This symbol, if defined, indicates that the isnanl routine is
  *     Usually set to 'void *' or 'cadd_t'.
  */
 /*#define HAS_MMAP             /**/
-#define Mmap_t $mmaptype       /**/
+#define Mmap_t void *  /**/
 
 /* HAS_MODFL:
  *     This symbol, if defined, indicates that the modfl routine is
  */
 #define HAS_SANE_MEMCMP        /**/
 
+/* 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_SEM:
  *     This symbol, if defined, indicates that the entire sem*(2) library is
  *     supported.
  *     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:
  */
 /*#define HAS_STRTOLL          /**/
 
+/* HAS_STRTOQ:
+ *     This symbol, if defined, indicates that the strtouq routine is
+ *     available to convert strings to long longs (quads).
+ */
+/*#define HAS_STRTOQ           /**/
+
+/* HAS_STRTOQ:
+ *     This symbol, if defined, indicates that the strtouq 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.
  *     This symbol, if defined, indicates to the C program that struct group
  *     in <grp.h> contains gr_passwd.
  */
-/*#define I_GRP                /**/
+#define I_GRP          /**/
 /*#define GRPASSWD     /**/
 
 /* I_ICONV:
  *     This symbol, if defined, indicates to the C program that struct passwd
  *     contains pw_passwd.
  */
-/*#define I_PWD                /**/
+#define I_PWD          /**/
 /*#define PWQUOTA      /**/
 /*#define PWAGE        /**/
 /*#define PWCHANGE     /**/
  */
 #define PERL_PRIfldbl  "Lf"    /**/
 #define PERL_PRIgldbl  "Lg"    /**/
-#define PERL_PRIeldbl  $sPRIeldbl      /**/
-# PERL_SCNfldbl        $sSCNfldbl      /**/
+#define PERL_PRIeldbl  "Le"    /**/
+#define PERL_SCNfldbl  "Lf"    /**/
 
 /* Off_t:
  *     This symbol holds the type used to declare offsets in the kernel.
  *     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 ""            /**/
-#define SITEARCH_EXP ""                /**/
+/*#define SITEARCH ""          /**/
+/*#define SITEARCH_EXP ""              /**/
 
 /* SITELIB:
  *     This symbol contains the name of the private library for this package.
  *     removed.  The elements in inc_version_list (inc_version_list.U) can
  *     be tacked onto this variable to generate a list of directories to search.
  */
-#define SITELIB "/system/ported/perl/lib/site/5.005"           /**/
-#define SITELIB_EXP "/system/ported/perl/lib/site/5.005"               /**/
+#define SITELIB "/system/ported/perl/lib/site/5.7"             /**/
+#define SITELIB_EXP "/system/ported/perl/lib/site/5.7"         /**/
 #define SITELIB_STEM "/system/ported/perl/lib/site"            /**/
 
 /* Size_t_size:
  *     compatible with the present perl.  (That is, pure perl modules
  *     written for pm_apiversion will still work for the current
  *     version).  perl.c:incpush() and lib/lib.pm will automatically
- *     search in /system/ported/perl/lib/site/5.005 for older directories across major versions
+ *     search in /system/ported/perl/lib/site/5.7 for older directories across major versions
  *     back to pm_apiversion.  This is only useful if you have a perl
  *     library directory tree structured like the default one.  The
  *     versioned site_perl library was introduced in 5.005, so that's
 /*#define HAS_SETPGRP          /**/
 /*#define USE_BSD_SETPGRP      /**/
 
+/* 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            / **/
+
 #endif
similarity index 88%
rename from vos/config.def
rename to vos/config.ga.def
index 4edc806..46cbc20 100644 (file)
@@ -8,14 +8,16 @@ $binexp='/system/ported/command_library'
 $byteorder='4321'
 $castflags='0'
 $cf_by='Paul_Green@stratus.com'
-$cf_time='2000-02-03 19:13 UCT'
+$cf_time='2000-10-24 15:35 UCT'
+$CONFIG_SH='config.sh'
 $cpp_stuff='42'
 $cpplast='-'
 $cppminus='-'
 $cpprun='cc -E -'
 $cppstdin='cc -E'
 $crosscompile='undef'
-$d_access='undef'
+$d__fwalk='undef'
+$d_access='define'
 $d_accessx='undef'
 $d_alarm='define'
 $d_archlib='undef'
@@ -31,12 +33,12 @@ $d_bzero='undef'
 $d_casti32='undef'
 $d_castneg='define'
 $d_charvspr='undef'
-$d_chown='undef'
+$d_chown='define'
 $d_chroot='undef'
 $d_chsize='undef'
 $d_const='define'
 $d_crypt='undef'
-$d_csh='undef'
+$d_csh='define'
 $d_cuserid='undef'
 $d_dbl_dig='define'
 $d_difftime='define'
@@ -45,7 +47,7 @@ $d_dlerror='undef'
 $d_dlsymun='undef'
 $d_dosuid='undef'
 $d_drand48proto='undef'
-$d_dup2='undef'
+$d_dup2='define'
 $d_eaccess='undef'
 $d_endgrent='undef'
 $d_endhent='define'
@@ -57,11 +59,12 @@ $d_eofnblk='define'
 $d_fchmod='define'
 $d_fchown='undef'
 $d_fcntl='define'
+$d_fcntl_can_lock='define'
 $d_fd_set='undef'
 $d_fgetpos='define'
 $d_flexfnam='define'
 $d_flock='undef'
-$d_fork='undef'
+$d_fork='define'
 $d_fpathconf='define'
 $d_fpos64_t='undef'
 $d_frexpl='undef'
@@ -70,6 +73,7 @@ $d_fseeko='undef'
 $d_fsetpos='define'
 $d_fstatfs='undef'
 $d_fstatvfs='undef'
+$d_fsync='undef'
 $d_ftello='undef'
 $d_Gconvert='sprintf((b),"%.*g",(n),(x))'
 $d_getcwd='define'
@@ -89,6 +93,7 @@ $d_getnbyaddr='define'
 $d_getnbyname='define'
 $d_getnent='define'
 $d_getnetprotos='define'
+$d_getpagsz='undef'
 $d_getpbyname='define'
 $d_getpbynumber='define'
 $d_getpent='define'
@@ -115,7 +120,7 @@ $d_index='undef'
 $d_inetaton='undef'
 $d_int64_t='undef'
 $d_isascii='define'
-$d_isnan='define'
+$d_isnan='undef'
 $d_isnanl='undef'
 $d_killpg='undef'
 $d_lchown='undef'
@@ -142,7 +147,7 @@ $d_mkstemp='undef'
 $d_mkstemps='undef'
 $d_mkfifo='define'
 $d_mktime='define'
-$d_mmap='undef'
+$d_mmap='define'
 $d_modfl='undef'
 $d_mprotect='undef'
 $d_msg='undef'
@@ -152,7 +157,7 @@ $d_msg_oob='undef'
 $d_msg_peek='undef'
 $d_msg_proxy='undef'
 $d_msync='undef'
-$d_munmap='undef'
+$d_munmap='define'
 $d_mymalloc='undef'
 $d_nice='undef'
 $d_nv_preserves_uv='define'
@@ -170,9 +175,6 @@ $d_poll='define'
 $d_PRIeldbl='define'
 $d_PRIfldbl='define'
 $d_PRIgldbl='define'
-$d_PRIEUldbl='define'
-$d_PRIFUldbl='define'
-$d_PRIGUldbl='define'
 $d_pthread_yield='undef'
 $d_pwage='undef'
 $d_pwchange='undef'
@@ -182,7 +184,6 @@ $d_pwexpire='undef'
 $d_pwgecos='undef'
 $d_pwpasswd='undef'
 $d_pwquota='undef'
-$d_qgcvt='undef'
 $d_quad='undef'
 $d_readdir='define'
 $d_readlink='define'
@@ -192,23 +193,25 @@ $d_rmdir='define'
 $d_safebcpy='undef'
 $d_safemcpy='undef'
 $d_sanemcmp='define'
+$d_sbrkproto='undef'
 $d_sched_yield='undef'
 $d_scm_rights='undef'
+$d_SCNfldbl='define'
 $d_seekdir='undef'
 $d_select='define'
 $d_sem='undef'
 $d_semctl_semid_ds='undef'
 $d_semctl_semun='undef'
-$d_setegid='undef'
-$d_seteuid='undef'
+$d_setegid='define'
+$d_seteuid='define'
 $d_setgrent='undef'
 $d_setgrps='undef'
 $d_sethent='define'
-$d_setlinebuf='undef'
+$d_setlinebuf='define'
 $d_setlocale='define'
 $d_setnent='define'
 $d_setpent='define'
-$d_setpgid='undef'
+$d_setpgid='define'
 $d_setpgrp2='undef'
 $d_setpgrp='undef'
 $d_setprior='undef'
@@ -221,14 +224,13 @@ $d_setreuid='undef'
 $d_setrgid='undef'
 $d_setruid='undef'
 $d_setsent='define'
-$d_setsid='undef'
+$d_setsid='define'
 $d_setvbuf='define'
 $d_sfio='undef'
 $d_shm='undef'
 $d_shmatprototype='define'
-$d_sigaction='undef'
-$d_sigsetjmp='undef'
-$d_sitearch='undef'
+$d_sigaction='define'
+$d_sigsetjmp='define'
 $d_socket='define'
 $d_sockpair='undef'
 $d_socks5_init='undef'
@@ -238,6 +240,8 @@ $d_statfs_f_flags='undef'
 $d_statfs_s='undef'
 $d_stdio_cnt_lval='define'
 $d_stdio_ptr_lval='define'
+$d_stdio_ptr_lval_sets_cnt='undef'
+$d_stdio_ptr_lval_nochange_cnt='undef'
 $d_stdio_stream_array='define'
 $d_stdiobase='define'
 $d_stdstdio='define'
@@ -250,6 +254,7 @@ $d_strtod='define'
 $d_strtol='define'
 $d_strtold='undef'
 $d_strtoll='undef'
+$d_strtoq='undef'
 $d_strtoul='define'
 $d_strtoull='undef'
 $d_strtouq='undef'
@@ -260,8 +265,8 @@ $d_syscall='undef'
 $d_sysconf='define'
 $d_syserrlst='define'
 $d_system='define'
-$d_tcgetpgrp='undef'
-$d_tcsetpgrp='undef'
+$d_tcgetpgrp='define'
+$d_tcsetpgrp='define'
 $d_telldir='undef'
 $d_telldirproto='undef'
 $d_times='define'
@@ -277,7 +282,7 @@ $d_vfork='undef'
 $d_void_closedir='undef'
 $d_volatile='define'
 $d_vprintf='define'
-$d_wait4='undef'
+$d_wait4='define'
 $d_waitpid='define'
 $d_wcstombs='define'
 $d_wctomb='define'
@@ -293,7 +298,7 @@ $fflushall='undef'
 $fflushNULL='define'
 $fpostype='fpos_t'
 $freetype='void'
-$full_csh=''
+$full_csh='/system/ported/command_library/bash.pm'
 $full_sed='/system/ported/command_library/sed.pm'
 $gidformat='"d"'
 $gidsize='4'
@@ -314,7 +319,7 @@ $i_dirent='define'
 $i_dlfcn='undef'
 $i_fcntl='define'
 $i_float='define'
-$i_grp='undef'
+$i_grp='define'
 $i_iconv='undef'
 $i_ieeefp='undef'
 $i_inttypes='undef'
@@ -328,12 +333,12 @@ $i_mntent='undef'
 $i_ndbm='undef'
 $i_netdb='define'
 $i_neterrno='undef'
-$i_netinettcp='undef'
+$i_netinettcp='define'
 $i_niin='define'
 $i_poll='undef'
 $i_prot='undef'
 $i_pthread='undef'
-$i_pwd='undef'
+$i_pwd='define'
 $i_rpcsvcdbm='undef'
 $i_sfio='undef'
 $i_sgtty='undef'
@@ -390,9 +395,11 @@ $longsize='4'
 $lseeksize='4'
 $lseektype='off_t'
 $malloctype='void *'
+$mmaptype='void *'
 $modetype='mode_t'
 $multiarch='undef'
 $myuname='VOS'
+$need_va_copy='undef'
 $netdb_hlen_type='int'
 $netdb_host_type='char *'
 $netdb_name_type='char *'
@@ -422,23 +429,25 @@ $sched_yield=''
 $seedfunc='srand'
 $selectminbits='1'
 $selecttype='fd_set *'
-$sh='/bin/sh'
+$sh='/system/ported/command_library/bash.pm'
 $shmattype='void *'
 $shortsize='2'
-$sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","KILL","PIPE","QUIT","CHLD","CONT","STOP","TSTP","TTIN","TTOU","BUS","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0'
-$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,0'
+$sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0'
+$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,0'
 $signal_t='void'
 $sitearch=''
 $sitearchexp=''
-$sitelib='/system/ported/perl/lib/site/5.005'
-$sitelibexp='/system/ported/perl/lib/site/5.005'
+$sitelib='/system/ported/perl/lib/site/5.7'
+$sitelibexp='/system/ported/perl/lib/site/5.7'
 $sitelib_stem='/system/ported/perl/lib/site'
 $sizesize='4'
 $sizetype='size_t'
 $socksizetype='int'
+$sPRIeldbl='"Le"'
 $sPRIfldbl='"Lf"'
 $sPRIgldbl='"Lg"'
-$src='%es#lang/vos_ftp_site/pub/vos/alpha/perl'
+$src='/vos_ftp_site/pub/vos/posix/(alpha|ga)/perl'
+$sSCNfldbl='"Lf"'
 $ssizetype='ssize_t'
 $startperl='!perl.pm'
 $stdchar='unsigned char'
@@ -460,6 +469,7 @@ $uidformat='"d"'
 $uidsize='4'
 $uidsign='-1'
 $uidtype='uid_t'
+$undef='$undef'
 $uquadtype='_error_'
 $use5005threads='undef'
 $use64bitall='undef'
@@ -472,7 +482,6 @@ $usemorebits='undef'
 $usemultiplicity='undef'
 $useperlio='undef'
 $usesocks='undef'
-$usethreads='undef'
 $uvoformat='"o"'
 $uvsize='4'
 $uvtype='unsigned int'
@@ -482,6 +491,5 @@ $vendorarch=''
 $vendorarchexp=''
 $vendorlib_stem=''
 $vendorlibexp=''
-$versiononly='undef'
 $voidflags='15'
 $xs_apiversion='5.00563'
old mode 100755 (executable)
new mode 100644 (file)
similarity index 83%
rename from vos/config_h.SH_orig
rename to vos/config.ga.h
index a209e6d..d235ba1
@@ -1,45 +1,21 @@
-case "$CONFIG_SH" in
-'') CONFIG_SH=config.sh ;;
-esac
-case "$CONFIG_H" in
-'') CONFIG_H=config.h ;;
-esac
-case $CONFIG in
-'')
-       if test -f $CONFIG_SH; then TOP=.;
-       elif test -f ../$CONFIG_SH; then TOP=..;
-       elif test -f ../../$CONFIG_SH; then TOP=../..;
-       elif test -f ../../../$CONFIG_SH; then TOP=../../..;
-       elif test -f ../../../../$CONFIG_SH; then TOP=../../../..;
-       else
-               echo "Can't find $CONFIG_SH."; exit 1
-       fi
-       . $TOP/$CONFIG_SH
-       ;;
-esac
-case "$0" in
-*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
-esac
-echo "Extracting $CONFIG_H (with variable substitutions)"
-sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-def!#undef!'
 /*
  * This file was produced by running the config_h.SH script, which
- * gets its values from $CONFIG_SH, which is generally produced by
+ * gets its values from config.sh, 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 $CONFIG_SH and rerun config_h.SH.
+ * For a more permanent change edit config.sh and rerun config_h.SH.
  *
  * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
  */
 
 /*
- * Package name      : $package
- * Source directory  : $src
- * Configuration time: $cf_time
- * Configured by     : $cf_by
- * Target system     : $myuname
+ * Package name      : perl5
+ * Source directory  : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
+ * Configuration time: 2000-10-24 15:35 UCT
+ * Configured by     : Paul_Green@stratus.com
+ * Target system     : VOS
  */
 
 #ifndef _config_h_
@@ -48,19 +24,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* LOC_SED:
  *     This symbol holds the complete pathname to the sed program.
  */
-#define LOC_SED        "$full_sed"     /**/
+#define LOC_SED        "/system/ported/command_library/sed.pm" /**/
 
 /* HAS_ALARM:
  *     This symbol, if defined, indicates that the alarm routine is
  *     available.
  */
-#$d_alarm HAS_ALARM            /**/
+#define HAS_ALARM              /**/
 
 /* HASATTRIBUTE:
  *     This symbol indicates the C compiler can check for function attributes,
  *     such as printf formats. This is normally only supported by GNU cc.
  */
-#$d_attribut HASATTRIBUTE      /**/
+/*#define HASATTRIBUTE         /**/
 #ifndef HASATTRIBUTE
 #define __attribute__(_arg_)
 #endif
@@ -69,37 +45,37 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol is defined if the bcmp() routine is available to
  *     compare blocks of memory.
  */
-#$d_bcmp HAS_BCMP      /**/
+/*#define HAS_BCMP     /**/
 
 /* HAS_BCOPY:
  *     This symbol is defined if the bcopy() routine is available to
  *     copy blocks of memory.
  */
-#$d_bcopy HAS_BCOPY    /**/
+/*#define HAS_BCOPY    /**/
 
 /* HAS_BZERO:
  *     This symbol is defined if the bzero() routine is available to
  *     set a memory block to 0.
  */
-#$d_bzero HAS_BZERO    /**/
+/*#define HAS_BZERO    /**/
 
 /* HAS_CHOWN:
  *     This symbol, if defined, indicates that the chown routine is
  *     available.
  */
-#$d_chown HAS_CHOWN            /**/
+#define HAS_CHOWN              /**/
 
 /* HAS_CHROOT:
  *     This symbol, if defined, indicates that the chroot routine is
  *     available.
  */
-#$d_chroot HAS_CHROOT          /**/
+/*#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.
  */
-#$d_chsize     HAS_CHSIZE              /**/
+/*#define      HAS_CHSIZE              /**/
 
 /* HASCONST:
  *     This symbol, if defined, indicates that this C compiler knows about
@@ -107,7 +83,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     within your programs. The mere use of the "const" keyword will
  *     trigger the necessary tests.
  */
-#$d_const HASCONST     /**/
+#define HASCONST       /**/
 #ifndef HASCONST
 #define const
 #endif
@@ -116,13 +92,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that the crypt routine is available
  *     to encrypt passwords and the like.
  */
-#$d_crypt HAS_CRYPT            /**/
+/*#define HAS_CRYPT            /**/
 
 /* HAS_CUSERID:
  *     This symbol, if defined, indicates that the cuserid routine is
  *     available to get character login names.
  */
-#$d_cuserid HAS_CUSERID                /**/
+/*#define HAS_CUSERID          /**/
 
 /* HAS_DBL_DIG:
  *     This symbol, if defined, indicates that this system's <float.h>
@@ -130,20 +106,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     of significant digits in a double precision number.  If this
  *     symbol is not defined, a guess of 15 is usually pretty good.
  */
-#$d_dbl_dig HAS_DBL_DIG        /* */
+#define HAS_DBL_DIG    /* */
 
 /* HAS_DIFFTIME:
  *     This symbol, if defined, indicates that the difftime routine is
  *     available.
  */
-#$d_difftime HAS_DIFFTIME              /**/
+#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().
  */
-#$d_dlerror HAS_DLERROR        /**/
+/*#define HAS_DLERROR  /**/
 
 /* SETUID_SCRIPTS_ARE_SECURE_NOW:
  *     This symbol, if defined, indicates that the bug that prevents
@@ -162,56 +138,69 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     subprocesses to which it must pass the filename rather than the
  *     file descriptor of the script to be executed.
  */
-#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW     /**/
-#$d_dosuid DOSUID              /**/
+#define SETUID_SCRIPTS_ARE_SECURE_NOW  /**/
+/*#define DOSUID               /**/
 
 /* HAS_DUP2:
  *     This symbol, if defined, indicates that the dup2 routine is
  *     available to duplicate file descriptors.
  */
-#$d_dup2 HAS_DUP2      /**/
+#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().
  */
-#$d_fchmod HAS_FCHMOD          /**/
+#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().
  */
-#$d_fchown HAS_FCHOWN          /**/
+/*#define HAS_FCHOWN           /**/
 
 /* HAS_FCNTL:
  *     This symbol, if defined, indicates to the C program that
  *     the fcntl() function exists.
  */
-#$d_fcntl HAS_FCNTL            /**/
+#define HAS_FCNTL              /**/
+
+/* 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           / **/
+
+/* 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_FGETPOS:
  *     This symbol, if defined, indicates that the fgetpos routine is
  *     available to get the file position indicator, similar to ftell().
  */
-#$d_fgetpos HAS_FGETPOS        /**/
+#define HAS_FGETPOS    /**/
 
 /* HAS_FLOCK:
  *     This symbol, if defined, indicates that the flock routine is
  *     available to do file locking.
  */
-#$d_flock HAS_FLOCK            /**/
+/*#define HAS_FLOCK            /**/
 
 /* HAS_FORK:
  *     This symbol, if defined, indicates that the fork routine is
  *     available.
  */
-#$d_fork HAS_FORK              /**/
+#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().
  */
-#$d_fsetpos HAS_FSETPOS        /**/
+#define HAS_FSETPOS    /**/
 
 /* HAS_GETTIMEOFDAY:
  *     This symbol, if defined, indicates that the gettimeofday() system
@@ -219,7 +208,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
  *     The type "Timeval" should be used to refer to "struct timeval".
  */
-#$d_gettimeod HAS_GETTIMEOFDAY /**/
+/*#define HAS_GETTIMEOFDAY     /**/
 #ifdef HAS_GETTIMEOFDAY
 #define Timeval struct timeval /* Structure used by gettimeofday() */
 #endif
@@ -229,106 +218,113 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     available to get the list of process groups.  If unavailable, multiple
  *     groups are probably not supported.
  */
-#$d_getgrps HAS_GETGROUPS              /**/
+/*#define HAS_GETGROUPS                /**/
 
 /* HAS_GETLOGIN:
  *     This symbol, if defined, indicates that the getlogin routine is
  *     available to get the login name.
  */
-#$d_getlogin HAS_GETLOGIN              /**/
+#define HAS_GETLOGIN           /**/
+
+/* 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_GETPGID:
  *     This symbol, if defined, indicates to the C program that 
  *     the getpgid(pid) function is available to get the
  *     process group id.
  */
-#$d_getpgid HAS_GETPGID                /**/
+/*#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.
  */
-#$d_getpgrp2 HAS_GETPGRP2              /**/
+/*#define HAS_GETPGRP2         /**/
 
 /* HAS_GETPPID:
  *     This symbol, if defined, indicates that the getppid routine is
  *     available to get the parent process ID.
  */
-#$d_getppid HAS_GETPPID                /**/
+#define HAS_GETPPID            /**/
 
 /* HAS_GETPRIORITY:
  *     This symbol, if defined, indicates that the getpriority routine is
  *     available to get a process's priority.
  */
-#$d_getprior HAS_GETPRIORITY           /**/
+/*#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.
  */
-#$d_inetaton HAS_INET_ATON             /**/
+/*#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.
  */
-#$d_killpg HAS_KILLPG  /**/
+/*#define HAS_KILLPG   /**/
 
 /* HAS_LINK:
  *     This symbol, if defined, indicates that the link routine is
  *     available to create hard links.
  */
-#$d_link HAS_LINK      /**/
+/*#define HAS_LINK     /**/
 
 /* HAS_LOCALECONV:
  *     This symbol, if defined, indicates that the localeconv routine is
  *     available for numeric and monetary formatting conventions.
  */
-#$d_locconv HAS_LOCALECONV     /**/
+#define HAS_LOCALECONV /**/
 
 /* HAS_LOCKF:
  *     This symbol, if defined, indicates that the lockf routine is
  *     available to do file locking.
  */
-#$d_lockf HAS_LOCKF            /**/
+#define HAS_LOCKF              /**/
 
 /* HAS_LSTAT:
  *     This symbol, if defined, indicates that the lstat routine is
  *     available to do file stats on symbolic links.
  */
-#$d_lstat HAS_LSTAT            /**/
+#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.
  */
-#$d_mblen HAS_MBLEN            /**/
+#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.
  */
-#$d_mbstowcs   HAS_MBSTOWCS            /**/
+#define        HAS_MBSTOWCS            /**/
 
 /* HAS_MBTOWC:
  *     This symbol, if defined, indicates that the mbtowc routine is available
  *     to covert a multibyte to a wide character.
  */
-#$d_mbtowc HAS_MBTOWC          /**/
+#define HAS_MBTOWC             /**/
 
 /* HAS_MEMCMP:
  *     This symbol, if defined, indicates that the memcmp routine is available
  *     to compare blocks of memory.
  */
-#$d_memcmp HAS_MEMCMP  /**/
+#define HAS_MEMCMP     /**/
 
 /* HAS_MEMCPY:
  *     This symbol, if defined, indicates that the memcpy routine is available
  *     to copy blocks of memory.
  */
-#$d_memcpy HAS_MEMCPY  /**/
+#define HAS_MEMCPY     /**/
 
 /* HAS_MEMMOVE:
  *     This symbol, if defined, indicates that the memmove routine is available
@@ -336,20 +332,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
  *     own version.
  */
-#$d_memmove HAS_MEMMOVE        /**/
+#define HAS_MEMMOVE    /**/
 
 /* HAS_MEMSET:
  *     This symbol, if defined, indicates that the memset routine is available
  *     to set blocks of memory.
  */
-#$d_memset HAS_MEMSET  /**/
+#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.
  */
-#$d_mkdir HAS_MKDIR            /**/
+#define HAS_MKDIR              /**/
 
 /* HAS_MKFIFO:
  *     This symbol, if defined, indicates that the mkfifo routine is
@@ -357,31 +353,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     do it for you. However, if mkfifo is there, mknod might require
  *     super-user privileges which mkfifo will not.
  */
-#$d_mkfifo HAS_MKFIFO          /**/
+#define HAS_MKFIFO             /**/
 
 /* HAS_MKTIME:
  *     This symbol, if defined, indicates that the mktime routine is
  *     available.
  */
-#$d_mktime HAS_MKTIME          /**/
+#define HAS_MKTIME             /**/
 
 /* HAS_MSYNC:
  *     This symbol, if defined, indicates that the msync system call is
  *     available to synchronize a mapped file.
  */
-#$d_msync HAS_MSYNC            /**/
+/*#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().
  */
-#$d_munmap HAS_MUNMAP          /**/
+#define HAS_MUNMAP             /**/
 
 /* HAS_NICE:
  *     This symbol, if defined, indicates that the nice routine is
  *     available.
  */
-#$d_nice HAS_NICE              /**/
+/*#define HAS_NICE             /**/
 
 /* HAS_PATHCONF:
  *     This symbol, if defined, indicates that pathconf() is available
@@ -393,122 +389,122 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     to determine file-system related limits and options associated
  *     with a given open file descriptor.
  */
-#$d_pathconf HAS_PATHCONF              /**/
-#$d_fpathconf HAS_FPATHCONF            /**/
+#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.
  */
-#$d_pause HAS_PAUSE            /**/
+#define HAS_PAUSE              /**/
 
 /* HAS_PIPE:
  *     This symbol, if defined, indicates that the pipe routine is
  *     available to create an inter-process channel.
  */
-#$d_pipe HAS_PIPE              /**/
+#define HAS_PIPE               /**/
 
 /* HAS_POLL:
  *     This symbol, if defined, indicates that the poll routine is
  *     available to poll active file descriptors. You may safely
  *     include <poll.h> when this symbol is defined.
  */
-#$d_poll HAS_POLL              /**/
+#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.
  */
-#$d_readdir HAS_READDIR                /**/
+#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.
  */
-#$d_seekdir HAS_SEEKDIR                /**/
+/*#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.
  */
-#$d_telldir HAS_TELLDIR                /**/
+/*#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.
  */
-#$d_rewinddir HAS_REWINDDIR            /**/
+#define HAS_REWINDDIR          /**/
 
 /* HAS_READLINK:
  *     This symbol, if defined, indicates that the readlink routine is
  *     available to read the value of a symbolic link.
  */
-#$d_readlink HAS_READLINK              /**/
+#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.
  */
-#$d_rename HAS_RENAME  /**/
+#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.
  */
-#$d_rmdir HAS_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.
  */
-#$d_select HAS_SELECT  /**/
+#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.
  */
-#$d_setegid HAS_SETEGID                /**/
+#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.
  */
-#$d_seteuid HAS_SETEUID                /**/
+#define HAS_SETEUID            /**/
 
 /* 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.
  */
-#$d_setlinebuf HAS_SETLINEBUF          /**/
+#define HAS_SETLINEBUF         /**/
 
 /* HAS_SETLOCALE:
  *     This symbol, if defined, indicates that the setlocale routine is
  *     available to handle locale-specific ctype implementations.
  */
-#$d_setlocale HAS_SETLOCALE    /**/
+#define HAS_SETLOCALE  /**/
 
 /* HAS_SETPGID:
  *     This symbol, if defined, indicates that the setpgid(pid, gpid)
  *     routine is available to set process group ID.
  */
-#$d_setpgid HAS_SETPGID        /**/
+#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.
  */
-#$d_setpgrp2 HAS_SETPGRP2              /**/
+/*#define HAS_SETPGRP2         /**/
 
 /* HAS_SETPRIORITY:
  *     This symbol, if defined, indicates that the setpriority routine is
  *     available to set a process's priority.
  */
-#$d_setprior HAS_SETPRIORITY           /**/
+/*#define HAS_SETPRIORITY              /**/
 
 /* HAS_SETREGID:
  *     This symbol, if defined, indicates that the setregid routine is
@@ -520,8 +516,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     available to change the real, effective and saved gid of the current
  *     process.
  */
-#$d_setregid HAS_SETREGID              /**/
-#$d_setresgid HAS_SETRESGID            /**/
+/*#define HAS_SETREGID         /**/
+/*#define HAS_SETRESGID                /**/
 
 /* HAS_SETREUID:
  *     This symbol, if defined, indicates that the setreuid routine is
@@ -533,26 +529,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     available to change the real, effective and saved uid of the current
  *     process.
  */
-#$d_setreuid HAS_SETREUID              /**/
-#$d_setresuid HAS_SETRESUID            /**/
+/*#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.
  */
-#$d_setrgid HAS_SETRGID                /**/
+/*#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.
  */
-#$d_setruid HAS_SETRUID                /**/
+/*#define HAS_SETRUID          /**/
 
 /* HAS_SETSID:
  *     This symbol, if defined, indicates that the setsid routine is
  *     available to set the process group ID.
  */
-#$d_setsid HAS_SETSID  /**/
+#define HAS_SETSID     /**/
 
 /* Shmat_t:
  *     This symbol holds the return type of the shmat() system call.
@@ -565,8 +561,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 $shmattype     /**/
-#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/
+#define Shmat_t void * /**/
+#define HAS_SHMAT_PROTOTYPE    /**/
 
 /* HAS_STRCHR:
  *     This symbol is defined to indicate that the strchr()/strrchr()
@@ -577,105 +573,117 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol is defined to indicate that the index()/rindex()
  *     functions are available for string searching.
  */
-#$d_strchr HAS_STRCHR  /**/
-#$d_index HAS_INDEX    /**/
+#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.
  */
-#$d_strcoll HAS_STRCOLL        /**/
+#define HAS_STRCOLL    /**/
 
 /* 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.
  */
-#$d_strctcpy   USE_STRUCT_COPY /**/
+#define        USE_STRUCT_COPY /**/
 
 /* HAS_STRTOD:
  *     This symbol, if defined, indicates that the strtod routine is
  *     available to provide better numeric string conversion than atof().
  */
-#$d_strtod HAS_STRTOD  /**/
+#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.
  */
-#$d_strtol HAS_STRTOL  /**/
+#define HAS_STRTOL     /**/
+
+/* HAS_STRTOQ:
+ *     This symbol, if defined, indicates that the strtouq routine is
+ *     available to convert strings to long longs (quads).
+ */
+/*#define HAS_STRTOQ           /**/
+
+/* HAS_STRTOQ:
+ *     This symbol, if defined, indicates that the strtouq routine is
+ *     available to convert strings to long longs (quads).
+ */
+/*#define HAS_STRTOQ           /**/
 
 /* HAS_STRTOUL:
  *     This symbol, if defined, indicates that the strtoul routine is
  *     available to provide conversion of strings to unsigned long.
  */
-#$d_strtoul HAS_STRTOUL        /**/
+#define HAS_STRTOUL    /**/
 
 /* HAS_STRXFRM:
  *     This symbol, if defined, indicates that the strxfrm() routine is
  *     available to transform strings.
  */
-#$d_strxfrm HAS_STRXFRM        /**/
+#define HAS_STRXFRM    /**/
 
 /* HAS_SYMLINK:
  *     This symbol, if defined, indicates that the symlink routine is available
  *     to create symbolic links.
  */
-#$d_symlink HAS_SYMLINK        /**/
+#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.
  */
-#$d_syscall HAS_SYSCALL        /**/
+/*#define HAS_SYSCALL  /**/
 
 /* HAS_SYSCONF:
  *     This symbol, if defined, indicates that sysconf() is available
  *     to determine system related limits and options.
  */
-#$d_sysconf HAS_SYSCONF        /**/
+#define HAS_SYSCONF    /**/
 
 /* HAS_SYSTEM:
  *     This symbol, if defined, indicates that the system routine is
  *     available to issue a shell command.
  */
-#$d_system HAS_SYSTEM  /**/
+#define HAS_SYSTEM     /**/
 
 /* HAS_TCGETPGRP:
  *     This symbol, if defined, indicates that the tcgetpgrp routine is
  *     available to get foreground process group ID.
  */
-#$d_tcgetpgrp HAS_TCGETPGRP            /**/
+#define HAS_TCGETPGRP          /**/
 
 /* HAS_TCSETPGRP:
  *     This symbol, if defined, indicates that the tcsetpgrp routine is
  *     available to set foreground process group ID.
  */
-#$d_tcsetpgrp HAS_TCSETPGRP            /**/
+#define HAS_TCSETPGRP          /**/
 
 /* HAS_TRUNCATE:
  *     This symbol, if defined, indicates that the truncate routine is
  *     available to truncate files.
  */
-#$d_truncate HAS_TRUNCATE      /**/
+/*#define HAS_TRUNCATE /**/
 
 /* HAS_TZNAME:
  *     This symbol, if defined, indicates that the tzname[] array is
  *     available to access timezone names.
  */
-#$d_tzname HAS_TZNAME          /**/
+#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.
  */
-#$d_umask HAS_UMASK            /**/
+#define HAS_UMASK              /**/
 
 /* HASVOLATILE:
  *     This symbol, if defined, indicates that this C compiler knows about
  *     the volatile declaration.
  */
-#$d_volatile   HASVOLATILE     /**/
+#define        HASVOLATILE     /**/
 #ifndef HASVOLATILE
 #define volatile
 #endif
@@ -683,31 +691,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* HAS_WAIT4:
  *     This symbol, if defined, indicates that wait4() exists.
  */
-#$d_wait4 HAS_WAIT4    /**/
+#define HAS_WAIT4      /**/
 
 /* HAS_WAITPID:
  *     This symbol, if defined, indicates that the waitpid routine is
  *     available to wait for child process.
  */
-#$d_waitpid HAS_WAITPID        /**/
+#define HAS_WAITPID    /**/
 
 /* HAS_WCSTOMBS:
  *     This symbol, if defined, indicates that the wcstombs routine is
  *     available to convert wide character strings to multibyte strings.
  */
-#$d_wcstombs HAS_WCSTOMBS      /**/
+#define HAS_WCSTOMBS   /**/
 
 /* HAS_WCTOMB:
  *     This symbol, if defined, indicates that the wctomb routine is available
  *     to covert a wide character to a multibyte.
  */
-#$d_wctomb HAS_WCTOMB          /**/
+#define HAS_WCTOMB             /**/
 
 /* 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.
  */
-#$i_arpainet   I_ARPA_INET             /**/
+#define        I_ARPA_INET             /**/
 
 /* I_DBM:
  *     This symbol, if defined, indicates that <dbm.h> exists and should
@@ -717,8 +725,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
  *     should be included.
  */
-#$i_dbm I_DBM  /**/
-#$i_rpcsvcdbm I_RPCSVC_DBM     /**/
+/*#define I_DBM        /**/
+/*#define I_RPCSVC_DBM /**/
 
 /* I_DIRENT:
  *     This symbol, if defined, indicates to the C program that it should
@@ -736,166 +744,166 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     whether dirent is available or not. You should use this pseudo type to
  *     portably declare your directory entries.
  */
-#$i_dirent I_DIRENT            /**/
-#$d_dirnamlen DIRNAMLEN        /**/
-#define Direntry_t $direntrytype
+#define I_DIRENT               /**/
+/*#define DIRNAMLEN    /**/
+#define Direntry_t struct dirent
 
 /* I_DLFCN:
  *     This symbol, if defined, indicates that <dlfcn.h> exists and should
  *     be included.
  */
-#$i_dlfcn I_DLFCN              /**/
+/*#define I_DLFCN              /**/
 
 /* I_FCNTL:
  *     This manifest constant tells the C program to include <fcntl.h>.
  */
-#$i_fcntl I_FCNTL      /**/
+#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.
  */
-#$i_float I_FLOAT              /**/
+#define I_FLOAT                /**/
 
 /* 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.
  */
-#$i_limits I_LIMITS            /**/
+#define I_LIMITS               /**/
 
 /* I_LOCALE:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <locale.h>.
  */
-#$i_locale     I_LOCALE                /**/
+#define        I_LOCALE                /**/
 
 /* I_MATH:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <math.h>.
  */
-#$i_math I_MATH                /**/
+#define I_MATH         /**/
 
 /* I_MEMORY:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <memory.h>.
  */
-#$i_memory I_MEMORY            /**/
+/*#define I_MEMORY             /**/
 
 /* I_NDBM:
  *     This symbol, if defined, indicates that <ndbm.h> exists and should
  *     be included.
  */
-#$i_ndbm I_NDBM        /**/
+/*#define I_NDBM       /**/
 
 /* I_NET_ERRNO:
  *     This symbol, if defined, indicates that <net/errno.h> exists and 
  *     should be included.
  */
-#$i_neterrno I_NET_ERRNO               /**/
+/*#define I_NET_ERRNO          /**/
 
 /* 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>.
  */
-#$i_niin I_NETINET_IN  /**/
+#define I_NETINET_IN   /**/
 
 /* I_SFIO:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sfio.h>.
  */
-#$i_sfio       I_SFIO          /**/
+/*#define      I_SFIO          /**/
 
 /* I_STDDEF:
  *     This symbol, if defined, indicates that <stddef.h> exists and should
  *     be included.
  */
-#$i_stddef I_STDDEF    /**/
+#define I_STDDEF       /**/
 
 /* I_STDLIB:
  *     This symbol, if defined, indicates that <stdlib.h> exists and should
  *     be included.
  */
-#$i_stdlib I_STDLIB            /**/
+#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).
  */
-#$i_string I_STRING            /**/
+#define I_STRING               /**/
 
 /* I_SYS_DIR:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/dir.h>.
  */
-#$i_sysdir I_SYS_DIR           /**/
+/*#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.
  */
-#$i_sysfile I_SYS_FILE         /**/
+/*#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_sysioctl   I_SYS_IOCTL             /**/
+#define        I_SYS_IOCTL             /**/
 
 /* I_SYS_NDIR:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/ndir.h>.
  */
-#$i_sysndir I_SYS_NDIR /**/
+/*#define I_SYS_NDIR   /**/
 
 /* I_SYS_PARAM:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/param.h>.
  */
-#$i_sysparam I_SYS_PARAM               /**/
+/*#define I_SYS_PARAM          /**/
 
 /* I_SYS_RESOURCE:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/resource.h>.
  */
-#$i_sysresrc I_SYS_RESOURCE            /**/
+/*#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.
  */
-#$i_sysselct I_SYS_SELECT      /**/
+#define I_SYS_SELECT   /**/
 
 /* I_SYS_STAT:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/stat.h>.
  */
-#$i_sysstat    I_SYS_STAT              /**/
+#define        I_SYS_STAT              /**/
 
 /* I_SYS_TIMES:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/times.h>.
  */
-#$i_systimes   I_SYS_TIMES             /**/
+#define        I_SYS_TIMES             /**/
 
 /* I_SYS_TYPES:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/types.h>.
  */
-#$i_systypes   I_SYS_TYPES             /**/
+#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.
  */
-#$i_sysun I_SYS_UN             /**/
+/*#define I_SYS_UN             /**/
 
 /* I_SYS_WAIT:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/wait.h>.
  */
-#$i_syswait I_SYS_WAIT /**/
+#define I_SYS_WAIT     /**/
 
 /* I_TERMIO:
  *     This symbol, if defined, indicates that the program should include
@@ -913,21 +921,21 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     <sgtty.h> rather than <termio.h>.  There are also differences in
  *     the ioctl() calls that depend on the value of this symbol.
  */
-#$i_termio I_TERMIO            /**/
-#$i_termios I_TERMIOS          /**/
-#$i_sgtty I_SGTTY              /**/
+/*#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>.
  */
-#$i_unistd I_UNISTD            /**/
+#define I_UNISTD               /**/
 
 /* I_UTIME:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <utime.h>.
  */
-#$i_utime I_UTIME              /**/
+#define I_UTIME                /**/
 
 /* I_VALUES:
  *     This symbol, if defined, indicates to the C program that it should
@@ -935,7 +943,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     MAXLONG, i.e. machine dependant limitations.  Probably, you
  *     should use <limits.h> instead, if it is available.
  */
-#$i_values I_VALUES            /**/
+#define I_VALUES               /**/
 
 /* I_STDARG:
  *     This symbol, if defined, indicates that <stdarg.h> exists and should
@@ -945,14 +953,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates to the C program that it should
  *     include <varargs.h>.
  */
-#$i_stdarg I_STDARG            /**/
-#$i_varargs I_VARARGS  /**/
+#define I_STDARG               /**/
+/*#define I_VARARGS    /**/
 
 /* I_VFORK:
  *     This symbol, if defined, indicates to the C program that it should
  *     include vfork.h.
  */
-#$i_vfork I_VFORK      /**/
+/*#define I_VFORK      /**/
 
 /* CAN_PROTOTYPE:
  *     If defined, this macro indicates that the C compiler can handle
@@ -965,7 +973,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *
  *             int main _((int argc, char *argv[]));
  */
-#$prototype    CAN_PROTOTYPE   /**/
+#define        CAN_PROTOTYPE   /**/
 #ifdef CAN_PROTOTYPE
 #define        _(args) args
 #else
@@ -979,19 +987,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     /bin/pdksh, /bin/ash, /bin/bash, or even something such as
  *     D:/bin/sh.exe.
  */
-#define SH_PATH "$sh"  /**/
+#define SH_PATH "/system/ported/command_library/bash.pm"  /**/
 
 /* 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 $stdchar       /**/
+#define STDCHAR unsigned char  /**/
 
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
  */
-#$crosscompile CROSSCOMPILE            /**/
+/*#define CROSSCOMPILE         /**/
 
 /* INTSIZE:
  *     This symbol contains the value of sizeof(int) so that the C
@@ -1005,9 +1013,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol contains the value of sizeof(short) so that the C
  *     preprocessor can make decisions based on it.
  */
-#define INTSIZE $intsize               /**/
-#define LONGSIZE $longsize             /**/
-#define SHORTSIZE $shortsize           /**/
+#define INTSIZE 4              /**/
+#define LONGSIZE 4             /**/
+#define SHORTSIZE 2            /**/
 
 /* MULTIARCH:
  *     This symbol, if defined, signifies that the build
@@ -1016,18 +1024,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     example with the NeXT "fat" binaries that contain executables
  *     for several CPUs.
  */
-#$multiarch MULTIARCH          /**/
+/*#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, or QUAD_IS_INT64_T.
  */
-#$d_quad HAS_QUAD      /**/
+/*#define HAS_QUAD     /**/
 #ifdef HAS_QUAD
-#   define Quad_t $quadtype    /**/
-#   define Uquad_t $uquadtype  /**/
-#   define QUADKIND $quadkind  /**/
+#   define Quad_t _error_      /**/
+#   define Uquad_t _error_     /**/
+#   define QUADKIND _error_    /**/
 #   define QUAD_IS_INT 1
 #   define QUAD_IS_LONG        2
 #   define QUAD_IS_LONG_LONG   3
@@ -1038,32 +1046,32 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that the accessx routine is
  *     available to do extended access checks.
  */
-#$d_accessx HAS_ACCESSX                /**/
+/*#define HAS_ACCESSX          /**/
 
 /* HAS_EACCESS:
  *     This symbol, if defined, indicates that the eaccess routine is
  *     available to do extended access checks.
  */
-#$d_eaccess HAS_EACCESS                /**/
+/*#define HAS_EACCESS          /**/
 
 /* I_SYS_ACCESS:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/access.h>.
  */
-#$i_sysaccess   I_SYS_ACCESS                /**/
+/*#define   I_SYS_ACCESS                /**/
 
 /* I_SYS_SECURITY:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/security.h>.
  */
-#$i_syssecrt   I_SYS_SECURITY  /**/
+/*#define   I_SYS_SECURITY     /**/
 
 /* 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.
  */
-#define OSNAME "$osname"               /**/
+#define OSNAME "VOS"           /**/
 
 /* MEM_ALIGNBYTES:
  *     This symbol contains the number of bytes required to align a
@@ -1073,13 +1081,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #if defined(CROSSCOMPILE) || defined(MULTIARCH)
 #  define MEM_ALIGNBYTES 8
 #else
-#define MEM_ALIGNBYTES $alignbytes
+#define MEM_ALIGNBYTES 8
 #endif
 
 /* ARCHLIB:
  *     This variable, if defined, holds the name of the directory in
  *     which the user wants to put architecture-dependent public
- *     library files for $package.  It is most often a local directory
+ *     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
@@ -1089,8 +1097,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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.
  */
-#$d_archlib ARCHLIB "$archlib"         /**/
-#$d_archlib ARCHLIB_EXP "$archlibexp"          /**/
+/*#define ARCHLIB ""           /**/
+/*#define ARCHLIB_EXP ""               /**/
 
 /* ARCHNAME:
  *     This symbol holds a string representing the architecture name.
@@ -1098,19 +1106,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     where library files may be held under a private library, for
  *     instance.
  */
-#define ARCHNAME "$archname"           /**/
+#define ARCHNAME "vos"         /**/
 
 /* HAS_ATOLF:
  *     This symbol, if defined, indicates that the atolf routine is
  *     available to convert strings into long doubles.
  */
-#$d_atolf HAS_ATOLF            /**/
+/*#define HAS_ATOLF            /**/
 
 /* HAS_ATOLL:
  *     This symbol, if defined, indicates that the atoll routine is
  *     available to convert strings into long longs.
  */
-#$d_atoll HAS_ATOLL            /**/
+/*#define HAS_ATOLL            /**/
 
 /* BIN:
  *     This symbol holds the path of the bin directory where the package will
@@ -1120,8 +1128,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 "$bin"     /**/
-#define BIN_EXP "$binexp"      /**/
+#define BIN "/system/ported/command_library"   /**/
+#define BIN_EXP "/system/ported/command_library"       /**/
 
 /* PERL_BINCOMPAT_5005:
  *     This symbol, if defined, indicates that this version of Perl should be
@@ -1129,7 +1137,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     that use features like threads and multiplicity it is always $undef
  *     for those versions.
  */
-#$d_bincompat5005 PERL_BINCOMPAT_5005                  /**/
+/*#define PERL_BINCOMPAT_5005                  /**/
 
 /* BYTEORDER:
  *     This symbol holds the hexadecimal constant defined in byteorder,
@@ -1171,7 +1179,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #    define BYTEORDER 0x4321
 #  endif
 #else
-#define BYTEORDER 0x$byteorder /* large digits for MSB */
+#define BYTEORDER 0x4321       /* large digits for MSB */
 #endif /* NeXT */
 
 /* CAT2:
@@ -1180,12 +1188,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* STRINGIFY:
  *     This macro surrounds its token with double quotes.
  */
-#if $cpp_stuff == 1
+#if 42 == 1
 #define CAT2(a,b)      a/**/b
 #define STRINGIFY(a)   "a"
                /* If you can get stringification with catify, tell me how! */
 #endif
-#if $cpp_stuff == 42
+#if 42 == 42
 #define PeRl_CaTiFy(a, b)      a ## b  
 #define PeRl_StGiFy(a) #a
 /* the additional level of indirection enables these macros to be
@@ -1194,7 +1202,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 #define StGiFy(a)      PeRl_StGiFy(a)
 #define STRINGIFY(a)   PeRl_StGiFy(a)
 #endif
-#if $cpp_stuff != 1 && $cpp_stuff != 42
+#if 42 != 1 && 42 != 42
 #   include "Bletch: How does this C preprocessor catenate tokens?"
 #endif
 
@@ -1223,23 +1231,23 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol is intended to be used along with CPPRUN in the same manner
  *     symbol CPPMINUS is used with CPPSTDIN. It contains either "-" or "".
  */
-#define CPPSTDIN "$cppstdin"
-#define CPPMINUS "$cppminus"
-#define CPPRUN "$cpprun"
-#define CPPLAST "$cpplast"
+#define CPPSTDIN "cc -E"
+#define CPPMINUS "-"
+#define CPPRUN "cc -E -"
+#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.)
  */
-#$d_access HAS_ACCESS          /**/
+#define HAS_ACCESS             /**/
 
 /* CASTI32:
  *     This symbol is defined if the C compiler can cast negative
  *     or large floating point numbers to 32-bit ints.
  */
-#$d_casti32    CASTI32         /**/
+/*#define      CASTI32         /**/
 
 /* CASTNEGFLOAT:
  *     This symbol is defined if the C compiler can cast negative
@@ -1253,14 +1261,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *             2 = couldn't cast >= 0x80000000
  *             4 = couldn't cast in argument expression list
  */
-#$d_castneg    CASTNEGFLOAT            /**/
-#define CASTFLAGS $castflags           /**/
+#define        CASTNEGFLOAT            /**/
+#define CASTFLAGS 0            /**/
 
 /* VOID_CLOSEDIR:
  *     This symbol, if defined, indicates that the closedir() routine
  *     does not return a value.
  */
-#$d_void_closedir VOID_CLOSEDIR                /**/
+/*#define VOID_CLOSEDIR                /**/
 
 /* HAS_CSH:
  *     This symbol, if defined, indicates that the C-shell exists.
@@ -1268,9 +1276,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* CSH:
  *     This symbol, if defined, contains the full pathname of csh.
  */
-#$d_csh HAS_CSH                /**/
+#define HAS_CSH                /**/
 #ifdef HAS_CSH
-#define CSH "$full_csh"        /**/
+#define CSH "/system/ported/command_library/bash.pm"   /**/
 #endif
 
 /* DLSYM_NEEDS_UNDERSCORE:
@@ -1279,7 +1287,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     makes sense if you *have* dlsym, which we will presume is the
  *     case if you're using dl_dlopen.xs.
  */
-#$d_dlsymun    DLSYM_NEEDS_UNDERSCORE  /**/
+/*#define      DLSYM_NEEDS_UNDERSCORE  /**/
 
 /* HAS_DRAND48_PROTO:
  *     This symbol, if defined, indicates that the system provides
@@ -1287,91 +1295,98 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     to the program to supply one.  A good guess is
  *             extern double drand48 _((void));
  */
-#$d_drand48proto       HAS_DRAND48_PROTO       /**/
+/*#define      HAS_DRAND48_PROTO       /**/
 
 /* HAS_ENDGRENT:
  *     This symbol, if defined, indicates that the getgrent routine is
  *     available for finalizing sequential access of the group database.
  */
-#$d_endgrent HAS_ENDGRENT              /**/
+/*#define HAS_ENDGRENT         /**/
 
 /* HAS_ENDHOSTENT:
  *     This symbol, if defined, indicates that the endhostent() routine is
  *     available to close whatever was being used for host queries.
  */
-#$d_endhent HAS_ENDHOSTENT             /**/
+#define HAS_ENDHOSTENT         /**/
 
 /* HAS_ENDNETENT:
  *     This symbol, if defined, indicates that the endnetent() routine is
  *     available to close whatever was being used for network queries.
  */
-#$d_endnent HAS_ENDNETENT              /**/
+#define HAS_ENDNETENT          /**/
 
 /* HAS_ENDPROTOENT:
  *     This symbol, if defined, indicates that the endprotoent() routine is
  *     available to close whatever was being used for protocol queries.
  */
-#$d_endpent HAS_ENDPROTOENT            /**/
+#define HAS_ENDPROTOENT                /**/
 
 /* HAS_ENDPWENT:
  *     This symbol, if defined, indicates that the getgrent routine is
  *     available for finalizing sequential access of the passwd database.
  */
-#$d_endpwent HAS_ENDPWENT              /**/
+/*#define HAS_ENDPWENT         /**/
 
 /* HAS_ENDSERVENT:
  *     This symbol, if defined, indicates that the endservent() routine is
  *     available to close whatever was being used for service queries.
  */
-#$d_endsent HAS_ENDSERVENT             /**/
+#define HAS_ENDSERVENT         /**/
 
 /* HAS_FD_SET:
  *     This symbol, when defined, indicates presence of the fd_set typedef
  *     in <sys/types.h>
  */
-#$d_fd_set HAS_FD_SET  /**/
+/*#define HAS_FD_SET   /**/
 
 /* FLEXFILENAMES:
  *     This symbol, if defined, indicates that the system supports filenames
  *     longer than 14 characters.
  */
-#$d_flexfnam   FLEXFILENAMES           /**/
+#define        FLEXFILENAMES           /**/
 
 /* HAS_FPOS64_T:
  *     This symbol will be defined if the C compiler supports fpos64_t.
  */
-#$d_fpos64_t   HAS_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.
  */
-#$d_frexpl HAS_FREXPL          /**/
+/*#define HAS_FREXPL           /**/
 
 /* HAS_STRUCT_FS_DATA:
  *     This symbol, if defined, indicates that the struct fs_data
  *     to do statfs() is supported.
  */
-#$d_fs_data_s HAS_STRUCT_FS_DATA       /**/
+/*#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).
  */
-#$d_fseeko HAS_FSEEKO          /**/
+/*#define HAS_FSEEKO           /**/
 
 /* HAS_FSTATFS:
  *     This symbol, if defined, indicates that the fstatfs routine is
  *     available to stat filesystems by file descriptors.
  */
-#$d_fstatfs HAS_FSTATFS                /**/
+/*#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).
  */
-#$d_ftello HAS_FTELLO          /**/
+/*#define HAS_FTELLO           /**/
 
 /* Gconvert:
  *     This preprocessor macro is defined to convert a floating point
@@ -1388,49 +1403,49 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *             d_Gconvert='sprintf((b),"%.*g",(n),(x))'
  *     The last two assume trailing zeros should not be kept.
  */
-#define Gconvert(x,n,t,b) $d_Gconvert
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
 
 /* HAS_GETCWD:
  *     This symbol, if defined, indicates that the getcwd routine is
  *     available to get the current working directory.
  */
-#$d_getcwd HAS_GETCWD          /**/
+#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.
  */
-#$d_getespwnam HAS_GETESPWNAM          /**/
+/*#define HAS_GETESPWNAM               /**/
 
 /* HAS_GETFSSTAT:
  *     This symbol, if defined, indicates that the getfsstat routine is
  *     available to stat filesystems in bulk.
  */
-#$d_getfsstat HAS_GETFSSTAT            /**/
+/*#define HAS_GETFSSTAT                /**/
 
 /* HAS_GETGRENT:
  *     This symbol, if defined, indicates that the getgrent routine is
  *     available for sequential access of the group database.
  */
-#$d_getgrent HAS_GETGRENT              /**/
+/*#define HAS_GETGRENT         /**/
 
 /* HAS_GETHOSTBYADDR:
  *     This symbol, if defined, indicates that the gethostbyaddr() routine is
  *     available to look up hosts by their IP addresses.
  */
-#$d_gethbyaddr HAS_GETHOSTBYADDR               /**/
+#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.
  */
-#$d_gethbyname HAS_GETHOSTBYNAME               /**/
+#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.
  */
-#$d_gethent HAS_GETHOSTENT             /**/
+#define HAS_GETHOSTENT         /**/
 
 /* HAS_GETHOSTNAME:
  *     This symbol, if defined, indicates that the C program may use the
@@ -1454,11 +1469,11 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     contents of PHOSTNAME as a command to feed to the popen() routine
  *     to derive the host name.
  */
-#$d_gethname HAS_GETHOSTNAME   /**/
-#$d_uname HAS_UNAME            /**/
-#$d_phostname HAS_PHOSTNAME    /**/
+#define HAS_GETHOSTNAME        /**/
+#define HAS_UNAME              /**/
+/*#define HAS_PHOSTNAME        /**/
 #ifdef HAS_PHOSTNAME
-#define PHOSTNAME "$aphostname"        /* How to get the host name */
+#define PHOSTNAME ""   /* How to get the host name */
 #endif
 
 /* HAS_GETHOST_PROTOS:
@@ -1467,37 +1482,37 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     gethostbyaddr().  Otherwise, it is up to the program to guess
  *     them.  See netdbtype.U for probing for various Netdb_xxx_t types.
  */
-#$d_gethostprotos      HAS_GETHOST_PROTOS      /**/
+#define        HAS_GETHOST_PROTOS      /**/
 
 /* HAS_GETMNT:
  *     This symbol, if defined, indicates that the getmnt routine is
  *     available to get filesystem mount info by filename.
  */
-#$d_getmnt HAS_GETMNT          /**/
+/*#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.
  */
-#$d_getmntent HAS_GETMNTENT            /**/
+/*#define HAS_GETMNTENT                /**/
 
 /* HAS_GETNETBYADDR:
  *     This symbol, if defined, indicates that the getnetbyaddr() routine is
  *     available to look up networks by their IP addresses.
  */
-#$d_getnbyaddr HAS_GETNETBYADDR                /**/
+#define HAS_GETNETBYADDR               /**/
 
 /* HAS_GETNETBYNAME:
  *     This symbol, if defined, indicates that the getnetbyname() routine is
  *     available to look up networks by their names.
  */
-#$d_getnbyname HAS_GETNETBYNAME                /**/
+#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.
  */
-#$d_getnent HAS_GETNETENT              /**/
+#define HAS_GETNETENT          /**/
 
 /* HAS_GETNET_PROTOS:
  *     This symbol, if defined, indicates that <netdb.h> includes
@@ -1505,13 +1520,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     getnetbyaddr().  Otherwise, it is up to the program to guess
  *     them.  See netdbtype.U for probing for various Netdb_xxx_t types.
  */
-#$d_getnetprotos       HAS_GETNET_PROTOS       /**/
+#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.
  */
-#$d_getpent HAS_GETPROTOENT            /**/
+#define HAS_GETPROTOENT                /**/
 
 /* HAS_GETPROTOBYNAME:
  *     This symbol, if defined, indicates that the getprotobyname()
@@ -1521,8 +1536,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that the getprotobynumber()
  *     routine is available to look up protocols by their number.
  */
-#$d_getpbyname HAS_GETPROTOBYNAME              /**/
-#$d_getpbynumber HAS_GETPROTOBYNUMBER          /**/
+#define HAS_GETPROTOBYNAME             /**/
+#define HAS_GETPROTOBYNUMBER           /**/
 
 /* HAS_GETPROTO_PROTOS:
  *     This symbol, if defined, indicates that <netdb.h> includes
@@ -1530,26 +1545,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     getprotobyaddr().  Otherwise, it is up to the program to guess
  *     them.  See netdbtype.U for probing for various Netdb_xxx_t types.
  */
-#$d_getprotoprotos     HAS_GETPROTO_PROTOS     /**/
+#define        HAS_GETPROTO_PROTOS     /**/
 
 /* HAS_GETPRPWNAM:
  *     This symbol, if defined, indicates that the getprpwnam system call is
  *     available to retrieve protected (shadow) password entries by name.
  */
-#$d_getprpwnam HAS_GETPRPWNAM          /**/
+/*#define HAS_GETPRPWNAM               /**/
 
 /* 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.
  */
-#$d_getpwent HAS_GETPWENT              /**/
+/*#define HAS_GETPWENT         /**/
 
 /* HAS_GETSERVENT:
  *     This symbol, if defined, indicates that the getservent() routine is
  *     available to look up network services in some data base or another.
  */
-#$d_getsent HAS_GETSERVENT             /**/
+#define HAS_GETSERVENT         /**/
 
 /* HAS_GETSERV_PROTOS:
  *     This symbol, if defined, indicates that <netdb.h> includes
@@ -1557,13 +1572,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     getservbyaddr().  Otherwise, it is up to the program to guess
  *     them.  See netdbtype.U for probing for various Netdb_xxx_t types.
  */
-#$d_getservprotos      HAS_GETSERV_PROTOS      /**/
+#define        HAS_GETSERV_PROTOS      /**/
 
 /* HAS_GETSPNAM:
  *     This symbol, if defined, indicates that the getspnam system call is
  *     available to retrieve SysV shadow password entries by name.
  */
-#$d_getspnam HAS_GETSPNAM              /**/
+/*#define HAS_GETSPNAM         /**/
 
 /* HAS_GETSERVBYNAME:
  *     This symbol, if defined, indicates that the getservbyname()
@@ -1573,14 +1588,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that the getservbyport()
  *     routine is available to look up services by their port.
  */
-#$d_getsbyname HAS_GETSERVBYNAME               /**/
-#$d_getsbyport HAS_GETSERVBYPORT               /**/
+#define HAS_GETSERVBYNAME              /**/
+#define HAS_GETSERVBYPORT              /**/
 
 /* HAS_GNULIBC:
  *     This symbol, if defined, indicates to the C program that 
  *     the GNU C library is being used.
  */
-#$d_gnulibc HAS_GNULIBC        /**/
+/*#define HAS_GNULIBC          /**/
 #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE)
 #   define _GNU_SOURCE
 #endif
@@ -1588,7 +1603,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that the hasmntopt routine is
  *     available to query the mount options of file systems.
  */
-#$d_hasmntopt HAS_HASMNTOPT            /**/
+/*#define HAS_HASMNTOPT                /**/
 
 /* HAS_HTONL:
  *     This symbol, if defined, indicates that the htonl() routine (and
@@ -1610,48 +1625,48 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     friends htonl() htons() ntohl()) are available to do network
  *     order byte swapping.
  */
-#$d_htonl HAS_HTONL            /**/
-#$d_htonl HAS_HTONS            /**/
-#$d_htonl HAS_NTOHL            /**/
-#$d_htonl HAS_NTOHS            /**/
+#define HAS_HTONL              /**/
+#define HAS_HTONS              /**/
+#define HAS_NTOHL              /**/
+#define HAS_NTOHS              /**/
 
 /* HAS_ICONV:
  *     This symbol, if defined, indicates that the iconv routine is
  *     available to do character set conversions.
  */
-#$d_iconv HAS_ICONV            /**/
+/*#define HAS_ICONV            /**/
 
 /* 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.
  */
-#$d_int64_t     HAS_INT64_T               /**/
+/*#define     HAS_INT64_T               /**/
 
 /* HAS_ISASCII:
  *     This manifest constant lets the C program know that isascii 
  *     is available.
  */
-#$d_isascii HAS_ISASCII                /**/
+#define HAS_ISASCII            /**/
 
 /* HAS_ISNAN:
  *     This symbol, if defined, indicates that the isnan routine is
  *     available to check whether a double is a NaN.
  */
-#$d_isnan HAS_ISNAN            /**/
+/*#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.
  */
-#$d_isnanl HAS_ISNANL          /**/
+/*#define HAS_ISNANL           /**/
 
 /* HAS_LCHOWN:
  *     This symbol, if defined, indicates that the lchown routine is
  *     available to operate on a symbolic link (instead of following the
  *     link).
  */
-#$d_lchown HAS_LCHOWN          /**/
+/*#define HAS_LCHOWN           /**/
 
 /* HAS_LDBL_DIG:
  *     This symbol, if defined, indicates that this system's <float.h>
@@ -1659,7 +1674,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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.
  */
-#$d_ldbl_dig HAS_LDBL_DIG      /* */
+#define HAS_LDBL_DIG   /* */
 
 /* HAS_LONG_DOUBLE:
  *     This symbol will be defined if the C compiler supports long
@@ -1670,9 +1685,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     C preprocessor can make decisions based on it.  It is only
  *     defined if the system supports long doubles.
  */
-#$d_longdbl HAS_LONG_DOUBLE            /**/
+#define HAS_LONG_DOUBLE                /**/
 #ifdef HAS_LONG_DOUBLE
-#define LONG_DOUBLESIZE $longdblsize           /**/
+#define LONG_DOUBLESIZE 8              /**/
 #endif
 
 /* HAS_LONG_LONG:
@@ -1683,9 +1698,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     C preprocessor can make decisions based on it.  It is only
  *     defined if the system supports long long.
  */
-#$d_longlong HAS_LONG_LONG             /**/
+/*#define HAS_LONG_LONG                /**/
 #ifdef HAS_LONG_LONG
-#define LONGLONGSIZE $longlongsize             /**/
+#define LONGLONGSIZE _error_           /**/
 #endif
 
 /* HAS_LSEEK_PROTO:
@@ -1694,39 +1709,39 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     to the program to supply one.  A good guess is
  *             extern off_t lseek(int, off_t, int);
  */
-#$d_lseekproto HAS_LSEEK_PROTO /**/
+#define        HAS_LSEEK_PROTO /**/
 
 /* HAS_MADVISE:
  *     This symbol, if defined, indicates that the madvise system call is
  *     available to map a file into memory.
  */
-#$d_madvise HAS_MADVISE                /**/
+/*#define HAS_MADVISE          /**/
 
 /* HAS_MEMCHR:
  *     This symbol, if defined, indicates that the memchr routine is available
  *     to locate characters within a C string.
  */
-#$d_memchr HAS_MEMCHR  /**/
+#define HAS_MEMCHR     /**/
 
 /* HAS_MKDTEMP:
  *     This symbol, if defined, indicates that the mkdtemp routine is
  *     available to exclusively create a uniquely named temporary directory.
  */
-#$d_mkdtemp HAS_MKDTEMP                /**/
+/*#define HAS_MKDTEMP          /**/
 
 /* HAS_MKSTEMP:
  *     This symbol, if defined, indicates that the mkstemp routine is
  *     available to exclusively create and open a uniquely named
  *     temporary file.
  */
-#$d_mkstemp HAS_MKSTEMP                /**/
+/*#define HAS_MKSTEMP          /**/
 
 /* 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.
  */
-#$d_mkstemps HAS_MKSTEMPS              /**/
+/*#define HAS_MKSTEMPS         /**/
 
 /* HAS_MMAP:
  *     This symbol, if defined, indicates that the mmap system call is
@@ -1737,38 +1752,38 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     (and simultaneously the type of the first argument).
  *     Usually set to 'void *' or 'cadd_t'.
  */
-#$d_mmap HAS_MMAP              /**/
-#define Mmap_t $mmaptype       /**/
+#define HAS_MMAP               /**/
+#define Mmap_t void *  /**/
 
 /* 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.
  */
-#$d_modfl HAS_MODFL            /**/
+/*#define HAS_MODFL            /**/
 
 /* HAS_MPROTECT:
  *     This symbol, if defined, indicates that the mprotect system call is
  *     available to modify the access protection of a memory mapped file.
  */
-#$d_mprotect HAS_MPROTECT              /**/
+/*#define HAS_MPROTECT         /**/
 
 /* HAS_MSG:
  *     This symbol, if defined, indicates that the entire msg*(2) library is
  *     supported (IPC mechanism based on message queues).
  */
-#$d_msg HAS_MSG                /**/
+/*#define HAS_MSG              /**/
 
 /* HAS_OFF64_T:
  *     This symbol will be defined if the C compiler supports off64_t.
  */
-#$d_off64_t    HAS_OFF64_T             /**/
+/*#define      HAS_OFF64_T             /**/
 
 /* HAS_OPEN3:
  *     This manifest constant lets the C program know that the three
  *     argument form of open(2) is available.
  */
-#$d_open3 HAS_OPEN3            /**/
+#define HAS_OPEN3              /**/
 
 /* OLD_PTHREAD_CREATE_JOINABLE:
  *     This symbol, if defined, indicates how to create pthread
@@ -1778,7 +1793,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     If defined, known values are PTHREAD_CREATE_UNDETACHED
  *     and __UNDETACHED.
  */
-#$d_old_pthread_create_joinable OLD_PTHREAD_CREATE_JOINABLE $old_pthread_create_joinable /**/
+/*#define OLD_PTHREAD_CREATE_JOINABLE  /**/
 
 /* HAS_PTHREAD_YIELD:
  *     This symbol, if defined, indicates that the pthread_yield 
@@ -1795,9 +1810,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     routine is available to yield the execution of the current
  *     thread.  sched_yield is preferable to pthread_yield.
  */
-#$d_pthread_yield HAS_PTHREAD_YIELD    /**/
-#define SCHED_YIELD    $sched_yield    /**/
-#$d_sched_yield HAS_SCHED_YIELD        /**/
+/*#define HAS_PTHREAD_YIELD    /**/
+#define SCHED_YIELD            /**/
+/*#define HAS_SCHED_YIELD      /**/
 
 /* HAS_SAFE_BCOPY:
  *     This symbol, if defined, indicates that the bcopy routine is available
@@ -1805,7 +1820,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     probably use memmove() or memcpy(). If neither is defined, roll your
  *     own version.
  */
-#$d_safebcpy HAS_SAFE_BCOPY    /**/
+/*#define HAS_SAFE_BCOPY       /**/
 
 /* HAS_SAFE_MEMCPY:
  *     This symbol, if defined, indicates that the memcpy routine is available
@@ -1813,94 +1828,103 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     probably use memmove() or memcpy(). If neither is defined, roll your
  *     own version.
  */
-#$d_safemcpy HAS_SAFE_MEMCPY   /**/
+/*#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.
  */
-#$d_sanemcmp HAS_SANE_MEMCMP   /**/
+#define HAS_SANE_MEMCMP        /**/
+
+/* 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_SEM:
  *     This symbol, if defined, indicates that the entire sem*(2) library is
  *     supported.
  */
-#$d_sem HAS_SEM                /**/
+/*#define HAS_SEM              /**/
 
 /* HAS_SETGRENT:
  *     This symbol, if defined, indicates that the setgrent routine is
  *     available for initializing sequential access of the group database.
  */
-#$d_setgrent HAS_SETGRENT              /**/
+/*#define HAS_SETGRENT         /**/
 
 /* 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.
  */
-#$d_setgrps HAS_SETGROUPS              /**/
+/*#define HAS_SETGROUPS                /**/
 
 /* HAS_SETHOSTENT:
  *     This symbol, if defined, indicates that the sethostent() routine is
  *     available.
  */
-#$d_sethent HAS_SETHOSTENT             /**/
+#define HAS_SETHOSTENT         /**/
 
 /* HAS_SETNETENT:
  *     This symbol, if defined, indicates that the setnetent() routine is
  *     available.
  */
-#$d_setnent HAS_SETNETENT              /**/
+#define HAS_SETNETENT          /**/
 
 /* HAS_SETPROTOENT:
  *     This symbol, if defined, indicates that the setprotoent() routine is
  *     available.
  */
-#$d_setpent HAS_SETPROTOENT            /**/
+#define HAS_SETPROTOENT                /**/
 
 /* HAS_SETPROCTITLE:
  *     This symbol, if defined, indicates that the setproctitle routine is
  *     available to set process title.
  */
-#$d_setproctitle HAS_SETPROCTITLE              /**/
+/*#define HAS_SETPROCTITLE             /**/
 
 /* HAS_SETPWENT:
  *     This symbol, if defined, indicates that the setpwent routine is
  *     available for initializing sequential access of the passwd database.
  */
-#$d_setpwent HAS_SETPWENT              /**/
+/*#define HAS_SETPWENT         /**/
 
 /* HAS_SETSERVENT:
  *     This symbol, if defined, indicates that the setservent() routine is
  *     available.
  */
-#$d_setsent HAS_SETSERVENT             /**/
+#define HAS_SETSERVENT         /**/
 
 /* 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.
  */
-#$d_setvbuf HAS_SETVBUF                /**/
+#define HAS_SETVBUF            /**/
 
 /* USE_SFIO:
  *     This symbol, if defined, indicates that sfio should
  *     be used.
  */
-#$d_sfio       USE_SFIO                /**/
+/*#define      USE_SFIO                /**/
 
 /* HAS_SHM:
  *     This symbol, if defined, indicates that the entire shm*(2) library is
  *     supported.
  */
-#$d_shm HAS_SHM                /**/
+/*#define HAS_SHM              /**/
 
 /* HAS_SIGACTION:
  *     This symbol, if defined, indicates that Vr4's sigaction() routine
  *     is available.
  */
-#$d_sigaction HAS_SIGACTION    /**/
+#define HAS_SIGACTION  /**/
 
 /* HAS_SIGSETJMP:
  *     This variable indicates to the C program that the sigsetjmp()
@@ -1922,7 +1946,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     traditional longjmp() if siglongjmp isn't available.
  *     See HAS_SIGSETJMP.
  */
-#$d_sigsetjmp HAS_SIGSETJMP    /**/
+#define HAS_SIGSETJMP  /**/
 #ifdef HAS_SIGSETJMP
 #define Sigjmp_buf sigjmp_buf
 #define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
@@ -1971,33 +1995,33 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     Checking just with #ifdef might not be enough because this symbol
  *     has been known to be an enum.
  */
-#$d_socket     HAS_SOCKET              /**/
-#$d_sockpair   HAS_SOCKETPAIR  /**/
-#$d_msg_ctrunc HAS_MSG_CTRUNC  /**/
-#$d_msg_dontroute      HAS_MSG_DONTROUTE       /**/
-#$d_msg_oob    HAS_MSG_OOB     /**/
-#$d_msg_peek   HAS_MSG_PEEK    /**/
-#$d_msg_proxy  HAS_MSG_PROXY   /**/
-#$d_scm_rights HAS_SCM_RIGHTS  /**/
+#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_SOCKS5_INIT:
  *     This symbol, if defined, indicates that the socks5_init routine is
  *     available to initialize SOCKS 5.
  */
-#$d_socks5_init HAS_SOCKS5_INIT                /**/
+/*#define HAS_SOCKS5_INIT              /**/
 
 /* HAS_SQRTL:
  *     This symbol, if defined, indicates that the sqrtl routine is
  *     available to do long double square roots.
  */
-#$d_sqrtl HAS_SQRTL            /**/
+/*#define HAS_SQRTL            /**/
 
 /* USE_STAT_BLOCKS:
  *     This symbol is defined if this system has a stat structure declaring
  *     st_blksize and st_blocks.
  */
 #ifndef USE_STAT_BLOCKS
-#$d_statblks USE_STAT_BLOCKS   /**/
+/*#define USE_STAT_BLOCKS      /**/
 #endif
 
 /* HAS_STRUCT_STATFS_F_FLAGS:
@@ -2009,19 +2033,19 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     have statfs() and struct statfs, they have ustat() and getmnt()
  *     with struct ustat and struct fs_data.
  */
-#$d_statfs_f_flags HAS_STRUCT_STATFS_F_FLAGS           /**/
+/*#define HAS_STRUCT_STATFS_F_FLAGS            /**/
 
 /* HAS_STRUCT_STATFS:
  *     This symbol, if defined, indicates that the struct statfs
  *     to do statfs() is supported.
  */
-#$d_statfs_s HAS_STRUCT_STATFS /**/
+/*#define HAS_STRUCT_STATFS    /**/
 
 /* HAS_FSTATVFS:
  *     This symbol, if defined, indicates that the fstatvfs routine is
  *     available to stat filesystems by file descriptors.
  */
-#$d_fstatvfs HAS_FSTATVFS              /**/
+/*#define HAS_FSTATVFS         /**/
 
 /* USE_STDIO_PTR:
  *     This symbol is defined if the _ptr and _cnt fields (or similar)
@@ -2048,12 +2072,23 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol is defined if the FILE_cnt macro can be used as an
  *     lvalue.
  */
-#$d_stdstdio USE_STDIO_PTR     /**/
+/* 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)   $stdio_ptr
-#$d_stdio_ptr_lval STDIO_PTR_LVALUE            /**/
-#define FILE_cnt(fp)   $stdio_cnt
-#$d_stdio_cnt_lval STDIO_CNT_LVALUE            /**/
+#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:
@@ -2076,10 +2111,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     structure pointed to its argument. This macro will always be defined
  *     if USE_STDIO_BASE is defined.
  */
-#$d_stdiobase USE_STDIO_BASE   /**/
+#define USE_STDIO_BASE         /**/
 #ifdef USE_STDIO_BASE
-#define FILE_base(fp)  $stdio_base
-#define FILE_bufsiz(fp)        $stdio_bufsiz
+#define FILE_base(fp)  ((fp)->_base)
+#define FILE_bufsiz(fp)        ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
 #endif
 
 /* HAS_STRERROR:
@@ -2097,33 +2132,33 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     not available to translate error numbers to strings but sys_errlist[]
  *     array is there.
  */
-#$d_strerror HAS_STRERROR              /**/
-#$d_syserrlst HAS_SYS_ERRLIST  /**/
-#define Strerror(e) $d_strerrm
+#define HAS_STRERROR           /**/
+#define HAS_SYS_ERRLIST        /**/
+#define Strerror(e) strerror(e)
 
 /* HAS_STRTOLD:
  *     This symbol, if defined, indicates that the strtold routine is
  *     available to convert strings to long doubles.
  */
-#$d_strtold HAS_STRTOLD                /**/
+/*#define HAS_STRTOLD          /**/
 
 /* HAS_STRTOLL:
  *     This symbol, if defined, indicates that the strtoll routine is
  *     available to convert strings to long longs.
  */
-#$d_strtoll HAS_STRTOLL                /**/
+/*#define HAS_STRTOLL          /**/
 
 /* HAS_STRTOULL:
  *     This symbol, if defined, indicates that the strtoull routine is
  *     available to convert strings to unsigned long longs.
  */
-#$d_strtoull HAS_STRTOULL              /**/
+/*#define HAS_STRTOULL         /**/
 
 /* HAS_STRTOUQ:
  *     This symbol, if defined, indicates that the strtouq routine is
  *     available to convert strings to unsigned long longs (quads).
  */
-#$d_strtouq HAS_STRTOUQ                /**/
+/*#define HAS_STRTOUQ          /**/
 
 /* HAS_TELLDIR_PROTO:
  *     This symbol, if defined, indicates that the system provides
@@ -2131,21 +2166,21 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     to the program to supply one.  A good guess is
  *             extern long telldir _((DIR*));
  */
-#$d_telldirproto       HAS_TELLDIR_PROTO       /**/
+/*#define      HAS_TELLDIR_PROTO       /**/
 
 /* 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 Time_t $timetype               /* Time type */
+#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>.
  */
-#$d_times HAS_TIMES            /**/
+#define HAS_TIMES              /**/
 
 /* HAS_UNION_SEMUN:
  *     This symbol, if defined, indicates that the union semun is
@@ -2165,20 +2200,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that struct semid_ds * is
  *     used for semctl IPC_STAT.
  */
-#$d_union_semun HAS_UNION_SEMUN        /**/
-#$d_semctl_semun USE_SEMCTL_SEMUN      /**/
-#$d_semctl_semid_ds USE_SEMCTL_SEMID_DS        /**/
+/*#define HAS_UNION_SEMUN      /**/
+/*#define USE_SEMCTL_SEMUN     /**/
+/*#define USE_SEMCTL_SEMID_DS  /**/
 
 /* HAS_USTAT:
  *     This symbol, if defined, indicates that the ustat system call is
  *     available to query file system statistics by dev_t.
  */
-#$d_ustat HAS_USTAT            /**/
+/*#define HAS_USTAT            /**/
 
 /* HAS_VFORK:
  *     This symbol, if defined, indicates that vfork() exists.
  */
-#$d_vfork HAS_VFORK    /**/
+/*#define HAS_VFORK    /**/
 
 /* Signal_t:
  *     This symbol's value is either "void" or "int", corresponding to the
@@ -2186,7 +2221,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     a signal handler using "Signal_t (*handler)()", and define the
  *     handler using "Signal_t handler(sig)".
  */
-#define Signal_t $signal_t     /* Signal handler's return type */
+#define Signal_t void  /* Signal handler's return type */
 
 /* HAS_VPRINTF:
  *     This symbol, if defined, indicates that the vprintf routine is available
@@ -2199,26 +2234,26 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     is up to the package author to declare vsprintf correctly based on the
  *     symbol.
  */
-#$d_vprintf HAS_VPRINTF        /**/
-#$d_charvspr USE_CHAR_VSPRINTF         /**/
+#define HAS_VPRINTF    /**/
+/*#define USE_CHAR_VSPRINTF    /**/
 
 /* USE_DYNAMIC_LOADING:
  *     This symbol, if defined, indicates that dynamic loading of
  *     some sort is available.
  */
-#$usedl USE_DYNAMIC_LOADING            /**/
+/*#define USE_DYNAMIC_LOADING          /**/
 
 /* DOUBLESIZE:
  *     This symbol contains the size of a double, so that the C preprocessor
  *     can make decisions based on it.
  */
-#define DOUBLESIZE $doublesize         /**/
+#define DOUBLESIZE 8           /**/
 
 /* EBCDIC:
  *     This symbol, if defined, indicates that this system uses
  *     EBCDIC encoding.
  */
-#$ebcdic       EBCDIC          /**/
+/*#define      EBCDIC          /**/
 
 /* FFLUSH_NULL:
  *     This symbol, if defined, tells that fflush(NULL) does flush
@@ -2231,31 +2266,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     Note that if fflushNULL is defined, fflushall will not
  *     even be probed for and will be left undefined.
  */
-#$fflushNULL   FFLUSH_NULL             /**/
-#$fflushall    FFLUSH_ALL              /**/
+#define        FFLUSH_NULL             /**/
+/*#define      FFLUSH_ALL              /**/
 
 /* 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 $fpostype               /* File position type */
+#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         $gidformat              /**/
+#define        Gid_t_f         "d"             /**/
 
 /* Gid_t_sign:
  *     This symbol holds the signedess of a Gid_t.
  *     1 for unsigned, -1 for signed.
  */
-#define Gid_t_sign     $gidsign                /* GID sign */
+#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 $gidsize            /* GID size */
+#define Gid_t_size 4           /* GID size */
 
 /* Gid_t:
  *     This symbol holds the return type of getgid() and the type of
@@ -2264,7 +2299,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     gid_t, etc... It may be necessary to include <sys/types.h> to get
  *     any typedef'ed information.
  */
-#define Gid_t $gidtype         /* Type for getgid(), etc... */
+#define Gid_t gid_t            /* Type for getgid(), etc... */
 
 /* Groups_t:
  *     This symbol holds the type used for the second argument to
@@ -2276,7 +2311,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     getgroups() or setgroups()..
  */
 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
-#define Groups_t $groupstype   /* Type for 2nd arg to [sg]etgroups() */
+#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */
 #endif
 
 /* DB_Prefix_t:
@@ -2289,8 +2324,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     in the <db.h> header file.  In older versions of DB, it was
  *     int, while in newer ones it is size_t.
  */
-#define DB_Hash_t      $db_hashtype            /**/
-#define DB_Prefix_t    $db_prefixtype          /**/
+#define DB_Hash_t      int             /**/
+#define DB_Prefix_t    int     /**/
 
 /* I_GRP:
  *     This symbol, if defined, indicates to the C program that it should
@@ -2300,74 +2335,74 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates to the C program that struct group
  *     in <grp.h> contains gr_passwd.
  */
-#$i_grp I_GRP          /**/
-#$d_grpasswd GRPASSWD  /**/
+#define I_GRP          /**/
+/*#define GRPASSWD     /**/
 
 /* I_ICONV:
  *     This symbol, if defined, indicates that <iconv.h> exists and
  *     should be included.
  */
-#$i_iconv      I_ICONV         /**/
+/*#define      I_ICONV         /**/
 
 /* I_IEEEFP:
  *     This symbol, if defined, indicates that <ieeefp.h> exists and
  *     should be included.
  */
-#$i_ieeefp     I_IEEEFP                /**/
+/*#define      I_IEEEFP                /**/
 
 /* I_INTTYPES:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <inttypes.h>.
  */
-#$i_inttypes   I_INTTYPES                /**/
+/*#define   I_INTTYPES                /**/
 
 /* I_LIBUTIL:
  *     This symbol, if defined, indicates that <libutil.h> exists and
  *     should be included.
  */
-#$i_libutil    I_LIBUTIL               /**/
+/*#define      I_LIBUTIL               /**/
 
 /* I_MACH_CTHREADS:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <mach/cthreads.h>.
  */
-#$i_machcthr   I_MACH_CTHREADS /**/
+/*#define   I_MACH_CTHREADS    /**/
 
 /* I_MNTENT:
  *     This symbol, if defined, indicates that <mntent.h> exists and
  *     should be included.
  */
-#$i_mntent     I_MNTENT                /**/
+/*#define      I_MNTENT                /**/
 
 /* I_NETDB:
  *     This symbol, if defined, indicates that <netdb.h> exists and
  *     should be included.
  */
-#$i_netdb I_NETDB              /**/
+#define I_NETDB                /**/
 
 /* I_NETINET_TCP:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <netinet/tcp.h>.
  */
-#$i_netinettcp   I_NETINET_TCP                /**/
+#define   I_NETINET_TCP                /**/
 
 /* I_POLL:
  *     This symbol, if defined, indicates that <poll.h> exists and
  *     should be included.
  */
-#$i_poll       I_POLL          /**/
+/*#define      I_POLL          /**/
 
 /* I_PROT:
  *     This symbol, if defined, indicates that <prot.h> exists and
  *     should be included.
  */
-#$i_prot       I_PROT          /**/
+/*#define      I_PROT          /**/
 
 /* I_PTHREAD:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <pthread.h>.
  */
-#$i_pthread   I_PTHREAD        /**/
+/*#define   I_PTHREAD  /**/
 
 /* I_PWD:
  *     This symbol, if defined, indicates to the C program that it should
@@ -2405,80 +2440,80 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates to the C program that struct passwd
  *     contains pw_passwd.
  */
-#$i_pwd I_PWD          /**/
-#$d_pwquota PWQUOTA    /**/
-#$d_pwage PWAGE        /**/
-#$d_pwchange PWCHANGE  /**/
-#$d_pwclass PWCLASS    /**/
-#$d_pwexpire PWEXPIRE  /**/
-#$d_pwcomment PWCOMMENT        /**/
-#$d_pwgecos PWGECOS    /**/
-#$d_pwpasswd PWPASSWD  /**/
+#define I_PWD          /**/
+/*#define PWQUOTA      /**/
+/*#define PWAGE        /**/
+/*#define PWCHANGE     /**/
+/*#define PWCLASS      /**/
+/*#define PWEXPIRE     /**/
+/*#define PWCOMMENT    /**/
+/*#define PWGECOS      /**/
+/*#define PWPASSWD     /**/
 
 /* I_SHADOW:
  *     This symbol, if defined, indicates that <shadow.h> exists and
  *     should be included.
  */
-#$i_shadow     I_SHADOW                /**/
+/*#define      I_SHADOW                /**/
 
 /* I_SOCKS:
  *     This symbol, if defined, indicates that <socks.h> exists and
  *     should be included.
  */
-#$i_socks      I_SOCKS         /**/
+/*#define      I_SOCKS         /**/
 
 /* I_SUNMATH:
  *     This symbol, if defined, indicates that <sunmath.h> exists and
  *     should be included.
  */
-#$i_sunmath    I_SUNMATH               /**/
+/*#define      I_SUNMATH               /**/
 
 /* I_SYSLOG:
  *     This symbol, if defined, indicates that <syslog.h> exists and
  *     should be included.
  */
-#$i_syslog     I_SYSLOG                /**/
+/*#define      I_SYSLOG                /**/
 
 /* I_SYSMODE:
  *     This symbol, if defined, indicates that <sys/mode.h> exists and
  *     should be included.
  */
-#$i_sysmode    I_SYSMODE               /**/
+/*#define      I_SYSMODE               /**/
 
 /* I_SYS_MOUNT:
  *     This symbol, if defined, indicates that <sys/mount.h> exists and
  *     should be included.
  */
-#$i_sysmount   I_SYS_MOUNT             /**/
+/*#define      I_SYS_MOUNT             /**/
 
 /* I_SYS_STATFS:
  *     This symbol, if defined, indicates that <sys/statfs.h> exists.
  */
-#$i_sysstatfs  I_SYS_STATFS            /**/
+/*#define      I_SYS_STATFS            /**/
 
 /* I_SYS_STATVFS:
  *     This symbol, if defined, indicates that <sys/statvfs.h> exists and
  *     should be included.
  */
-#$i_sysstatvfs I_SYS_STATVFS           /**/
+/*#define      I_SYS_STATVFS           /**/
 
 /* I_SYSUIO:
  *     This symbol, if defined, indicates that <sys/uio.h> exists and
  *     should be included.
  */
-#$i_sysuio     I_SYSUIO                /**/
+/*#define      I_SYSUIO                /**/
 
 /* I_SYSUTSNAME:
  *     This symbol, if defined, indicates that <sys/utsname.h> exists and
  *     should be included.
  */
-#$i_sysutsname I_SYSUTSNAME            /**/
+#define        I_SYSUTSNAME            /**/
 
 /* I_SYS_VFS:
  *     This symbol, if defined, indicates that <sys/vfs.h> exists and
  *     should be included.
  */
-#$i_sysvfs     I_SYS_VFS               /**/
+/*#define      I_SYS_VFS               /**/
 
 /* I_TIME:
  *     This symbol, if defined, indicates to the C program that it should
@@ -2492,15 +2527,15 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates to the C program that it should
  *     include <sys/time.h> with KERNEL defined.
  */
-#$i_time I_TIME                /**/
-#$i_systime I_SYS_TIME         /**/
-#$i_systimek I_SYS_TIME_KERNEL         /**/
+/*#define I_TIME               /**/
+#define I_SYS_TIME             /**/
+/*#define I_SYS_TIME_KERNEL            /**/
 
 /* I_USTAT:
  *     This symbol, if defined, indicates that <ustat.h> exists and
  *     should be included.
  */
-#$i_ustat      I_USTAT         /**/
+/*#define      I_USTAT         /**/
 
 /* PERL_INC_VERSION_LIST:
  *     This variable specifies the list of subdirectories in over
@@ -2509,13 +2544,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     for a C initialization string.  See the inc_version_list entry
  *     in Porting/Glossary for more details.
  */
-#define PERL_INC_VERSION_LIST $inc_version_list_init           /**/
+#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.
  */
-#$installusrbinperl INSTALL_USR_BIN_PERL       /**/
+/*#define INSTALL_USR_BIN_PERL /**/
 
 /* PERL_PRIfldbl:
  *     This symbol, if defined, contains the string used by stdio to
@@ -2533,10 +2568,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, contains the string used by stdio to
  *     format long doubles (format 'f') for input.
  */
-#$d_PRIfldbl PERL_PRIfldbl     $sPRIfldbl      /**/
-#$d_PRIgldbl PERL_PRIgldbl     $sPRIgldbl      /**/
-#$d_PRIeldbl PERL_PRIeldbl     $sPRIeldbl      /**/
-#$d_SCNfldbl PERL_SCNfldbl     $sSCNfldbl      /**/
+#define PERL_PRIfldbl  "Lf"    /**/
+#define PERL_PRIgldbl  "Lg"    /**/
+#define PERL_PRIeldbl  "Le"    /**/
+#define PERL_SCNfldbl  "Lf"    /**/
 
 /* Off_t:
  *     This symbol holds the type used to declare offsets in the kernel.
@@ -2549,9 +2584,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* Off_t_size:
  *     This symbol holds the number of bytes used by the Off_t.
  */
-#define Off_t $lseektype               /* <offset> type */
-#define LSEEKSIZE $lseeksize           /* <offset> size */
-#define Off_t_size $lseeksize  /* <offset> size */
+#define Off_t off_t            /* <offset> type */
+#define LSEEKSIZE 4            /* <offset> size */
+#define Off_t_size 4   /* <offset> size */
 
 /* Free_t:
  *     This variable contains the return type of free().  It is usually
@@ -2560,13 +2595,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* Malloc_t:
  *     This symbol is the type of pointer returned by malloc and realloc.
  */
-#define Malloc_t $malloctype                   /**/
-#define Free_t $freetype                       /**/
+#define Malloc_t void *                        /**/
+#define Free_t void                    /**/
 
 /* MYMALLOC:
  *     This symbol, if defined, indicates that we're using our own malloc.
  */
-#$d_mymalloc MYMALLOC                  /**/
+/*#define MYMALLOC                     /**/
 
 /* Mode_t:
  *     This symbol holds the type used to declare file modes 
@@ -2574,7 +2609,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     int or unsigned short.  It may be necessary to include <sys/types.h>
  *     to get any typedef'ed information.
  */
-#define Mode_t $modetype        /* file mode parameter for system calls */
+#define Mode_t mode_t   /* file mode parameter for system calls */
 
 /* VAL_O_NONBLOCK:
  *     This symbol is to be used during open() or fcntl(F_SETFL) to turn on
@@ -2598,10 +2633,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 $rd_nodata
-#$d_eofnblk EOF_NONBLOCK
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
 
 /* Netdb_host_t:
  *     This symbol holds the type used for the 1st argument
@@ -2619,10 +2654,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol holds the type used for the 1st argument to
  *     getnetbyaddr().
  */
-#define Netdb_host_t           $netdb_host_type /**/
-#define Netdb_hlen_t           $netdb_hlen_type /**/
-#define Netdb_name_t           $netdb_name_type /**/
-#define Netdb_net_t            $netdb_net_type /**/
+#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
@@ -2632,7 +2667,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     and architecture-specific directories.  See PERL_INC_VERSION_LIST
  *     for more details.
  */
-#$d_perl_otherlibdirs PERL_OTHERLIBDIRS "$otherlibdirs"                /**/
+/*#define PERL_OTHERLIBDIRS ""         /**/
 
 /* IVTYPE:
  *     This symbol defines the C type used for Perl's IV.
@@ -2708,34 +2743,34 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol contains the number of bits a variable of type NVTYPE
  *     can preserve of a variable of type UVTYPE.
  */
-#define        IVTYPE          $ivtype         /**/
-#define        UVTYPE          $uvtype         /**/
-#define        I8TYPE          $i8type         /**/
-#define        U8TYPE          $u8type         /**/
-#define        I16TYPE         $i16type        /**/
-#define        U16TYPE         $u16type        /**/
-#define        I32TYPE         $i32type        /**/
-#define        U32TYPE         $u32type        /**/
+#define        IVTYPE          int             /**/
+#define        UVTYPE          unsigned int            /**/
+#define        I8TYPE          char            /**/
+#define        U8TYPE          unsigned char           /**/
+#define        I16TYPE         short   /**/
+#define        U16TYPE         unsigned short  /**/
+#define        I32TYPE         int     /**/
+#define        U32TYPE         unsigned int    /**/
 #ifdef HAS_QUAD
-#define        I64TYPE         $i64type        /**/
-#define        U64TYPE         $u64type        /**/
+#define        I64TYPE         _error_ /**/
+#define        U64TYPE         _error_ /**/
 #endif
-#define        NVTYPE          $nvtype         /**/
-#define        IVSIZE          $ivsize         /**/
-#define        UVSIZE          $uvsize         /**/
-#define        I8SIZE          $i8size         /**/
-#define        U8SIZE          $u8size         /**/
-#define        I16SIZE         $i16size        /**/
-#define        U16SIZE         $u16size        /**/
-#define        I32SIZE         $i32size        /**/
-#define        U32SIZE         $u32size        /**/
+#define        NVTYPE          double          /**/
+#define        IVSIZE          4               /**/
+#define        UVSIZE          4               /**/
+#define        I8SIZE          1               /**/
+#define        U8SIZE          1               /**/
+#define        I16SIZE         2       /**/
+#define        U16SIZE         2       /**/
+#define        I32SIZE         4       /**/
+#define        U32SIZE         4       /**/
 #ifdef HAS_QUAD
-#define        I64SIZE         $i64size        /**/
-#define        U64SIZE         $u64size        /**/
+#define        I64SIZE         _error_ /**/
+#define        U64SIZE         _error_ /**/
 #endif
-#define        NVSIZE          $nvsize         /**/
-#$d_nv_preserves_uv    NV_PRESERVES_UV
-#define        NV_PRESERVES_UV_BITS    $d_nv_preserves_uv_bits
+#define        NVSIZE          8               /**/
+#define        NV_PRESERVES_UV
+#define        NV_PRESERVES_UV_BITS    32
 
 /* IVdf:
  *     This symbol defines the format string used for printing a Perl IV
@@ -2765,20 +2800,20 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol defines the format string used for printing a Perl NV
  *     using %g-ish floating point format.
  */
-#define        IVdf            $ivdformat              /**/
-#define        UVuf            $uvuformat              /**/
-#define        UVof            $uvoformat              /**/
-#define        UVxf            $uvxformat              /**/
-#define        NVef            $nveformat              /**/
-#define        NVff            $nvfformat              /**/
-#define        NVgf            $nvgformat              /**/
+#define        IVdf            "d"             /**/
+#define        UVuf            "u"             /**/
+#define        UVof            "o"             /**/
+#define        UVxf            "x"             /**/
+#define        NVef            "e"             /**/
+#define        NVff            "f"             /**/
+#define        NVgf            "g"             /**/
 
 /* 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 $pidtype         /* PID type */
+#define Pid_t pid_t            /* PID type */
 
 /* PRIVLIB:
  *     This symbol contains the name of the private library for this package.
@@ -2790,8 +2825,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 "$privlib"             /**/
-#define PRIVLIB_EXP "$privlibexp"              /**/
+#define PRIVLIB "/system/ported/perl/lib/5.7"          /**/
+#define PRIVLIB_EXP "/system/ported/perl/lib/5.7"              /**/
 
 /* PTRSIZE:
  *     This symbol contains the size of a pointer, so that the C preprocessor
@@ -2799,7 +2834,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     the compiler supports (void *); otherwise it will be
  *     sizeof(char *).
  */
-#define PTRSIZE $ptrsize               /**/
+#define PTRSIZE 4              /**/
 
 /* Drand01:
  *     This macro is to be used to generate uniformly distributed
@@ -2821,10 +2856,10 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     function used to generate normalized random numbers.
  *     Values include 15, 16, 31, and 48.
  */
-#define Drand01()              $drand01                /**/
-#define Rand_seed_t            $randseedtype           /**/
-#define seedDrand01(x) $seedfunc((Rand_seed_t)x)       /**/
-#define RANDBITS               $randbits               /**/
+#define Drand01()              rand()/(RAND_MAX+1)             /**/
+#define Rand_seed_t            unsigned int            /**/
+#define seedDrand01(x) srand((Rand_seed_t)x)   /**/
+#define RANDBITS               15              /**/
 
 /* SELECT_MIN_BITS:
  *     This symbol holds the minimum number of bits operated by select.
@@ -2833,7 +2868,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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        $selectminbits  /**/
+#define SELECT_MIN_BITS        1       /**/
 
 /* Select_fd_set_t:
  *     This symbol holds the type used for the 2nd, 3rd, and 4th
@@ -2841,7 +2876,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     is defined, and 'int *' otherwise.  This is only useful if you 
  *     have select(), of course.
  */
-#define Select_fd_set_t        $selecttype     /**/
+#define Select_fd_set_t        fd_set *        /**/
 
 /* SIG_NAME:
  *     This symbol contains a list of signal names in order of
@@ -2871,8 +2906,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     The last element is 0, corresponding to the 0 at the end of
  *     the sig_name list.
  */
-#define SIG_NAME $sig_name_init                /**/
-#define SIG_NUM  $sig_num_init         /**/
+#define SIG_NAME "ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO","HUP","URG","ALRM","CHLD","CONT","KILL","STOP","PIPE","QUIT","BUS","TRAP","TSTP","TTIN","TTOU","RT1","RT2","RT3","RT4","RT5","RT6","RT7","RT8",0             /**/
+#define 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,27,28,29,30,31,0               /**/
 
 /* SITEARCH:
  *     This symbol contains the name of the private library for this package.
@@ -2889,8 +2924,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 "$sitearch"           /**/
-#define SITEARCH_EXP "$sitearchexp"            /**/
+/*#define SITEARCH ""          /**/
+/*#define SITEARCH_EXP ""              /**/
 
 /* SITELIB:
  *     This symbol contains the name of the private library for this package.
@@ -2912,14 +2947,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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 "$sitelib"             /**/
-#define SITELIB_EXP "$sitelibexp"              /**/
-#define SITELIB_STEM "$sitelib_stem"           /**/
+#define SITELIB "/system/ported/perl/lib/site/5.7"             /**/
+#define SITELIB_EXP "/system/ported/perl/lib/site/5.7"         /**/
+#define SITELIB_STEM "/system/ported/perl/lib/site"            /**/
 
 /* Size_t_size:
  *     This symbol holds the size of a Size_t in bytes.
  */
-#define Size_t_size $sizesize          /* */
+#define Size_t_size 4          /* */
 
 /* Size_t:
  *     This symbol holds the type used to declare length parameters
@@ -2927,13 +2962,13 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     unsigned long, int, etc.  It may be necessary to include
  *     <sys/types.h> to get any typedef'ed information.
  */
-#define Size_t $sizetype        /* length paramater for string functions */
+#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            $socksizetype /**/
+#define Sock_size_t            int /**/
 
 /* SSize_t:
  *     This symbol holds the type used by functions that return
@@ -2943,14 +2978,14 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     to get any typedef'ed information.
  *     We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
  */
-#define SSize_t $ssizetype      /* signed count of bytes */
+#define SSize_t ssize_t         /* signed count of bytes */
 
 /* 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 "$startperl"         /**/
+#define STARTPERL "!perl.pm"           /**/
 
 /* HAS_STDIO_STREAM_ARRAY:
  *     This symbol, if defined, tells that there is an array
@@ -2960,31 +2995,31 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol tells the name of the array holding the stdio streams.
  *     Usual values include _iob, __iob, and __sF.
  */
-#$d_stdio_stream_array HAS_STDIO_STREAM_ARRAY  /**/
-#define STDIO_STREAM_ARRAY     $stdio_stream_array
+#define        HAS_STDIO_STREAM_ARRAY  /**/
+#define STDIO_STREAM_ARRAY     _iob
 
 /* Uid_t_f:
  *     This symbol defines the format string used for printing a Uid_t.
  */
-#define        Uid_t_f         $uidformat              /**/
+#define        Uid_t_f         "d"             /**/
 
 /* Uid_t_sign:
  *     This symbol holds the signedess of a Uid_t.
  *     1 for unsigned, -1 for signed.
  */
-#define Uid_t_sign     $uidsign                /* UID sign */
+#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 $uidsize            /* UID size */
+#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 $uidtype         /* UID type */
+#define Uid_t uid_t            /* UID type */
 
 /* USE_64_BIT_INT:
  *     This symbol, if defined, indicates that 64-bit integers should
@@ -3005,11 +3040,11 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     you may need at least to reboot your OS to 64-bit mode.
  */
 #ifndef USE_64_BIT_INT
-#$use64bitint  USE_64_BIT_INT          /**/
+/*#define      USE_64_BIT_INT          /**/
 #endif
 
 #ifndef USE_64_BIT_ALL
-#$use64bitall  USE_64_BIT_ALL          /**/
+/*#define      USE_64_BIT_ALL          /**/
 #endif
 
 /* USE_LARGE_FILES:
@@ -3017,7 +3052,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     should be used when available.
  */
 #ifndef USE_LARGE_FILES
-#$uselargefiles        USE_LARGE_FILES         /**/
+/*#define      USE_LARGE_FILES         /**/
 #endif
 
 /* USE_LONG_DOUBLE:
@@ -3025,7 +3060,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     be used when available.
  */
 #ifndef USE_LONG_DOUBLE
-#$uselongdouble        USE_LONG_DOUBLE         /**/
+#define        USE_LONG_DOUBLE         /**/
 #endif
 
 /* USE_MORE_BITS:
@@ -3033,7 +3068,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     long doubles should be used when available.
  */
 #ifndef USE_MORE_BITS
-#$usemorebits  USE_MORE_BITS           /**/
+/*#define      USE_MORE_BITS           /**/
 #endif
 
 /* MULTIPLICITY:
@@ -3041,7 +3076,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     be built to use multiplicity.
  */
 #ifndef MULTIPLICITY
-#$usemultiplicity      MULTIPLICITY            /**/
+/*#define      MULTIPLICITY            /**/
 #endif
 
 /* USE_PERLIO:
@@ -3050,7 +3085,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     used in a fully backward compatible manner.
  */
 #ifndef USE_PERLIO
-#$useperlio    USE_PERLIO              /**/
+/*#define      USE_PERLIO              /**/
 #endif
 
 /* USE_SOCKS:
@@ -3058,7 +3093,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     be built to use socks.
  */
 #ifndef USE_SOCKS
-#$usesocks     USE_SOCKS               /**/
+/*#define      USE_SOCKS               /**/
 #endif
 
 /* USE_ITHREADS:
@@ -3073,12 +3108,12 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that Perl should
  *     be built to use the old draft POSIX threads API.
  */
-#$use5005threads       USE_5005THREADS         /**/
-#$useithreads  USE_ITHREADS            /**/
+/*#define      USE_5005THREADS         /**/
+/*#define      USE_ITHREADS            /**/
 #if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
 #define                USE_THREADS             /* until src is revised*/
 #endif
-#$d_oldpthreads        OLD_PTHREADS_API                /**/
+/*#define      OLD_PTHREADS_API                /**/
 
 /* PERL_VENDORARCH:
  *     If defined, this symbol contains the name of a private library.
@@ -3095,8 +3130,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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.
  */
-#$d_vendorarch PERL_VENDORARCH "$vendorarch"           /**/
-#$d_vendorarch PERL_VENDORARCH_EXP "$vendorarchexp"            /**/
+#define PERL_VENDORARCH ""             /**/
+#define PERL_VENDORARCH_EXP ""         /**/
 
 /* PERL_VENDORLIB_EXP:
  *     This symbol contains the ~name expanded version of VENDORLIB, to be used
@@ -3107,8 +3142,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     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.
  */
-#$d_vendorlib PERL_VENDORLIB_EXP "$vendorlibexp"               /**/
-#$d_vendorlib PERL_VENDORLIB_STEM "$vendorlib_stem"            /**/
+#define PERL_VENDORLIB_EXP ""          /**/
+#define PERL_VENDORLIB_STEM ""         /**/
 
 /* VOIDFLAGS:
  *     This symbol indicates how much support of the void type is given by this
@@ -3127,9 +3162,9 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     level of void support necessary is not present, defines void to int.
  */
 #ifndef VOIDUSED
-#define VOIDUSED $defvoidused
+#define VOIDUSED 15
 #endif
-#define VOIDFLAGS $voidflags
+#define VOIDFLAGS 15
 #if (VOIDFLAGS & VOIDUSED) != VOIDUSED
 #define void int               /* is void to be avoided? */
 #define M_VOID                 /* Xenix strikes again */
@@ -3138,7 +3173,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
 /* PERL_XS_APIVERSION:
  *     This variable contains the version of the oldest perl binary
  *     compatible with the present perl.  perl.c:incpush() and
- *     lib/lib.pm will automatically search in $sitearch for older
+ *     lib/lib.pm will automatically search in  for older
  *     directories across major versions back to xs_apiversion.
  *     This is only useful if you have a perl library directory tree
  *     structured like the default one.
@@ -3157,7 +3192,7 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     compatible with the present perl.  (That is, pure perl modules
  *     written for pm_apiversion will still work for the current
  *     version).  perl.c:incpush() and lib/lib.pm will automatically
- *     search in $sitelib for older directories across major versions
+ *     search in /system/ported/perl/lib/site/5.7 for older directories across major versions
  *     back to pm_apiversion.  This is only useful if you have a perl
  *     library directory tree structured like the default one.  The
  *     versioned site_perl library was introduced in 5.005, so that's
@@ -3167,8 +3202,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     (presumably) be similar.
  *     See the INSTALL file for how this works.
  */
-#define PERL_XS_APIVERSION "$xs_apiversion"
-#define PERL_PM_APIVERSION "$pm_apiversion"
+#define PERL_XS_APIVERSION "5.00563"
+#define PERL_PM_APIVERSION "5.005"
 
 /* HAS_GETPGRP:
  *     This symbol, if defined, indicates that the getpgrp routine is
@@ -3178,8 +3213,8 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     This symbol, if defined, indicates that getpgrp needs one
  *     arguments whereas USG one needs none.
  */
-#$d_getpgrp HAS_GETPGRP                /**/
-#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
+#define HAS_GETPGRP            /**/
+/*#define USE_BSD_GETPGRP      /**/
 
 /* HAS_SETPGRP:
  *     This symbol, if defined, indicates that the setpgrp routine is
@@ -3190,8 +3225,18 @@ sed <<!GROK!THIS! >$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un
  *     arguments whereas USG one needs none.  See also HAS_SETPGID
  *     for a POSIX interface.
  */
-#$d_setpgrp HAS_SETPGRP                /**/
-#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+/*#define HAS_SETPGRP          /**/
+/*#define USE_BSD_SETPGRP      /**/
+
+/* 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            / **/
 
 #endif
-!GROK!THIS!
index c6014ad..c865ba1 100644 (file)
@@ -3,6 +3,7 @@
 #
 # Written January 24, 2000 by Jarkko Hietaniemi [jhi@iki.fi]
 # Modified February 2, 2000 by Paul Green [Paul_Green@stratus.com]
+# Modified October 23, 2000 by Paul Green [Paul_Green@stratus.com]
 
 #
 # Read in the definitions file
@@ -13,6 +14,7 @@ if (open(CONFIG_DEF, "config.def")) {
         if (/^([^=]+)='(.*)'$/) {
             my ($var, $val) = ($1, $2);
             $define{$var} = $val;
+            $used{$var} = 0;
         } else {
             warn "config.def: $.: illegal line: $_";
         }
@@ -27,8 +29,9 @@ close (CONFIG_DEF);
 # Open the template input file.
 #
 
-unless (open(CONFIG_SH, "config_h.SH_orig")) {
-    die "$0: Cannot open config_h.SH_orig: $!";
+$lineno = 0;
+unless (open(CONFIG_SH, "../config_h.SH")) {
+    die "$0: Cannot open ../config_h.SH: $!";
 }
 
 #
@@ -44,6 +47,7 @@ unless (open(CONFIG_H, ">config.h.new")) {
 #
 
 while (<CONFIG_SH>) {
+    $lineno = $lineno + 1;
     last if /^sed <<!GROK!THIS!/;
 }
 
@@ -53,20 +57,34 @@ while (<CONFIG_SH>) {
 #
 
 while (<CONFIG_SH>) {
+    $lineno = $lineno + 1;
     last if /^!GROK!THIS!/;
 #
+#   The definition of SITEARCH and SITEARCH_EXP has to be commented-out.
+#   The easiest way to do this is to special-case it here.
+#
+    if (/^#define SITEARCH*/) {
+        s@(^.*$)@/*$1@;
+    }
+#
 #   The case of #$d_foo at the BOL has to be handled carefully.
 #   If $d_foo is "undef", then we must first comment out the entire line.
 #
-    if (/^#\$\w+/) {
-        s@^#(\$\w+)@("$define{$1}" eq "undef")?"/*#define":"#$define{$1}"@e;
+    if (/^#(\$\w+)/) {
+        if (exists $define{$1}) {
+            $used{$1}=1;
+            s@^#(\$\w+)@("$define{$1}" eq "undef") ?
+                "/*#define":"#$define{$1}"@e;
+        }
     }
 #
 #   There could be multiple $variables on this line.
 #   Find and replace all of them.
 #
     if (/(\$\w+)/) {
-        s/(\$\w+)/(exists $define{$1}) ? $define{$1} : $1/ge;
+        s/(\$\w+)/(exists $define{$1}) ?
+            (($used{$1}=1),$define{$1}) :
+            ((print "Undefined keyword $1 on line $lineno\n"),$1)/ge;
         print CONFIG_H;
     }
 #
@@ -82,3 +100,10 @@ unless (close (CONFIG_H)) {
     }
 
 close (CONFIG_SH);
+
+while (($key,$value) = each %used) {
+    if ($value == 0) {
+        print "Unused keyword definition: $key\n";
+    }
+}
+
diff --git a/vos/configure_perl.cm b/vos/configure_perl.cm
new file mode 100644 (file)
index 0000000..49611f9
--- /dev/null
@@ -0,0 +1,24 @@
+& This command macro configures perl to build with
+& either the alpha or generally-available version of
+& VOS POSIX.1 support.
+& Written 00-10-24 by Paul Green (Paul_Green@stratus.com)
+&
+&begin_parameters
+     version   option(-version)name,allow(alpha,ga),=ga
+&end_parameters
+&echo command_lines
+&
+&if (file_info config.&version&.def date_modified) > (file_info config.&version&.h date_modified)
+&then &do
+!copy_file config.&version&.def config.def -delete
+&
+& NOTE: We must invoke Perl 5 not Perl 4. If necessary, edit the
+& next line to say "perl5 config.pl".
+&
+!perl config.pl
+!rename config.h.new config.&version&.h -delete
+!delete_file config.def
+&end
+&
+&if (file_info config.&version&.h date_modified) ^= (file_info config.h date_modified)
+&then !copy_file config.&version&.h config.h -delete -keep_dates
diff --git a/vos/install_perl.cm b/vos/install_perl.cm
new file mode 100644 (file)
index 0000000..95fe064
--- /dev/null
@@ -0,0 +1,69 @@
+& Macro to install the perl components into the right directories
+& Written 00-10-24 by Paul Green (Paul_Green@stratus.com)
+&
+&begin_parameters
+     cpu       option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020
+&end_parameters priv
+&echo command_lines
+&
+&if &cpu& = mc68020
+&then &set_string obj ''
+&if &cpu& = i80860
+&then &set_string obj .860
+&if &cpu& = pa7100
+&then &set_string obj .7100
+&if &cpu& = pa8000
+&then &set_string obj .8000
+&
+&set_string MDS (master_disk)>system
+&
+&if ^ (exists -directory &MDS&>ported)
+&then !create_dir &MDS&>ported
+&
+&if ^ (exists -directory &MDS&>ported>command_library)
+&then !create_dir &MDS&>ported>command_library
+&
+&if ^ (exists -directory &MDS&>ported>perl)
+&then !create_dir &MDS&>ported>perl
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib)
+&then !create_dir &MDS&>ported>perl>lib
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>5.7)
+&then !create_dir &MDS&>ported>perl>lib>5.7
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.68k)
+&then !create_dir &MDS&>ported>perl>lib>5.7.68k
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.860)
+&then !create_dir &MDS&>ported>perl>lib>5.7.860
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.7100)
+&then !create_dir &MDS&>ported>perl>lib>5.7.7100
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.8000)
+&then !create_dir &MDS&>ported>perl>lib>5.7.8000
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site)
+&then !create_dir &MDS&>ported>perl>lib>site
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7)
+&then !create_dir &MDS&>ported>perl>lib>site>5.7
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.68k)
+&then !create_dir &MDS&>ported>perl>lib>site>5.7.68k
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.860)
+&then !create_dir &MDS&>ported>perl>lib>site>5.7.860
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.7100)
+&then !create_dir &MDS&>ported>perl>lib>site>5.7.7100
+&
+&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.8000)
+&then !create_dir &MDS&>ported>perl>lib>site>5.7.8000
+&
+!copy_dir <lib &MDS&>ported>perl>lib>5.7 -delete
+&
+!copy_file obj&obj&>perl.pm &MDS&>ported>command_library>perl.pm.new -delete
+!rename &MDS&>ported>command_library>perl.pm *.(date).(time) -delete
+!rename &MDS&>ported>command_library>perl.pm.new perl.pm -delete
index 714ce3d..1e77e5a 100644 (file)
@@ -31,9 +31,6 @@ modules:  miniperlmain,
           universal,
           utf8,
           util,
-          xsutils,
-          vos_dummies,
-          tcp_runtime,
-          tcp_gethost;
+          xsutils;
 
 end;
index 5a6b079..d600065 100644 (file)
@@ -1,140 +1 @@
-/*
- * The following symbols are defined if your operating system supports
- * functions by that name.  All Unixes I know of support them, thus they
- * are not checked by the configuration script, but are directly defined
- * here.
- */
-
-/* HAS_IOCTL:
- *     This symbol, if defined, indicates that the ioctl() routine is
- *     available to set I/O characteristics
- */
-#define        HAS_IOCTL               / **/
-/* HAS_UTIME:
- *     This symbol, if defined, indicates that the routine utime() is
- *     available to update the access and modification times of files.
- */
-#define HAS_UTIME              / **/
-
-/* HAS_GROUP
- *     This symbol, if defined, indicates that the getgrnam() and
- *     getgrgid() routines are available to get group entries.
- *     The getgrent() has a separate definition, HAS_GETGRENT.
- */
-/*#define HAS_GROUP            / **/
-
-/* HAS_PASSWD
- *     This symbol, if defined, indicates that the getpwnam() and
- *     getpwuid() routines are available to get password entries.
- *     The getpwent() has a separate definition, HAS_GETPWENT.
- */
-/*#define HAS_PASSWD           / **/
-
-#define HAS_KILL
-#define HAS_WAIT
-  
-/* USEMYBINMODE
- *     This symbol, if defined, indicates that the program should
- *     use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
- *     that a file is in "binary" mode -- that is, that no translation
- *     of bytes occurs on read or write operations.
- */
-#undef USEMYBINMODE
-
-/* Stat_t:
- *     This symbol holds the type used to declare buffers for information
- *     returned by stat().  It's usually just struct stat.  It may be necessary
- *     to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
- *     information.
- */
-#define Stat_t struct stat
-
-/* USE_STAT_RDEV:
- *     This symbol is defined if this system has a stat structure declaring
- *     st_rdev
- */
-/*#define USE_STAT_RDEV        / **/
-
-/* ACME_MESS:
- *     This symbol, if defined, indicates that error messages should be 
- *     should be generated in a format that allows the use of the Acme
- *     GUI/editor's autofind feature.
- */
-#undef ACME_MESS       /**/
-
-/* UNLINK_ALL_VERSIONS:
- *     This symbol, if defined, indicates that the program should arrange
- *     to remove all versions of a file if unlink() is called.  This is
- *     probably only relevant for VMS.
- */
-/* #define UNLINK_ALL_VERSIONS         / **/
-
-/* VMS:
- *     This symbol, if defined, indicates that the program is running under
- *     VMS.  It is currently automatically set by cpps running under VMS,
- *     and is included here for completeness only.
- */
-/* #define VMS         / **/
-
-/* ALTERNATE_SHEBANG:
- *     This symbol, if defined, contains a "magic" string which may be used
- *     as the first line of a Perl program designed to be executed directly
- *     by name, instead of the standard Unix #!.  If ALTERNATE_SHEBANG
- *     begins with a character other then #, then Perl will only treat
- *     it as a command line if if finds the string "perl" in the first
- *     word; otherwise it's treated as the first line of code in the script.
- *     (IOW, Perl won't hand off to another interpreter via an alternate
- *     shebang sequence that might be legal Perl code.)
- */
-/* #define ALTERNATE_SHEBANG "#!" / **/
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) || defined(__NetBSD__)
-# include <signal.h>
-#endif
-
-#ifndef SIGABRT
-#    define SIGABRT SIGILL
-#endif
-#ifndef SIGILL
-#    define SIGILL 6         /* blech */
-#endif
-#define ABORT() kill(PerlProc_getpid(),SIGABRT);
-
-/*
- * fwrite1() should be a routine with the same calling sequence as fwrite(),
- * but which outputs all of the bytes requested as a single stream (unlike
- * fwrite() itself, which on some systems outputs several distinct records
- * if the number_of_items parameter is >1).
- */
-#define fwrite1 fwrite
-
-#define Stat(fname,bufptr) stat((fname),(bufptr))
-#define Fstat(fd,bufptr)   fstat((fd),(bufptr))
-#define Fflush(fp)         fflush(fp)
-#define Mkdir(path,mode)   mkdir((path),(mode))
-
-/* these should be set in a hint file, not here */
-#ifndef PERL_SYS_INIT
-#ifdef PERL_SCO5
-#  define PERL_SYS_INIT(c,v)   fpsetmask(0); MALLOC_INIT
-#else
-#  ifdef POSIX_BC
-#    define PERL_SYS_INIT(c,v) sigignore(SIGFPE); MALLOC_INIT
-#  else
-#    ifdef CYGWIN
-#      define PERL_SYS_INIT(c,v) Perl_my_setenv_init(&environ); MALLOC_INIT
-#    else
-#      define PERL_SYS_INIT(c,v) MALLOC_INIT
-#    endif
-#  endif
-#endif
-#endif
-
-#ifndef PERL_SYS_TERM
-#define PERL_SYS_TERM()                MALLOC_TERM
-#endif
-
-#define BIT_BUCKET "/dev/null"
-
-#define dXSUB_SYS
+#include "unixish.h"
index 0c2d2ec..3a5037d 100644 (file)
@@ -1,5 +1,8 @@
 #!/usr/bin/perl
 
+
+$VERSION = '1.00';
+
 BEGIN {
   push @INC, './lib';
 }
@@ -104,7 +107,7 @@ sub mkRange
 
 
     for ($i = 1 ; $i < @a; ++ $i) {
-       $out[$i] = ".." 
+       $out[$i] = ".."
           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
     }
 
@@ -130,9 +133,9 @@ sub printTree
        print $prefix . "|\n" ;
        print $prefix . "+- $k" ;
        if (ref $v)
-       { 
+       {
            print " " . "-" x ($max - length $k ) . "+\n" ;
-           printTree ($v, $prefix . "|" , $max + $indent - 1) 
+           printTree ($v, $prefix . "|" , $max + $indent - 1)
        }
        else
          { print "\n" }
@@ -289,9 +292,9 @@ foreach $k (sort keys  %list) {
     my $v = $list{$k} ;
     my @list = sort { $a <=> $b } @$v ;
 
-    print PM tab(4, "    '$k'"), '=> "', 
-               # mkHex($warn_size, @list), 
-               mkHex($warn_size, map $_ * 2 , @list), 
+    print PM tab(4, "    '$k'"), '=> "',
+               # mkHex($warn_size, @list),
+               mkHex($warn_size, map $_ * 2 , @list),
                '", # [', mkRange(@list), "]\n" ;
 }
 
@@ -303,9 +306,9 @@ foreach $k (sort keys  %list) {
     my $v = $list{$k} ;
     my @list = sort { $a <=> $b } @$v ;
 
-    print PM tab(4, "    '$k'"), '=> "', 
-               # mkHex($warn_size, @list), 
-               mkHex($warn_size, map $_ * 2 + 1 , @list), 
+    print PM tab(4, "    '$k'"), '=> "',
+               # mkHex($warn_size, @list),
+               mkHex($warn_size, map $_ * 2 + 1 , @list),
                '", # [', mkRange(@list), "]\n" ;
 }
 
@@ -327,6 +330,8 @@ __END__
 
 package warnings;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 warnings - Perl pragma to control optional warnings
@@ -361,7 +366,7 @@ warnings - Perl pragma to control optional warnings
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-A number of functions are provided to assist module authors. 
+A number of functions are provided to assist module authors.
 
 =over 4
 
@@ -465,7 +470,7 @@ sub bits {
            $mask |= $DeadBits{$word} if $fatal ;
        }
        else
-          { croak("unknown warnings category '$word'")}  
+          { croak("unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -511,13 +516,13 @@ sub __chk
            unless defined $offset;
     }
     else {
-        $category = (caller(1))[0] ; 
+        $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
         croak("package '$category' not registered for warnings")
            unless defined $offset ;
     }
 
-    my $this_pkg = (caller(1))[0] ; 
+    my $this_pkg = (caller(1))[0] ;
     my $i = 2 ;
     my $pkg ;
 
@@ -531,11 +536,11 @@ sub __chk
         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
             last if $pkg ne $this_pkg ;
         }
-        $i = 2 
+        $i = 2
             if !$pkg || $pkg eq $this_pkg ;
     }
 
-    my $callers_bitmask = (caller($i))[9] ; 
+    my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
@@ -560,7 +565,7 @@ sub warn
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
     carp($message) ;
@@ -575,12 +580,12 @@ sub warnif
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
 
-    return 
+    return
         unless defined $callers_bitmask &&
                (vec($callers_bitmask, $offset, 1) ||
                vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 
index af11990..fe1b1b1 100644 (file)
@@ -1,8 +1,10 @@
 #
 # Makefile to build perl on Windows NT using Microsoft NMAKE.
+# Supported compilers:
+#      Visual C++ 5.x (possibly other versions)
 #
 # This is set up to build a perl.exe that runs off a shared library
-# (perl56.dll).  Also makes individual DLLs for the XS extensions.
+# (perl57.dll).  Also makes individual DLLs for the XS extensions.
 #
 
 ##
@@ -29,7 +31,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.6.0
+INST_VER       = \5.7.0
 
 #
 # Comment this out if you DON'T want your perl installation to have
@@ -63,6 +65,12 @@ INST_ARCH    = \$(ARCHNAME)
 #USE_IMP_SYS   = define
 
 #
+# uncomment to enable the experimental PerlIO I/O subsystem.
+# This is currently incompatible with USE_MULTI, USE_ITHREADS,
+# and USE_IMP_SYS
+#USE_PERLIO    = define
+
+#
 # WARNING! This option is deprecated and will eventually go away (enable
 # USE_ITHREADS instead).
 #
@@ -70,7 +78,7 @@ INST_ARCH     = \$(ARCHNAME)
 # USE_ITHREADS, and is only here for people who may have come to rely
 # on the experimental Thread support that was in 5.005.
 #
-#USE_5005THREADS= define
+#USE_5005THREADS       = define
 
 #
 # WARNING! This option is deprecated and will eventually go away (enable
@@ -273,10 +281,18 @@ ARCHNAME  = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread
 !IF "$(USE_MULTI)" == "define"
 ARCHNAME       = MSWin32-$(PROCESSOR_ARCHITECTURE)-multi
 !ELSE
+!IF "$(USE_PERLIO)" == "define"
+ARCHNAME       = MSWin32-$(PROCESSOR_ARCHITECTURE)-perlio
+!ELSE
 ARCHNAME       = MSWin32-$(PROCESSOR_ARCHITECTURE)
 !ENDIF
 !ENDIF
 !ENDIF
+!ENDIF
+
+!IF "$(USE_PERLIO)" == "define"
+BUILDOPT       = $(BUILDOPT) -DUSE_PERLIO
+!ENDIF
 
 !IF "$(USE_ITHREADS)" == "define"
 ARCHNAME       = $(ARCHNAME)-thread
@@ -287,7 +303,7 @@ ARCHNAME    = $(ARCHNAME)-thread
 
 # VC 6.0 can load the socket dll on demand.  Makes the test suite
 # run in about 10% less time.
-DELAYLOAD      = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib 
+DELAYLOAD      = -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
 
 # VC 6.0 seems capable of compiling perl correctly with optimizations
 # enabled.  Anything earlier fails tests.
@@ -327,7 +343,7 @@ RSC         = rc
 #
 
 INCLUDES       = -I$(COREDIR) -I.\include -I. -I..
-#PCHFLAGS      = -Fpc:\temp\vcmoduls.pch -YX 
+#PCHFLAGS      = -Fpc:\temp\vcmoduls.pch -YX
 DEFINES                = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
 LOCDEFS                = -DPERLDLL -DPERL_CORE
 SUBSYS         = console
@@ -395,7 +411,7 @@ o = .obj
 
 #
 # Rules
-# 
+#
 
 .SUFFIXES : .c $(o) .dll .lib .exe .rc .res
 
@@ -407,15 +423,19 @@ o = .obj
 
 $(o).dll:
        $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
-           -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)  
+           -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
 
 .rc.res:
        $(RSC) -i.. $<
 
 #
 # various targets
-PERLIMPLIB     = ..\perl56.lib
-PERLDLL                = ..\perl56.dll
+
+# makedef.pl must be updated if this changes, and this should normally
+# only change when there is an incompatible revision of the public API.
+# XXX so why did we change it from perl56 to perl57?
+PERLIMPLIB     = ..\perl57.lib
+PERLDLL                = ..\perl57.dll
 
 MINIPERL       = ..\miniperl.exe
 MINIDIR                = .\mini
@@ -465,6 +485,8 @@ RCOPY               = xcopy /f /r /i /e /d
 NOOP           = @echo
 NULL           =
 
+DEL            = bin\mdelete.bat
+
 #
 # filenames given to xsubpp must have forward slashes (since it puts
 # full pathnames in #line strings)
@@ -514,7 +536,7 @@ EXTRACORE_SRC       = $(EXTRACORE_SRC) ..\perlio.c
 WIN32_SRC      =               \
                .\win32.c       \
                .\win32sck.c    \
-               .\win32thread.c 
+               .\win32thread.c
 
 !IF "$(CRYPT_SRC)" != ""
 WIN32_SRC      = $(WIN32_SRC) .\$(CRYPT_SRC)
@@ -594,7 +616,7 @@ SETARGV_OBJ = setargv$(o)
 
 DYNAMIC_EXT    = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
                Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
-               Sys/Hostname Storable
+               Sys/Hostname Storable Filter/Util/Call Encode
 STATIC_EXT     = DynaLoader
 NONXS_EXT      = Errno
 
@@ -617,6 +639,8 @@ DPROF               = $(EXTDIR)\Devel\DProf\DProf
 GLOB           = $(EXTDIR)\File\Glob\Glob
 HOSTNAME       = $(EXTDIR)\Sys\Hostname\Hostname
 STORABLE       = $(EXTDIR)\Storable\Storable
+FILTER         = $(EXTDIR)\Filter\Util\Call\Call
+ENCODE         = $(EXTDIR)\Encode\Encode
 
 SOCKET_DLL     = $(AUTODIR)\Socket\Socket.dll
 FCNTL_DLL      = $(AUTODIR)\Fcntl\Fcntl.dll
@@ -635,6 +659,8 @@ DPROF_DLL   = $(AUTODIR)\Devel\DProf\DProf.dll
 GLOB_DLL       = $(AUTODIR)\File\Glob\Glob.dll
 HOSTNAME_DLL   = $(AUTODIR)\Sys\Hostname\Hostname.dll
 STORABLE_DLL   = $(AUTODIR)\Storable\Storable.dll
+FILTER_DLL     = $(AUTODIR)\Filter\Util\Call\Call.dll
+ENCODE_DLL     = $(AUTODIR)\Encode\Encode.dll
 
 ERRNO_PM       = $(LIBDIR)\Errno.pm
 
@@ -655,7 +681,9 @@ EXTENSION_C =               \
                $(DPROF).c      \
                $(GLOB).c       \
                $(HOSTNAME).c   \
-               $(STORABLE).c
+               $(STORABLE).c   \
+               $(FILTER).c     \
+               $(ENCODE).c     
 
 EXTENSION_DLL  =               \
                $(SOCKET_DLL)   \
@@ -674,7 +702,9 @@ EXTENSION_DLL       =               \
                $(DPROF_DLL)    \
                $(GLOB_DLL)     \
                $(HOSTNAME_DLL) \
-               $(STORABLE_DLL)
+               $(STORABLE_DLL) \
+               $(FILTER_DLL)   \
+               $(ENCODE_DLL)
 
 EXTENSION_PM   =               \
                $(ERRNO_PM)
@@ -691,8 +721,9 @@ CFG_VARS    =                                       \
                "INST_ARCH=$(INST_ARCH)"                \
                "archname=$(ARCHNAME)"                  \
                "cc=$(CC)"                              \
-               "ccflags=$(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)"       \
-               "cf_email=$(EMAIL)"                     \
+               "ld=$(LINK32)"                          \
+               "ccflags=-nologo -Gf -W3 $(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)"       \
+               "cf_email=$(EMAIL)"                     \
                "d_crypt=$(D_CRYPT)"                    \
                "d_mymalloc=$(PERL_MALLOC)"             \
                "libs=$(LIBFILES)"                      \
@@ -724,7 +755,7 @@ $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
 
 $(GLOBEXE) : perlglob$(o)
        $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
-           perlglob$(o) setargv$(o) 
+           perlglob$(o) setargv$(o)
 
 perlglob$(o)  : perlglob.c
 
@@ -740,7 +771,7 @@ config.w32 : $(CFGSH_TMPL)
 
 # this target is for when changes to the main config.sh happen
 # edit config.{b,v,g}c and make this target once for each supported
-# compiler (e.g. `dmake CCTYPE=BORLAND regen_config_h`)
+# compiler (e.g. `nmake CCTYPE=BORLAND regen_config_h`)
 regen_config_h:
        perl config_sh.PL $(CFG_VARS) $(CFGSH_TMPL) > ..\config.sh
        cd ..
@@ -753,14 +784,16 @@ regen_config_h:
        rename config.h $(CFGH_TMPL)
 
 $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
-       cd .. && miniperl configpm
+       cd ..
+       miniperl configpm
+       cd win32
        if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
        $(XCOPY) ..\*.h $(COREDIR)\*.*
        $(XCOPY) *.h $(COREDIR)\*.*
        $(XCOPY) ..\ext\re\re.pm $(LIBDIR)\*.*
        $(RCOPY) include $(COREDIR)\*.*
-       $(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)" \
-           || $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
+       -$(MINIPERL) -I..\lib config_h.PL "INST_VER=$(INST_VER)"
+       if errorlevel 1 $(MAKE) /$(MAKEFLAGS) $(CONFIGPM)
 
 $(MINIPERL) : $(MINIDIR) $(MINI_OBJ)
        $(LINK32) -subsystem:console -out:$@ @<<
@@ -803,7 +836,9 @@ $(PERLDLL): perldll.def $(PERLDLL_OBJ) $(PERLDLL_RES)
        $(XCOPY) $(PERLIMPLIB) $(COREDIR)
 
 $(MINIMOD) : $(MINIPERL) ..\minimod.pl
-       cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+       cd ..
+       miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+       cd win32
 
 ..\x2p\a2p$(o) : ..\x2p\a2p.c
        $(CC) -I..\x2p $(CFLAGS) $(OBJOUT_FLAG)$@ -c ..\x2p\a2p.c
@@ -827,7 +862,7 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ)
                $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ)
 <<
 
-perlmain.c : runperl.c 
+perlmain.c : runperl.c
        copy runperl.c perlmain.c
 
 perlmain$(o) : perlmain.c
@@ -838,7 +873,7 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
            $(LIBFILES) $(PERLEXE_OBJ) $(SETARGV_OBJ) $(PERLIMPLIB) $(PERLEXE_RES)
        copy $(PERLEXE) $(WPERLEXE)
        $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
-       copy splittree.pl .. 
+       copy splittree.pl ..
        $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
 
 $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
@@ -952,12 +987,30 @@ $(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs
        $(MAKE)
        cd ..\..\win32
 
+$(ENCODE_DLL): $(PERLEXE) $(ENCODE).xs
+       cd $(EXTDIR)\$(*B)
+       ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+       $(MAKE)
+       cd ..\..\win32
+
 $(STORABLE_DLL): $(PERLEXE) $(STORABLE).xs
        cd $(EXTDIR)\$(*B)
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        $(MAKE)
        cd ..\..\win32
 
+$(FILTER_DLL): $(PERLEXE) $(FILTER).xs
+       cd $(EXTDIR)\Filter\Util\Call
+       ..\..\..\..\miniperl -I..\..\..\..\lib Makefile.PL INSTALLDIRS=perl
+       $(MAKE)
+       cd ..\..\..\..\win32
+
+$(ENCODE_DLL): $(PERLEXE) $(ENCODE).xs
+       cd $(EXTDIR)\$(*B)
+       ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+       $(MAKE)
+       cd ..\..\win32
+
 $(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL
        cd $(EXTDIR)\$(*B)
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
@@ -1004,10 +1057,17 @@ distclean: clean
        -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
        -del /f $(LIBDIR)\File\Glob.pm
        -del /f $(LIBDIR)\Storable.pm
-       -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO
-       -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread
-       -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B
-       -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data
+       -del /f $(LIBDIR)\Filter\Util\Call\Call.pm
+       -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO
+       -rmdir /s $(LIBDIR)\IO
+       -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread
+       -rmdir /s $(LIBDIR)\Thread
+       -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B
+       -rmdir /s $(LIBDIR)\B
+       -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data
+       -rmdir /s $(LIBDIR)\Data
+       -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call
+       -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util
        -del /f $(PODDIR)\*.html
        -del /f $(PODDIR)\*.bat
        cd ..\utils
@@ -1024,8 +1084,10 @@ distclean: clean
        cd $(EXTDIR)
        -del /s *.lib *.def *.map *.pdb *.bs Makefile *$(o) pm_to_blib
        cd ..\win32
-       -if exist $(AUTODIR) rmdir /s /q $(AUTODIR) || rmdir /s $(AUTODIR)
-       -if exist $(COREDIR) rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR)
+       -if exist $(AUTODIR) rmdir /s /q $(AUTODIR)
+       -rmdir /s $(AUTODIR)
+       -if exist $(COREDIR) rmdir /s /q $(COREDIR)
+       -rmdir /s $(COREDIR)
 
 install : all installbare installhtml
 
@@ -1039,7 +1101,7 @@ installhtml : doc
        $(RCOPY) html\*.* $(INST_HTML)\*.*
 
 inst_lib : $(CONFIGPM)
-       copy splittree.pl .. 
+       copy splittree.pl ..
        $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
        $(RCOPY) ..\lib $(INST_LIB)\*.*
 
@@ -1081,28 +1143,29 @@ test-wide-notty : test-prep
        $(PERLEXE) -I..\lib harness
        cd ..\win32
 
-clean : 
-       -@erase miniperlmain$(o)
-       -@erase $(MINIPERL)
-       -@erase perlglob$(o)
-       -@erase perlmain$(o)
-       -@erase config.w32
-       -@erase /f config.h
-       -@erase $(GLOBEXE)
-       -@erase $(PERLEXE)
-       -@erase $(WPERLEXE)
-       -@erase $(PERLDLL)
-       -@erase $(CORE_OBJ)
-       -if exist $(MINIDIR) rmdir /s /q $(MINIDIR) || rmdir /s $(MINIDIR)
-       -@erase $(WIN32_OBJ)
-       -@erase $(DLL_OBJ)
-       -@erase $(X2P_OBJ)
-       -@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res
-       -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
-       -@erase ..\x2p\*.exe ..\x2p\*.bat
-       -@erase *.ilk
-       -@erase *.pdb
+clean :
+       -@$(DEL) miniperlmain$(o)
+       -@$(DEL) $(MINIPERL)
+       -@$(DEL) perlglob$(o)
+       -@$(DEL) perlmain$(o)
+       -@$(DEL) config.w32
+       -@$(DEL) /f config.h
+       -@$(DEL) $(GLOBEXE)
+       -@$(DEL) $(PERLEXE)
+       -@$(DEL) $(WPERLEXE)
+       -@$(DEL) $(PERLDLL)
+       -@$(DEL) $(CORE_OBJ)
+       -if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
+       -rmdir /s $(MINIDIR)
+       -@$(DEL) $(WIN32_OBJ)
+       -@$(DEL) $(DLL_OBJ)
+       -@$(DEL) $(X2P_OBJ)
+       -@$(DEL) ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp *.res
+       -@$(DEL) ..\t\*.exe ..\t\*.dll ..\t\*.bat
+       -@$(DEL) ..\x2p\*.exe ..\x2p\*.bat
+       -@$(DEL) *.ilk
+       -@$(DEL) *.pdb
+
 # Handy way to run perlbug -ok without having to install and run the
 # installed perlbug. We don't re-run the tests here - we trust the user.
 # Please *don't* use this unless all tests pass.
@@ -1112,9 +1175,9 @@ ok: utils
 
 okfile: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
+
 nok: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
+
 nokfile: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
diff --git a/win32/bin/mdelete.bat b/win32/bin/mdelete.bat
new file mode 100644 (file)
index 0000000..0e7e8bd
--- /dev/null
@@ -0,0 +1,30 @@
+@echo off
+rem ! This is a batch file to delete all the files on its
+rem ! command line, to work around command.com's del command's
+rem ! braindeadness
+rem !
+rem !    -- BKS, 11-11-2000
+
+:nextfile
+set file=%1
+shift
+if "%file%"=="" goto end
+del %file%
+goto nextfile
+:end
+
+@echo off\r
+rem ! This is a batch file to delete all the files on its\r
+rem ! command line, to work around command.com's del command's\r
+rem ! braindeadness\r
+rem !\r
+rem !    -- BKS, 11-11-2000\r
+\r
+:nextfile\r
+set file=%1\r
+shift\r
+if "%file%"=="" goto end\r
+del %file%\r
+goto nextfile\r
+:end\r
+\r
index ad74001..5c3d65e 100644 (file)
@@ -621,7 +621,7 @@ sub read_rc
     local($line_num, $ln, $tag) = 0;
     local($use_default, @default) = 0;
 
-    { package magic; $\17 = 0; } ## turn off warnings for when we run EXPR's
+    { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's
 
     unless (open(RC, "$file")) {
        $use_default=1;
index 097d429..4e246fa 100644 (file)
@@ -40,7 +40,7 @@ byteorder='1234'
 c=''
 castflags='0'
 cat='type'
-cc='bcc32'
+cc='~CC~'
 cccdlflags=' '
 ccdlflags='-tWD'
 ccflags='-DWIN32'
@@ -70,6 +70,7 @@ cppsymbols=''
 crosscompile='undef'
 cryptlib=''
 csh='undef'
+d__fwalk='undef'
 d_Gconvert='gcvt((x),(n),(b))'
 d_PRIEUldbl='undef'
 d_PRIFUldbl='undef'
@@ -129,6 +130,7 @@ d_eunice='undef'
 d_fchmod='undef'
 d_fchown='undef'
 d_fcntl='undef'
+d_fcntl_can_lock='undef'
 d_fd_macros='define'
 d_fd_set='define'
 d_fds_bits='define'
@@ -144,6 +146,7 @@ d_fseeko='undef'
 d_fsetpos='define'
 d_fstatfs='undef'
 d_fstatvfs='undef'
+d_fsync='undef'
 d_ftello='undef'
 d_ftime='define'
 d_getcwd='undef'
@@ -163,6 +166,7 @@ d_getnbyaddr='undef'
 d_getnbyname='undef'
 d_getnent='undef'
 d_getnetprotos='undef'
+d_getpagsz='undef'
 d_getpbyname='define'
 d_getpbynumber='define'
 d_getpent='undef'
@@ -266,6 +270,7 @@ d_rmdir='define'
 d_safebcpy='undef'
 d_safemcpy='undef'
 d_sanemcmp='define'
+d_sbrkproto='undef'
 d_sched_yield='undef'
 d_scm_rights='undef'
 d_seekdir='define'
@@ -319,6 +324,8 @@ d_statfs_s='undef'
 d_statvfs='undef'
 d_stdio_cnt_lval='define'
 d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_ptr_lval_nochange_cnt='undef'
 d_stdio_stream_array='undef'
 d_stdiobase='define'
 d_stdstdio='define'
@@ -331,6 +338,7 @@ d_strtod='define'
 d_strtol='define'
 d_strtold='undef'
 d_strtoll='undef'
+d_strtoq='undef'
 d_strtoul='define'
 d_strtoull='undef'
 d_strtouq='undef'
@@ -522,12 +530,13 @@ installvendorarch=''
 installvendorbin=''
 installvendorlib=''
 intsize='4'
+issymlink=''
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
 known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~'
 ksh=''
-ld='tlink32'
+ld='~LINK32~'
 lddlflags='-Tpd ~LINK_FLAGS~'
 ldflags='~LINK_FLAGS~'
 ldlibpthname=''
@@ -597,6 +606,7 @@ mydomain=''
 myhostname=''
 myuname=''
 n='-n'
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='char *'
 netdb_name_type='char *'
index 9251b24..31c6b43 100644 (file)
@@ -40,7 +40,7 @@ byteorder='1234'
 c=''
 castflags='0'
 cat='type'
-cc='gcc'
+cc='~CC~'
 cccdlflags=' '
 ccdlflags=' '
 ccflags='-MD -DWIN32'
@@ -70,6 +70,7 @@ cppsymbols=''
 crosscompile='undef'
 cryptlib=''
 csh='undef'
+d__fwalk='undef'
 d_Gconvert='sprintf((b),"%.*g",(n),(x))'
 d_PRIEUldbl='undef'
 d_PRIFUldbl='undef'
@@ -129,6 +130,7 @@ d_eunice='undef'
 d_fchmod='undef'
 d_fchown='undef'
 d_fcntl='undef'
+d_fcntl_can_lock='undef'
 d_fd_macros='define'
 d_fd_set='define'
 d_fds_bits='define'
@@ -144,6 +146,7 @@ d_fseeko='undef'
 d_fsetpos='define'
 d_fstatfs='undef'
 d_fstatvfs='undef'
+d_fsync='undef'
 d_ftello='undef'
 d_ftime='define'
 d_getcwd='undef'
@@ -163,6 +166,7 @@ d_getnbyaddr='undef'
 d_getnbyname='undef'
 d_getnent='undef'
 d_getnetprotos='undef'
+d_getpagsz='undef'
 d_getpbyname='define'
 d_getpbynumber='define'
 d_getpent='undef'
@@ -266,6 +270,7 @@ d_rmdir='define'
 d_safebcpy='undef'
 d_safemcpy='undef'
 d_sanemcmp='define'
+d_sbrkproto='undef'
 d_sched_yield='undef'
 d_scm_rights='undef'
 d_seekdir='define'
@@ -319,6 +324,8 @@ d_statfs_s='undef'
 d_statvfs='undef'
 d_stdio_cnt_lval='define'
 d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_ptr_lval_nochange_cnt='define'
 d_stdio_stream_array='undef'
 d_stdiobase='define'
 d_stdstdio='define'
@@ -331,6 +338,7 @@ d_strtod='define'
 d_strtol='define'
 d_strtold='undef'
 d_strtoll='undef'
+d_strtoq='undef'
 d_strtoul='define'
 d_strtoull='undef'
 d_strtouq='undef'
@@ -522,6 +530,7 @@ installvendorarch=''
 installvendorbin=''
 installvendorlib=''
 intsize='4'
+issymlink=''
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
@@ -597,6 +606,7 @@ mydomain=''
 myhostname=''
 myuname=''
 n='-n'
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='char *'
 netdb_name_type='char *'
@@ -759,7 +769,7 @@ usemultiplicity='undef'
 usemymalloc='n'
 usenm='false'
 useopcode='true'
-useperlio='undef'
+useperlio='define'
 useposix='true'
 usesfio='false'
 useshrplib='yes'
index 61558e5..c526018 100644 (file)
@@ -1,4 +1,4 @@
-## Configured by: ~cf_email~
+# Configured by: ~cf_email~
 ## Target system: WIN32 
 Author=''
 CONFIGDOTSH='true'
@@ -40,7 +40,7 @@ byteorder='1234'
 c=''
 castflags='0'
 cat='type'
-cc='cl'
+cc='~CC~'
 cccdlflags=' '
 ccdlflags=' '
 ccflags='-MD -DWIN32'
@@ -70,6 +70,7 @@ cppsymbols=''
 crosscompile='undef'
 cryptlib=''
 csh='undef'
+d__fwalk='undef'
 d_Gconvert='sprintf((b),"%.*g",(n),(x))'
 d_PRIEUldbl='undef'
 d_PRIFUldbl='undef'
@@ -129,6 +130,7 @@ d_eunice='undef'
 d_fchmod='undef'
 d_fchown='undef'
 d_fcntl='undef'
+d_fcntl_can_lock='undef'
 d_fd_macros='define'
 d_fd_set='define'
 d_fds_bits='define'
@@ -144,6 +146,7 @@ d_fseeko='undef'
 d_fsetpos='define'
 d_fstatfs='undef'
 d_fstatvfs='undef'
+d_fsync='undef'
 d_ftello='undef'
 d_ftime='define'
 d_getcwd='undef'
@@ -163,6 +166,7 @@ d_getnbyaddr='undef'
 d_getnbyname='undef'
 d_getnent='undef'
 d_getnetprotos='undef'
+d_getpagsz='undef'
 d_getpbyname='define'
 d_getpbynumber='define'
 d_getpent='undef'
@@ -266,6 +270,7 @@ d_rmdir='define'
 d_safebcpy='undef'
 d_safemcpy='undef'
 d_sanemcmp='define'
+d_sbrkproto='undef'
 d_sched_yield='undef'
 d_scm_rights='undef'
 d_seekdir='define'
@@ -319,6 +324,8 @@ d_statfs_s='undef'
 d_statvfs='undef'
 d_stdio_cnt_lval='define'
 d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_ptr_lval_nochange_cnt='define'
 d_stdio_stream_array='undef'
 d_stdiobase='define'
 d_stdstdio='define'
@@ -331,6 +338,7 @@ d_strtod='define'
 d_strtol='define'
 d_strtold='undef'
 d_strtoll='undef'
+d_strtoq='undef'
 d_strtoul='define'
 d_strtoull='undef'
 d_strtouq='undef'
@@ -522,12 +530,13 @@ installvendorarch=''
 installvendorbin=''
 installvendorlib=''
 intsize='4'
+issymlink=''
 ivdformat='"ld"'
 ivsize='4'
 ivtype='long'
 known_extensions='~static_ext~ ~dynamic_ext~ ~nonxs_ext~'
 ksh=''
-ld='link'
+ld='~LINK32~'
 lddlflags='-dll ~LINK_FLAGS~'
 ldflags='~LINK_FLAGS~'
 ldlibpthname=''
@@ -597,6 +606,7 @@ mydomain=''
 myhostname=''
 myuname=''
 n='-n'
+need_va_copy='undef'
 netdb_hlen_type='int'
 netdb_host_type='char *'
 netdb_name_type='char *'
@@ -759,7 +769,7 @@ usemultiplicity='undef'
 usemymalloc='n'
 usenm='false'
 useopcode='true'
-useperlio='undef'
+useperlio='define'
 useposix='true'
 usesfio='false'
 useshrplib='yes'
index d71db98..2af3c6f 100644 (file)
@@ -1,11 +1,11 @@
 /*
  * This file was produced by running the config_h.SH script, which
- * gets its values from config.sh, which is generally produced by
+ * 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 config.sh and rerun config_h.SH.
+ * For a more permanent change edit undef and rerun config_h.SH.
  *
  * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
  */
@@ -13,8 +13,8 @@
 /*
  * Package name      : perl5
  * Source directory  : 
- * Configuration time: Tue Mar 21 01:26:35 2000
- * Configured by     : gsar
+ * Configuration time: Wed Dec  6 18:24:42 2000
+ * Configured by     : nick
  * Target system     : 
  */
 
  */
 /*#define HAS_FORK             /**/
 
-/* 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_FSETPOS:
  *     This symbol, if defined, indicates that the fsetpos routine is
  *     available to set the file position indicator, similar to fseek().
  */
 /*#define HAS_GETPGID          /**/
 
-/* 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_GETPGRP2:
  *     This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
  *     routine is available to get the current process group.
  */
 /*#define HAS_SETPGID  /**/
 
-/* 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_SETPGRP2:
  *     This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
  *     routine is available to set the current process group.
  */
 #define SH_PATH "cmd /x /c"  /**/
 
-/* 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 unsigned char  /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
  *     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.6.0\\lib\\MSWin32-x86"            /**/
+#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread"               /**/
 /*#define ARCHLIB_EXP ""       /**/
 
 /* ARCHNAME:
  *     where library files may be held under a private library, for
  *     instance.
  */
-#define ARCHNAME "MSWin32-x86"         /**/
+#define ARCHNAME "MSWin32-x86-multi-thread"            /**/
 
 /* HAS_ATOLF:
  *     This symbol, if defined, indicates that the atolf routine is
  *     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.6.0\\bin\\MSWin32-x86"        /**/
-#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86"    /**/
+#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"   /**/
+#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"       /**/
 
 /* PERL_BINCOMPAT_5005:
  *     This symbol, if defined, indicates that this version of Perl should be
  *     This macro surrounds its token with double quotes.
  */
 #if 42 == 1
-#  define CAT2(a,b)    a/**/b
-#  define STRINGIFY(a) "a"
+#define CAT2(a,b)      a/**/b
+#define STRINGIFY(a)   "a"
                /* If you can get stringification with catify, tell me how! */
 #endif
 #if 42 == 42
-#  define PeRl_CaTiFy(a, b)    a ## b  
-#  define PeRl_StGiFy(a)       #a
+#define PeRl_CaTiFy(a, b)      a ## b  
+#define PeRl_StGiFy(a) #a
 /* the additional level of indirection enables these macros to be
  * used as arguments to other macros.  See K&R 2nd ed., page 231. */
-#  define CAT2(a,b)    PeRl_CaTiFy(a,b)
-#  define StGiFy(a)    PeRl_StGiFy(a)
-#  define STRINGIFY(a) PeRl_StGiFy(a)
+#define CAT2(a,b)      PeRl_CaTiFy(a,b)
+#define StGiFy(a)      PeRl_StGiFy(a)
+#define STRINGIFY(a)   PeRl_StGiFy(a)
 #endif
 #if 42 != 1 && 42 != 42
-#include "Bletch: How does this C preprocessor catenate tokens?"
+#   include "Bletch: How does this C preprocessor catenate tokens?"
 #endif
 
 /* CPPSTDIN:
  */
 #define HAS_FD_SET     /**/
 
+/* FLEXFILENAMES:
+ *     This symbol, if defined, indicates that the system supports filenames
+ *     longer than 14 characters.
+ */
+#define        FLEXFILENAMES           /**/
+
 /* 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_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_GETNET_PROTOS       /**/
 
+/* 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_GETPROTOENT:
  *     This symbol, if defined, indicates that the getprotoent() routine is
  *     available to look up protocols in some data base or another.
  */
 #define        HAS_GETPROTO_PROTOS     /**/
 
+/* 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_GETPWENT:
  *     This symbol, if defined, indicates that the getpwent routine is
  *     available for sequential access of the passwd database.
  */
 /*#define HAS_GETSPNAM         /**/
 
-/* 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_GETPRPWNAM:
- *     This symbol, if defined, indicates that the getprpwnam system call is
- *     available to retrieve protected (shadow) password entries by name.
- */
-/*#define HAS_GETPRPWNAM               /**/
-
-/* I_PROT:
- *     This symbol, if defined, indicates that <prot.h> exists and
- *     should be included.
- */
-/*#define      I_PROT          /**/
-
 /* HAS_GETSERVBYNAME:
  *     This symbol, if defined, indicates that the getservbyname()
  *     routine is available to look up services by their name.
  */
 /*#define HAS_ISNANL           /**/
 
+/* 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_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
 /*#define HAS_MMAP             /**/
 #define Mmap_t void *  /**/
 
-/* 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_MODFL:
  *     This symbol, if defined, indicates that the modfl routine is
  *     available to split a long double x into a fractional part f and
  */
 /*#define HAS_MODFL            /**/
 
+/* 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_MSG:
  *     This symbol, if defined, indicates that the entire msg*(2) library is
  *     supported (IPC mechanism based on message queues).
  */
 /*#define HAS_SETPROTOENT              /**/
 
+/* HAS_SETPROCTITLE:
+ *     This symbol, if defined, indicates that the setproctitle routine is
+ *     available to set process title.
+ */
+/*#define HAS_SETPROCTITLE             /**/
+
 /* HAS_SETPWENT:
  *     This symbol, if defined, indicates that the setpwent routine is
  *     available for initializing sequential access of the passwd database.
 /*#define      HAS_MSG_PROXY   /**/
 /*#define      HAS_SCM_RIGHTS  /**/
 
+/* HAS_SOCKS5_INIT:
+ *     This symbol, if defined, indicates that the socks5_init routine is
+ *     available to initialize SOCKS 5.
+ */
+/*#define HAS_SOCKS5_INIT              /**/
+
 /* HAS_SQRTL:
  *     This symbol, if defined, indicates that the sqrtl routine is
  *     available to do long double square roots.
  *     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)->curp)
 #define STDIO_PTR_LVALUE               /**/
 #define FILE_cnt(fp)   ((fp)->level)
 #define STDIO_CNT_LVALUE               /**/
+/*#define STDIO_PTR_LVAL_SETS_CNT      /**/
+/*#define STDIO_PTR_LVAL_NOCHANGE_CNT  /**/
 #endif
 
 /* USE_STDIO_BASE:
  */
 /*#define   I_INTTYPES                /**/
 
+/* I_LIBUTIL:
+ *     This symbol, if defined, indicates that <libutil.h> exists and
+ *     should be included.
+ */
+/*#define      I_LIBUTIL               /**/
+
 /* I_MACH_CTHREADS:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <mach/cthreads.h>.
  */
 /*#define      I_POLL          /**/
 
+/* I_PROT:
+ *     This symbol, if defined, indicates that <prot.h> exists and
+ *     should be included.
+ */
+/*#define      I_PROT          /**/
+
 /* I_PTHREAD:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <pthread.h>.
  *     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        undef   /**/
 
 /* Off_t:
  *     This symbol holds the type used to declare offsets in the kernel.
 #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 ""         /**/
+
 /* IVTYPE:
  *     This symbol defines the C type used for Perl's IV.
  */
 /* 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 bit of a variable of type UVTYPE.
+ *     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
 #define        I64SIZE         8       /**/
 #define        U64SIZE         8       /**/
 #endif
+#define        NVSIZE          8               /**/
 #define        NV_PRESERVES_UV
 #define        NV_PRESERVES_UV_BITS    32
 
  */
 /* UVxf:
  *     This symbol defines the format string used for printing a Perl UV
- *     as an unsigned hexadecimal integer.
+ *     as an unsigned hexadecimal integer in lowercase abcdef.
  */
 /* NVef:
  *     This symbol defines the format string used for printing a Perl NV
  *     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\\5.6.0\\lib"         /**/
-#define PRIVLIB_EXP (win32_get_privlib("5.6.0"))       /**/
+#define PRIVLIB "c:\\perl\\5.7.0\\lib"         /**/
+#define PRIVLIB_EXP (win32_get_privlib("5.7.0"))       /**/
 
 /* PTRSIZE:
  *     This symbol contains the size of a pointer, so that the C preprocessor
  *     This symbol contains the ~name expanded version of SITEARCH, to be used
  *     in programs that are not prepared to deal with ~ expansion at run-time.
  */
-#define SITEARCH "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86"             /**/
+#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread"                /**/
 /*#define SITEARCH_EXP ""      /**/
 
 /* SITELIB:
  *     removed.  The elements in inc_version_list (inc_version_list.U) can
  *     be tacked onto this variable to generate a list of directories to search.
  */
-#define SITELIB "c:\\perl\\site\\5.6.0\\lib"           /**/
-#define SITELIB_EXP (win32_get_sitelib("5.6.0"))       /**/
+#define SITELIB "c:\\perl\\site\\5.7.0\\lib"           /**/
+#define SITELIB_EXP (win32_get_sitelib("5.7.0"))       /**/
 #define SITELIB_STEM ""                /**/
 
 /* Size_t_size:
  *     be built to use multiplicity.
  */
 #ifndef MULTIPLICITY
-/*#define      MULTIPLICITY            /**/
+#define        MULTIPLICITY            /**/
 #endif
 
 /* USE_PERLIO:
  *     be built to use the old draft POSIX threads API.
  */
 /*#define      USE_5005THREADS         /**/
-/*#define      USE_ITHREADS            /**/
+#define        USE_ITHREADS            /**/
 #if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
 #define                USE_THREADS             /* until src is revised*/
 #endif
 /* PERL_XS_APIVERSION:
  *     This variable contains the version of the oldest perl binary
  *     compatible with the present perl.  perl.c:incpush() and
- *     lib/lib.pm will automatically search in c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older
+ *     lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread for older
  *     directories across major versions back to xs_apiversion.
  *     This is only useful if you have a perl library directory tree
  *     structured like the default one.
  *     compatible with the present perl.  (That is, pure perl modules
  *     written for pm_apiversion will still work for the current
  *     version).  perl.c:incpush() and lib/lib.pm will automatically
- *     search in c:\\perl\\site\\5.6.0\\lib for older directories across major versions
+ *     search in c:\\perl\\site\\5.7.0\\lib for older directories across major versions
  *     back to pm_apiversion.  This is only useful if you have a perl
  *     library directory tree structured like the default one.  The
  *     versioned site_perl library was introduced in 5.005, so that's
 #define PERL_XS_APIVERSION "5.6.0"
 #define PERL_PM_APIVERSION "5.005"
 
-/* HAS_LCHOWN:
- *     This symbol, if defined, indicates that the lchown routine is
- *     available to operate on a symbolic link (instead of following the
- *     link).
+/* HAS_GETPGRP:
+ *     This symbol, if defined, indicates that the getpgrp routine is
+ *     available to get the current process group.
  */
-/*#define HAS_LCHOWN           /**/
+/* 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      /**/
 
-/* FLEXFILENAMES:
- *     This symbol, if defined, indicates that the system supports filenames
- *     longer than 14 characters.
+/* HAS_SETPGRP:
+ *     This symbol, if defined, indicates that the setpgrp routine is
+ *     available to set the current process group.
  */
-#define        FLEXFILENAMES           /**/
+/* 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      /**/
+
+/* 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 unsigned char  /**/
+
+/* 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           /**/
+
+/* 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_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_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  /**/
+
+/* 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            /**/
 
 #endif
index f943aad..d26492f 100644 (file)
@@ -1,11 +1,11 @@
 /*
  * This file was produced by running the config_h.SH script, which
- * gets its values from config.sh, which is generally produced by
+ * 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 config.sh and rerun config_h.SH.
+ * For a more permanent change edit undef and rerun config_h.SH.
  *
  * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
  */
@@ -13,8 +13,8 @@
 /*
  * Package name      : perl5
  * Source directory  : 
- * Configuration time: Tue Mar 21 01:26:44 2000
- * Configured by     : gsar
+ * Configuration time: Wed Dec  6 18:22:28 2000
+ * Configured by     : nick
  * Target system     : 
  */
 
  */
 /*#define HAS_FORK             /**/
 
-/* 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_FSETPOS:
  *     This symbol, if defined, indicates that the fsetpos routine is
  *     available to set the file position indicator, similar to fseek().
  */
 /*#define HAS_GETPGID          /**/
 
-/* 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_GETPGRP2:
  *     This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
  *     routine is available to get the current process group.
  */
 /*#define HAS_SETPGID  /**/
 
-/* 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_SETPGRP2:
  *     This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
  *     routine is available to set the current process group.
  */
 #define SH_PATH "cmd /x /c"  /**/
 
-/* 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   /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
  *     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.6.0\\lib\\MSWin32-x86"            /**/
+#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread"               /**/
 /*#define ARCHLIB_EXP ""       /**/
 
 /* ARCHNAME:
  *     where library files may be held under a private library, for
  *     instance.
  */
-#define ARCHNAME "MSWin32-x86"         /**/
+#define ARCHNAME "MSWin32-x86-multi-thread"            /**/
 
 /* HAS_ATOLF:
  *     This symbol, if defined, indicates that the atolf routine is
  *     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.6.0\\bin\\MSWin32-x86"        /**/
-#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86"    /**/
+#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"   /**/
+#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"       /**/
 
 /* PERL_BINCOMPAT_5005:
  *     This symbol, if defined, indicates that this version of Perl should be
  *     This macro surrounds its token with double quotes.
  */
 #if 42 == 1
-#  define CAT2(a,b)    a/**/b
-#  define STRINGIFY(a) "a"
+#define CAT2(a,b)      a/**/b
+#define STRINGIFY(a)   "a"
                /* If you can get stringification with catify, tell me how! */
 #endif
 #if 42 == 42
-#  define PeRl_CaTiFy(a, b)    a ## b  
-#  define PeRl_StGiFy(a)       #a
+#define PeRl_CaTiFy(a, b)      a ## b  
+#define PeRl_StGiFy(a) #a
 /* the additional level of indirection enables these macros to be
  * used as arguments to other macros.  See K&R 2nd ed., page 231. */
-#  define CAT2(a,b)    PeRl_CaTiFy(a,b)
-#  define StGiFy(a)    PeRl_StGiFy(a)
-#  define STRINGIFY(a) PeRl_StGiFy(a)
+#define CAT2(a,b)      PeRl_CaTiFy(a,b)
+#define StGiFy(a)      PeRl_StGiFy(a)
+#define STRINGIFY(a)   PeRl_StGiFy(a)
 #endif
 #if 42 != 1 && 42 != 42
-#include "Bletch: How does this C preprocessor catenate tokens?"
+#   include "Bletch: How does this C preprocessor catenate tokens?"
 #endif
 
 /* CPPSTDIN:
  */
 #define HAS_FD_SET     /**/
 
+/* FLEXFILENAMES:
+ *     This symbol, if defined, indicates that the system supports filenames
+ *     longer than 14 characters.
+ */
+#define        FLEXFILENAMES           /**/
+
 /* 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_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_GETNET_PROTOS       /**/
 
+/* 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_GETPROTOENT:
  *     This symbol, if defined, indicates that the getprotoent() routine is
  *     available to look up protocols in some data base or another.
  */
 #define        HAS_GETPROTO_PROTOS     /**/
 
+/* 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_GETPWENT:
  *     This symbol, if defined, indicates that the getpwent routine is
  *     available for sequential access of the passwd database.
  */
 /*#define HAS_GETSPNAM         /**/
 
-/* 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_GETPRPWNAM:
- *     This symbol, if defined, indicates that the getprpwnam system call is
- *     available to retrieve protected (shadow) password entries by name.
- */
-/*#define HAS_GETPRPWNAM               /**/
-
-/* I_PROT:
- *     This symbol, if defined, indicates that <prot.h> exists and
- *     should be included.
- */
-/*#define      I_PROT          /**/
-
 /* HAS_GETSERVBYNAME:
  *     This symbol, if defined, indicates that the getservbyname()
  *     routine is available to look up services by their name.
  */
 /*#define HAS_ISNANL           /**/
 
+/* 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_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
 /*#define HAS_MMAP             /**/
 #define Mmap_t void *  /**/
 
-/* 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_MODFL:
  *     This symbol, if defined, indicates that the modfl routine is
  *     available to split a long double x into a fractional part f and
  */
 /*#define HAS_MODFL            /**/
 
+/* 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_MSG:
  *     This symbol, if defined, indicates that the entire msg*(2) library is
  *     supported (IPC mechanism based on message queues).
  */
 /*#define HAS_SETPROTOENT              /**/
 
+/* HAS_SETPROCTITLE:
+ *     This symbol, if defined, indicates that the setproctitle routine is
+ *     available to set process title.
+ */
+/*#define HAS_SETPROCTITLE             /**/
+
 /* HAS_SETPWENT:
  *     This symbol, if defined, indicates that the setpwent routine is
  *     available for initializing sequential access of the passwd database.
 /*#define      HAS_MSG_PROXY   /**/
 /*#define      HAS_SCM_RIGHTS  /**/
 
+/* HAS_SOCKS5_INIT:
+ *     This symbol, if defined, indicates that the socks5_init routine is
+ *     available to initialize SOCKS 5.
+ */
+/*#define HAS_SOCKS5_INIT              /**/
+
 /* HAS_SQRTL:
  *     This symbol, if defined, indicates that the sqrtl routine is
  *     available to do long double square roots.
  *     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:
  */
 /*#define   I_INTTYPES                /**/
 
+/* I_LIBUTIL:
+ *     This symbol, if defined, indicates that <libutil.h> exists and
+ *     should be included.
+ */
+/*#define      I_LIBUTIL               /**/
+
 /* I_MACH_CTHREADS:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <mach/cthreads.h>.
  */
 /*#define      I_POLL          /**/
 
+/* I_PROT:
+ *     This symbol, if defined, indicates that <prot.h> exists and
+ *     should be included.
+ */
+/*#define      I_PROT          /**/
+
 /* I_PTHREAD:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <pthread.h>.
  *     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        undef   /**/
 
 /* Off_t:
  *     This symbol holds the type used to declare offsets in the kernel.
 #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 ""         /**/
+
 /* IVTYPE:
  *     This symbol defines the C type used for Perl's IV.
  */
 /* 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 bit of a variable of type UVTYPE.
+ *     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
 #define        I64SIZE         8       /**/
 #define        U64SIZE         8       /**/
 #endif
+#define        NVSIZE          8               /**/
 #define        NV_PRESERVES_UV
 #define        NV_PRESERVES_UV_BITS    32
 
  */
 /* UVxf:
  *     This symbol defines the format string used for printing a Perl UV
- *     as an unsigned hexadecimal integer.
+ *     as an unsigned hexadecimal integer in lowercase abcdef.
  */
 /* NVef:
  *     This symbol defines the format string used for printing a Perl NV
  *     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\\5.6.0\\lib"         /**/
-#define PRIVLIB_EXP (win32_get_privlib("5.6.0"))       /**/
+#define PRIVLIB "c:\\perl\\5.7.0\\lib"         /**/
+#define PRIVLIB_EXP (win32_get_privlib("5.7.0"))       /**/
 
 /* PTRSIZE:
  *     This symbol contains the size of a pointer, so that the C preprocessor
  *     This symbol contains the ~name expanded version of SITEARCH, to be used
  *     in programs that are not prepared to deal with ~ expansion at run-time.
  */
-#define SITEARCH "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86"             /**/
+#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread"                /**/
 /*#define SITEARCH_EXP ""      /**/
 
 /* SITELIB:
  *     removed.  The elements in inc_version_list (inc_version_list.U) can
  *     be tacked onto this variable to generate a list of directories to search.
  */
-#define SITELIB "c:\\perl\\site\\5.6.0\\lib"           /**/
-#define SITELIB_EXP (win32_get_sitelib("5.6.0"))       /**/
+#define SITELIB "c:\\perl\\site\\5.7.0\\lib"           /**/
+#define SITELIB_EXP (win32_get_sitelib("5.7.0"))       /**/
 #define SITELIB_STEM ""                /**/
 
 /* Size_t_size:
  *     be built to use multiplicity.
  */
 #ifndef MULTIPLICITY
-/*#define      MULTIPLICITY            /**/
+#define        MULTIPLICITY            /**/
 #endif
 
 /* USE_PERLIO:
  *     used in a fully backward compatible manner.
  */
 #ifndef USE_PERLIO
-/*#define      USE_PERLIO              /**/
+#define        USE_PERLIO              /**/
 #endif
 
 /* USE_SOCKS:
  *     be built to use the old draft POSIX threads API.
  */
 /*#define      USE_5005THREADS         /**/
-/*#define      USE_ITHREADS            /**/
+#define        USE_ITHREADS            /**/
 #if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
 #define                USE_THREADS             /* until src is revised*/
 #endif
 /* PERL_XS_APIVERSION:
  *     This variable contains the version of the oldest perl binary
  *     compatible with the present perl.  perl.c:incpush() and
- *     lib/lib.pm will automatically search in c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older
+ *     lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread for older
  *     directories across major versions back to xs_apiversion.
  *     This is only useful if you have a perl library directory tree
  *     structured like the default one.
  *     compatible with the present perl.  (That is, pure perl modules
  *     written for pm_apiversion will still work for the current
  *     version).  perl.c:incpush() and lib/lib.pm will automatically
- *     search in c:\\perl\\site\\5.6.0\\lib for older directories across major versions
+ *     search in c:\\perl\\site\\5.7.0\\lib for older directories across major versions
  *     back to pm_apiversion.  This is only useful if you have a perl
  *     library directory tree structured like the default one.  The
  *     versioned site_perl library was introduced in 5.005, so that's
 #define PERL_XS_APIVERSION "5.6.0"
 #define PERL_PM_APIVERSION "5.005"
 
-/* HAS_LCHOWN:
- *     This symbol, if defined, indicates that the lchown routine is
- *     available to operate on a symbolic link (instead of following the
- *     link).
+/* HAS_GETPGRP:
+ *     This symbol, if defined, indicates that the getpgrp routine is
+ *     available to get the current process group.
  */
-/*#define HAS_LCHOWN           /**/
+/* 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      /**/
 
-/* FLEXFILENAMES:
- *     This symbol, if defined, indicates that the system supports filenames
- *     longer than 14 characters.
+/* HAS_SETPGRP:
+ *     This symbol, if defined, indicates that the setpgrp routine is
+ *     available to set the current process group.
  */
-#define        FLEXFILENAMES           /**/
+/* 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      /**/
+
+/* 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   /**/
+
+/* 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           /**/
+
+/* 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_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_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  /**/
+
+/* 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            /**/
 
 #endif
index 6b8d234..0aa5f38 100644 (file)
@@ -1,11 +1,11 @@
 /*
  * This file was produced by running the config_h.SH script, which
- * gets its values from config.sh, which is generally produced by
+ * 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 config.sh and rerun config_h.SH.
+ * For a more permanent change edit undef and rerun config_h.SH.
  *
  * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
  */
@@ -13,8 +13,8 @@
 /*
  * Package name      : perl5
  * Source directory  : 
- * Configuration time: Tue Mar 21 01:26:24 2000
- * Configured by     : gsar
+ * Configuration time: Wed Dec  6 14:45:43 2000
+ * Configured by     : nick
  * Target system     : 
  */
 
  */
 /*#define HAS_FORK             /**/
 
-/* 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_FSETPOS:
  *     This symbol, if defined, indicates that the fsetpos routine is
  *     available to set the file position indicator, similar to fseek().
  */
 /*#define HAS_GETPGID          /**/
 
-/* 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_GETPGRP2:
  *     This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
  *     routine is available to get the current process group.
  */
 /*#define HAS_SETPGID  /**/
 
-/* 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_SETPGRP2:
  *     This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
  *     routine is available to set the current process group.
  */
 #define SH_PATH "cmd /x /c"  /**/
 
-/* 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   /**/
-
 /* CROSSCOMPILE:
  *     This symbol, if defined, signifies that we our
  *     build process is a cross-compilation.
  *     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.6.0\\lib\\MSWin32-x86"            /**/
+#define ARCHLIB "c:\\perl\\5.7.0\\lib\\MSWin32-x86-multi-thread"               /**/
 /*#define ARCHLIB_EXP ""       /**/
 
 /* ARCHNAME:
  *     where library files may be held under a private library, for
  *     instance.
  */
-#define ARCHNAME "MSWin32-x86"         /**/
+#define ARCHNAME "MSWin32-x86-multi-thread"            /**/
 
 /* HAS_ATOLF:
  *     This symbol, if defined, indicates that the atolf routine is
  *     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.6.0\\bin\\MSWin32-x86"        /**/
-#define BIN_EXP "c:\\perl\\5.6.0\\bin\\MSWin32-x86"    /**/
+#define BIN "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"   /**/
+#define BIN_EXP "c:\\perl\\5.7.0\\bin\\MSWin32-x86-multi-thread"       /**/
 
 /* PERL_BINCOMPAT_5005:
  *     This symbol, if defined, indicates that this version of Perl should be
  *     This macro surrounds its token with double quotes.
  */
 #if 42 == 1
-#  define CAT2(a,b)    a/**/b
-#  define STRINGIFY(a) "a"
+#define CAT2(a,b)      a/**/b
+#define STRINGIFY(a)   "a"
                /* If you can get stringification with catify, tell me how! */
 #endif
 #if 42 == 42
-#  define PeRl_CaTiFy(a, b)    a ## b  
-#  define PeRl_StGiFy(a)       #a
+#define PeRl_CaTiFy(a, b)      a ## b  
+#define PeRl_StGiFy(a) #a
 /* the additional level of indirection enables these macros to be
  * used as arguments to other macros.  See K&R 2nd ed., page 231. */
-#  define CAT2(a,b)    PeRl_CaTiFy(a,b)
-#  define StGiFy(a)    PeRl_StGiFy(a)
-#  define STRINGIFY(a) PeRl_StGiFy(a)
+#define CAT2(a,b)      PeRl_CaTiFy(a,b)
+#define StGiFy(a)      PeRl_StGiFy(a)
+#define STRINGIFY(a)   PeRl_StGiFy(a)
 #endif
 #if 42 != 1 && 42 != 42
-#include "Bletch: How does this C preprocessor catenate tokens?"
+#   include "Bletch: How does this C preprocessor catenate tokens?"
 #endif
 
 /* CPPSTDIN:
  */
 #define HAS_FD_SET     /**/
 
+/* FLEXFILENAMES:
+ *     This symbol, if defined, indicates that the system supports filenames
+ *     longer than 14 characters.
+ */
+#define        FLEXFILENAMES           /**/
+
 /* 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_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_GETNET_PROTOS       /**/
 
+/* 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_GETPROTOENT:
  *     This symbol, if defined, indicates that the getprotoent() routine is
  *     available to look up protocols in some data base or another.
  */
 #define        HAS_GETPROTO_PROTOS     /**/
 
+/* 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_GETPWENT:
  *     This symbol, if defined, indicates that the getpwent routine is
  *     available for sequential access of the passwd database.
  */
 /*#define HAS_GETSPNAM         /**/
 
-/* 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_GETPRPWNAM:
- *     This symbol, if defined, indicates that the getprpwnam system call is
- *     available to retrieve protected (shadow) password entries by name.
- */
-/*#define HAS_GETPRPWNAM               /**/
-
-/* I_PROT:
- *     This symbol, if defined, indicates that <prot.h> exists and
- *     should be included.
- */
-/*#define      I_PROT          /**/
-
 /* HAS_GETSERVBYNAME:
  *     This symbol, if defined, indicates that the getservbyname()
  *     routine is available to look up services by their name.
  */
 /*#define HAS_ISNANL           /**/
 
+/* 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_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
 /*#define HAS_MMAP             /**/
 #define Mmap_t void *  /**/
 
-/* 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_MODFL:
  *     This symbol, if defined, indicates that the modfl routine is
  *     available to split a long double x into a fractional part f and
  */
 /*#define HAS_MODFL            /**/
 
+/* 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_MSG:
  *     This symbol, if defined, indicates that the entire msg*(2) library is
  *     supported (IPC mechanism based on message queues).
  */
 /*#define HAS_SETPROTOENT              /**/
 
+/* HAS_SETPROCTITLE:
+ *     This symbol, if defined, indicates that the setproctitle routine is
+ *     available to set process title.
+ */
+/*#define HAS_SETPROCTITLE             /**/
+
 /* HAS_SETPWENT:
  *     This symbol, if defined, indicates that the setpwent routine is
  *     available for initializing sequential access of the passwd database.
 /*#define      HAS_MSG_PROXY   /**/
 /*#define      HAS_SCM_RIGHTS  /**/
 
+/* HAS_SOCKS5_INIT:
+ *     This symbol, if defined, indicates that the socks5_init routine is
+ *     available to initialize SOCKS 5.
+ */
+/*#define HAS_SOCKS5_INIT              /**/
+
 /* HAS_SQRTL:
  *     This symbol, if defined, indicates that the sqrtl routine is
  *     available to do long double square roots.
  *     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:
  */
 /*#define   I_INTTYPES                /**/
 
+/* I_LIBUTIL:
+ *     This symbol, if defined, indicates that <libutil.h> exists and
+ *     should be included.
+ */
+/*#define      I_LIBUTIL               /**/
+
 /* I_MACH_CTHREADS:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <mach/cthreads.h>.
  */
 /*#define      I_POLL          /**/
 
+/* I_PROT:
+ *     This symbol, if defined, indicates that <prot.h> exists and
+ *     should be included.
+ */
+/*#define      I_PROT          /**/
+
 /* I_PTHREAD:
  *     This symbol, if defined, indicates to the C program that it should
  *     include <pthread.h>.
  *     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        undef   /**/
 
 /* Off_t:
  *     This symbol holds the type used to declare offsets in the kernel.
 #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 ""         /**/
+
 /* IVTYPE:
  *     This symbol defines the C type used for Perl's IV.
  */
 /* 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 bit of a variable of type UVTYPE.
+ *     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
 #define        I64SIZE         8       /**/
 #define        U64SIZE         8       /**/
 #endif
+#define        NVSIZE          8               /**/
 #define        NV_PRESERVES_UV
 #define        NV_PRESERVES_UV_BITS    32
 
  */
 /* UVxf:
  *     This symbol defines the format string used for printing a Perl UV
- *     as an unsigned hexadecimal integer.
+ *     as an unsigned hexadecimal integer in lowercase abcdef.
  */
 /* NVef:
  *     This symbol defines the format string used for printing a Perl NV
  *     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\\5.6.0\\lib"         /**/
-#define PRIVLIB_EXP (win32_get_privlib("5.6.0"))       /**/
+#define PRIVLIB "c:\\perl\\5.7.0\\lib"         /**/
+#define PRIVLIB_EXP (win32_get_privlib("5.7.0"))       /**/
 
 /* PTRSIZE:
  *     This symbol contains the size of a pointer, so that the C preprocessor
  *     This symbol contains the ~name expanded version of SITEARCH, to be used
  *     in programs that are not prepared to deal with ~ expansion at run-time.
  */
-#define SITEARCH "c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86"             /**/
+#define SITEARCH "c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread"                /**/
 /*#define SITEARCH_EXP ""      /**/
 
 /* SITELIB:
  *     removed.  The elements in inc_version_list (inc_version_list.U) can
  *     be tacked onto this variable to generate a list of directories to search.
  */
-#define SITELIB "c:\\perl\\site\\5.6.0\\lib"           /**/
-#define SITELIB_EXP (win32_get_sitelib("5.6.0"))       /**/
+#define SITELIB "c:\\perl\\site\\5.7.0\\lib"           /**/
+#define SITELIB_EXP (win32_get_sitelib("5.7.0"))       /**/
 #define SITELIB_STEM ""                /**/
 
 /* Size_t_size:
  *     be built to use multiplicity.
  */
 #ifndef MULTIPLICITY
-/*#define      MULTIPLICITY            /**/
+#define        MULTIPLICITY            /**/
 #endif
 
 /* USE_PERLIO:
  *     used in a fully backward compatible manner.
  */
 #ifndef USE_PERLIO
-/*#define      USE_PERLIO              /**/
+#define        USE_PERLIO              /**/
 #endif
 
 /* USE_SOCKS:
  *     be built to use the old draft POSIX threads API.
  */
 /*#define      USE_5005THREADS         /**/
-/*#define      USE_ITHREADS            /**/
+#define        USE_ITHREADS            /**/
 #if defined(USE_5005THREADS) && !defined(USE_ITHREADS)
 #define                USE_THREADS             /* until src is revised*/
 #endif
 /* PERL_XS_APIVERSION:
  *     This variable contains the version of the oldest perl binary
  *     compatible with the present perl.  perl.c:incpush() and
- *     lib/lib.pm will automatically search in c:\\perl\\site\\5.6.0\\lib\\MSWin32-x86 for older
+ *     lib/lib.pm will automatically search in c:\\perl\\site\\5.7.0\\lib\\MSWin32-x86-multi-thread for older
  *     directories across major versions back to xs_apiversion.
  *     This is only useful if you have a perl library directory tree
  *     structured like the default one.
  *     compatible with the present perl.  (That is, pure perl modules
  *     written for pm_apiversion will still work for the current
  *     version).  perl.c:incpush() and lib/lib.pm will automatically
- *     search in c:\\perl\\site\\5.6.0\\lib for older directories across major versions
+ *     search in c:\\perl\\site\\5.7.0\\lib for older directories across major versions
  *     back to pm_apiversion.  This is only useful if you have a perl
  *     library directory tree structured like the default one.  The
  *     versioned site_perl library was introduced in 5.005, so that's
 #define PERL_XS_APIVERSION "5.6.0"
 #define PERL_PM_APIVERSION "5.005"
 
-/* HAS_LCHOWN:
- *     This symbol, if defined, indicates that the lchown routine is
- *     available to operate on a symbolic link (instead of following the
- *     link).
+/* HAS_GETPGRP:
+ *     This symbol, if defined, indicates that the getpgrp routine is
+ *     available to get the current process group.
  */
-/*#define HAS_LCHOWN           /**/
+/* 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      /**/
 
-/* FLEXFILENAMES:
- *     This symbol, if defined, indicates that the system supports filenames
- *     longer than 14 characters.
+/* HAS_SETPGRP:
+ *     This symbol, if defined, indicates that the setpgrp routine is
+ *     available to set the current process group.
  */
-#define        FLEXFILENAMES           /**/
+/* 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      /**/
+
+/* 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   /**/
+
+/* 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           /**/
+
+/* 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_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_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  /**/
+
+/* 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            /**/
 
 #endif
index 91f35a4..a0ee22d 100644 (file)
@@ -45,7 +45,7 @@ eval $str;
 die "$str:$@" if $@;
 
 open(H,">$file.new") || die "Cannot open $file.new:$!";
-binmode H;             # no CRs (which cause a spurious rebuild)
+#binmode H;            # no CRs (which cause a spurious rebuild)
 while (<SH>)
  {
   last if /^$term$/o;
diff --git a/win32/distclean.bat b/win32/distclean.bat
new file mode 100755 (executable)
index 0000000..e202eab
--- /dev/null
@@ -0,0 +1,30 @@
+@perl -w -Sx %0 %*
+@goto end_of_perl
+#!perl -w
+BEGIN { push(@INC,'lib') }
+use strict;
+use File::Find;
+use ExtUtils::Manifest qw(maniread);
+my $files = maniread();
+my @dead;
+find(sub { 
+return if -d $_;
+my $name = $File::Find::name;
+$name =~ s#^\./##;
+ unless (exists $files->{$name})
+  {
+   print "new $name\n";
+   push(@dead,$name);
+  } 
+},'.');
+
+foreach my $file (@dead)
+ {
+  chmod(0666,$file) unless -w $file;
+  unlink($file) || warn "Cannot delete $file:$!";
+ }
+
+__END__
+:end_of_perl
+del perl.exe
+del perl*.dll
\ No newline at end of file
index 194de95..e83fd2b 100644 (file)
 extern "C" {
 #endif
 
-#ifndef  _WINDOWS_
-#ifdef   __GNUC__
 #define WIN32_LEAN_AND_MEAN
 #ifdef __GNUC__
-#define Win32_Winsock
+#  define Win32_Winsock
 #endif
 #include <windows.h>
-#else
-#define  _WINDOWS_
-
-#define  FAR
-#define  PASCAL     __stdcall
-#define  WINAPI     __stdcall
-
-#undef WORD
-typedef  int        BOOL;
-typedef  unsigned short WORD;
-typedef  void*      HANDLE;
-typedef  void*      HWND;
-typedef  int (FAR WINAPI *FARPROC)();
-
-typedef unsigned long       DWORD;
-typedef void *PVOID;
-
-#define IN
-#define OUT
-
-typedef struct _OVERLAPPED {
-    DWORD   Internal;
-    DWORD   InternalHigh;
-    DWORD   Offset;
-    DWORD   OffsetHigh;
-    HANDLE  hEvent;
-} OVERLAPPED, *LPOVERLAPPED;
-
-#endif
-#endif //_WINDOWS_
-// #ifndef __GNUC__
 #include <winsock.h>
-// #endif
 
 #define  ENOTSOCK      WSAENOTSOCK
-#undef   HOST_NOT_FOUND
 
 #ifdef USE_SOCKETS_AS_HANDLES
 
index 86a2bf4..974deb3 100644 (file)
@@ -6,7 +6,7 @@
 #      Mingw32 with gcc-2.95.2 or better  **experimental**
 #
 # This is set up to build a perl.exe that runs off a shared library
-# (perl56.dll).  Also makes individual DLLs for the XS extensions.
+# (perl57.dll).  Also makes individual DLLs for the XS extensions.
 #
 
 ##
@@ -33,7 +33,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.6.0
+INST_VER       *= \5.7.0
 
 #
 # Comment this out if you DON'T want your perl installation to have
@@ -50,21 +50,21 @@ INST_ARCH   *= \$(ARCHNAME)
 # uncomment to enable multiple interpreters.  This is need for fork()
 # emulation.
 #
-#USE_MULTI     *= define
+USE_MULTI      *= define
 
 #
 # Beginnings of interpreter cloning/threads; still very incomplete.
 # This should be enabled to get the fork() emulation.  This needs
 # USE_MULTI as well.
 #
-#USE_ITHREADS  *= define
+USE_ITHREADS   *= define
 
 #
 # uncomment to enable the implicit "host" layer for all system calls
 # made by perl.  This needs USE_MULTI above.  This is also needed to
 # get fork().
 #
-#USE_IMP_SYS   *= define
+USE_IMP_SYS    *= define
 
 #
 # WARNING! This option is deprecated and will eventually go away (enable
@@ -89,17 +89,17 @@ INST_ARCH   *= \$(ARCHNAME)
 
 #
 # uncomment exactly one of the following
-# 
+#
 # Visual C++ 2.x
 #CCTYPE                *= MSVC20
 # Visual C++ > 2.x and < 6.x
 #CCTYPE                *= MSVC
 # Visual C++ >= 6.x
-#CCTYPE                *= MSVC60
+CCTYPE         *= MSVC60
 # Borland 5.02 or later
 #CCTYPE                *= BORLAND
 # mingw32+gcc-2.95.2 or better
-CCTYPE         *= GCC
+#CCTYPE                *= GCC
 
 #
 # uncomment this if you are compiling under Windows 95/98 and command.com
@@ -111,7 +111,7 @@ CCTYPE              *= GCC
 # If not enabled, we automatically try to use maximum optimization
 # with all compilers that are known to have a working optimizer.
 #
-#CFG           *= Debug
+CFG            *= Debug
 
 #
 # uncomment to enable use of PerlCRT.DLL when using the Visual C compiler.
@@ -165,7 +165,7 @@ CCTYPE              *= GCC
 #
 #CCHOME                *= c:\bc5
 #CCHOME                *= $(MSVCDIR)
-CCHOME         *= c:\gcc-2.95.2-msvcrt
+CCHOME         *= c:\gcc-2.95.2
 CCINCDIR       *= $(CCHOME)\include
 CCLIBDIR       *= $(CCHOME)\lib
 
@@ -290,12 +290,15 @@ ARCHNAME  !:= $(ARCHNAME)-thread
 
 # VC 6.0 can load the socket dll on demand.  Makes the test suite
 # run in about 10% less time.
-DELAYLOAD      *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib 
+DELAYLOAD      *= -DELAYLOAD:wsock32.dll -DELAYLOAD:shell32.dll delayimp.lib
 
+.IF "$(CFG)" == "Debug"
+.ELSE
 # VC 6.0 seems capable of compiling perl correctly with optimizations
 # enabled.  Anything earlier fails tests.
 CFG            *= Optimize
 .ENDIF
+.ENDIF
 
 ARCHDIR                = ..\lib\$(ARCHNAME)
 COREDIR                = ..\lib\CORE
@@ -332,7 +335,7 @@ RSC         = rc
 # Options
 #
 INCLUDES       = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)"
-#PCHFLAGS      = -H -Hc -H=c:\temp\bcmoduls.pch 
+#PCHFLAGS      = -H -Hc -H=c:\temp\bcmoduls.pch
 DEFINES                = -DWIN32 $(CRYPT_FLAG)
 LOCDEFS                = -DPERLDLL -DPERL_CORE
 SUBSYS         = console
@@ -346,7 +349,7 @@ OPTIMIZE    = -v -D_RTLDLL -DDEBUGGING
 LINK_DBG       = -v
 .ELSE
 OPTIMIZE       = -O2 -D_RTLDLL
-LINK_DBG       = 
+LINK_DBG       =
 .ENDIF
 
 CFLAGS         = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
@@ -354,7 +357,7 @@ CFLAGS              = -w -g0 -tWM -tWD $(INCLUDES) $(DEFINES) $(LOCDEFS) \
 LINK_FLAGS     = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
 OBJOUT_FLAG    = -o
 EXEOUT_FLAG    = -e
-LIBOUT_FLAG    = 
+LIBOUT_FLAG    =
 
 .ELIF "$(CCTYPE)" == "GCC"
 
@@ -364,6 +367,7 @@ LIB32               = ar rc
 IMPLIB         = dlltool
 RSC            = rc
 
+i = .i
 o = .o
 a = .a
 
@@ -371,7 +375,7 @@ a = .a
 # Options
 #
 
-INCLUDES       = -I$(COREDIR) -I.\include -I. -I..
+INCLUDES       = -I.\include -I. -I.. -I$(COREDIR)
 DEFINES                = -DWIN32 $(CRYPT_FLAG)
 LOCDEFS                = -DPERLDLL -DPERL_CORE
 SUBSYS         = console
@@ -387,18 +391,18 @@ LIBFILES  = $(CRYPT_LIB) $(LIBC) \
                  -lwinmm -lversion -lodbc32
 
 .IF  "$(CFG)" == "Debug"
-OPTIMIZE       = -g -DDEBUGGING
+OPTIMIZE       = -g -O2 -DDEBUGGING
 LINK_DBG       = -g
 .ELSE
 OPTIMIZE       = -g -O2
-LINK_DBG       = 
+LINK_DBG       = -g
 .ENDIF
 
 CFLAGS         = $(INCLUDES) $(DEFINES) $(LOCDEFS) $(OPTIMIZE)
 LINK_FLAGS     = $(LINK_DBG) -L"$(INST_COREDIR)" -L"$(CCLIBDIR)"
 OBJOUT_FLAG    = -o
 EXEOUT_FLAG    = -o
-LIBOUT_FLAG    = 
+LIBOUT_FLAG    =
 
 # NOTE: we assume that GCC uses MSVCRT.DLL
 BUILDOPT       += -fno-strict-aliasing -DPERL_MSVCRT_READFIX
@@ -415,7 +419,7 @@ RSC         = rc
 #
 
 INCLUDES       = -I$(COREDIR) -I.\include -I. -I..
-#PCHFLAGS      = -Fpc:\temp\vcmoduls.pch -YX 
+#PCHFLAGS      = -Fpc:\temp\vcmoduls.pch -YX
 DEFINES                = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG)
 LOCDEFS                = -DPERLDLL -DPERL_CORE
 SUBSYS         = console
@@ -433,10 +437,14 @@ PERLDLL_RES       =
 .IF  "$(CFG)" == "Debug"
 .IF "$(CCTYPE)" == "MSVC20"
 OPTIMIZE       = -Od -MD -Z7 -DDEBUGGING
+LINK_DBG       = -debug -pdb:none
 .ELSE
-OPTIMIZE       = -Od -MD -Zi -DDEBUGGING
+# -Zi requires .pdb file(s)
+#OPTIMIZE      = -Od -MD -Zi -DDEBUGGING
+#LINK_DBG      = -debug 
+OPTIMIZE       = -O1 -MD -Z7 -DDEBUGGING
+LINK_DBG       = -debug -debugtype:both -pdb:none
 .ENDIF
-LINK_DBG       = -debug -pdb:none
 .ELSE
 .IF "$(CFG)" == "Optimize"
 # -O1 yields smaller code, which turns out to be faster than -O2
@@ -496,13 +504,16 @@ LKPOST            = )
 
 #
 # Rules
-# 
+#
 
-.SUFFIXES : .c $(o) .dll $(a) .exe .rc .res
+.SUFFIXES : .c .i $(o) .dll $(a) .exe .rc .res
 
 .c$(o):
        $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) $(OBJOUT_FLAG)$@ $<
 
+.c.i:
+       $(CC) -c $(null,$(<:d) $(NULL) -I$(<:d)) $(CFLAGS_O) -E $< >$@ 
+
 .y.c:
        $(NOOP)
 
@@ -515,7 +526,7 @@ $(o).dll:
        $(IMPLIB) --input-def $(*B).def --output-lib $(*B).a $@
 .ELSE
        $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
-           -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL)  
+           -out:$@ $(BLINK_FLAGS) $(LIBFILES) $< $(LIBPERL)
 .ENDIF
 
 .rc.res:
@@ -532,6 +543,13 @@ CONFIGPM   = ..\lib\Config.pm
 MINIMOD                = ..\lib\ExtUtils\Miniperl.pm
 X2P            = ..\x2p\a2p.exe
 
+# Nominate a target which causes extensions to be re-built
+# This used to be $(PERLEXE), but at worst it is the .dll that they depend
+# on and really only the interface - i.e. the .def file used to export symbols
+# from the .dll
+PERLDEP = perldll.def
+
+
 PL2BAT         = bin\pl2bat.pl
 GLOBBAT                = bin\perlglob.bat
 
@@ -570,7 +588,7 @@ CFGH_TMPL   = config_H.bc
 
 CFGSH_TMPL     = config.gc
 CFGH_TMPL      = config_H.gc
-PERLIMPLIB     = ..\libperl56$(a)
+PERLIMPLIB     = ..\libperl57$(a)
 
 .ELSE
 
@@ -579,8 +597,11 @@ CFGH_TMPL  = config_H.vc
 
 .ENDIF
 
-PERLIMPLIB     *= ..\perl56$(a)
-PERLDLL                = ..\perl56.dll
+# makedef.pl must be updated if this changes, and this should normally
+# only change when there is an incompatible revision of the public API.
+# XXX so why did we change it from perl56 to perl57?
+PERLIMPLIB     *= ..\perl57$(a)
+PERLDLL                = ..\perl57.dll
 
 XCOPY          = xcopy /f /r /i /d
 RCOPY          = xcopy /f /r /i /e /d
@@ -635,7 +656,7 @@ EXTRACORE_SRC       += ..\perlio.c
 WIN32_SRC      =               \
                .\win32.c       \
                .\win32sck.c    \
-               .\win32thread.c 
+               .\win32thread.c
 
 .IF "$(CRYPT_SRC)" != ""
 WIN32_SRC      += .\$(CRYPT_SRC)
@@ -712,7 +733,7 @@ SETARGV_OBJ = setargv$(o)
 
 DYNAMIC_EXT    = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \
                Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob \
-               Sys/Hostname Storable
+               Sys/Hostname Storable Filter/Util/Call Encode
 STATIC_EXT     = DynaLoader
 NONXS_EXT      = Errno
 
@@ -735,6 +756,8 @@ DPROF               = $(EXTDIR)\Devel\DProf\DProf
 GLOB           = $(EXTDIR)\File\Glob\Glob
 HOSTNAME       = $(EXTDIR)\Sys\Hostname\Hostname
 STORABLE       = $(EXTDIR)\Storable\Storable
+FILTER         = $(EXTDIR)\Filter\Util\Call\Call
+ENCODE          = $(EXTDIR)\Encode\Encode
 
 SOCKET_DLL     = $(AUTODIR)\Socket\Socket.dll
 FCNTL_DLL      = $(AUTODIR)\Fcntl\Fcntl.dll
@@ -753,6 +776,8 @@ DPROF_DLL   = $(AUTODIR)\Devel\DProf\DProf.dll
 GLOB_DLL       = $(AUTODIR)\File\Glob\Glob.dll
 HOSTNAME_DLL   = $(AUTODIR)\Sys\Hostname\Hostname.dll
 STORABLE_DLL   = $(AUTODIR)\Storable\Storable.dll
+FILTER_DLL     = $(AUTODIR)\Filter\Util\Call\Call.dll
+ENCODE_DLL     = $(AUTODIR)\Encode\Encode.dll
 
 ERRNO_PM       = $(LIBDIR)\Errno.pm
 
@@ -773,7 +798,9 @@ EXTENSION_C =               \
                $(DPROF).c      \
                $(GLOB).c       \
                $(HOSTNAME).c   \
-               $(STORABLE).c
+               $(STORABLE).c   \
+               $(FILTER).c     \
+               $(ENCODE).c
 
 EXTENSION_DLL  =               \
                $(SOCKET_DLL)   \
@@ -792,7 +819,9 @@ EXTENSION_DLL       =               \
                $(DPROF_DLL)    \
                $(GLOB_DLL)     \
                $(HOSTNAME_DLL) \
-               $(STORABLE_DLL)
+               $(STORABLE_DLL) \
+               $(FILTER_DLL)   \
+               $(ENCODE_DLL)
 
 EXTENSION_PM   =               \
                $(ERRNO_PM)
@@ -813,6 +842,7 @@ CFG_VARS    =                                       \
                INST_ARCH=$(INST_ARCH)          ~       \
                archname=$(ARCHNAME)            ~       \
                cc=$(CC)                        ~       \
+               ld=$(LINK32)                    ~       \
                ccflags=$(OPTIMIZE) $(DEFINES) $(BUILDOPT)      ~       \
                cf_email=$(EMAIL)               ~       \
                d_crypt=$(D_CRYPT)              ~       \
@@ -845,7 +875,7 @@ RIGHTMAKE   = __switch_makefiles
 NOOP           = @rem
 .ELSE
 MK2            = __not_needed
-RIGHTMAKE      = __not_needed
+RIGHTMAKE      =
 .ENDIF
 
 #
@@ -901,7 +931,7 @@ __no_such_target:
 #--------------------- END Win95 SPECIFIC ---------------------
 
 # a blank target for when builds don't need to do certain things
-# this target added for Win95 port but used to keep the WinNT port able to 
+# this target added for Win95 port but used to keep the WinNT port able to
 # use this file
 __not_needed:
        $(NOOP)
@@ -915,7 +945,7 @@ $(GLOBEXE) : perlglob$(o)
        $(LINK32) $(BLINK_FLAGS) -mconsole -o $@ perlglob$(o) $(LIBFILES)
 .ELSE
        $(LINK32) $(BLINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \
-           perlglob$(o) setargv$(o) 
+           perlglob$(o) setargv$(o)
 .ENDIF
 
 perlglob$(o)  : perlglob.c
@@ -960,7 +990,7 @@ $(MINIPERL) : $(MINIDIR) $(MINI_OBJ) $(CRTIPMLIBS)
            @$(mktmp c0x32$(o) $(MINI_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),)
 .ELIF "$(CCTYPE)" == "GCC"
        $(LINK32) -v -mconsole -o $@ $(BLINK_FLAGS) \
-           $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) 
+           $(mktmp $(LKPRE) $(MINI_OBJ:s,\,\\) $(LIBFILES) $(LKPOST))
 .ELSE
        $(LINK32) -subsystem:console -out:$@ \
            @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(MINI_OBJ:s,\,\\))
@@ -1058,7 +1088,7 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ)
            @$(mktmp $(BLINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\))
 .ENDIF
 
-perlmain.c : runperl.c 
+perlmain.c : runperl.c
        copy runperl.c perlmain.c
 
 perlmain$(o) : perlmain.c
@@ -1079,7 +1109,7 @@ $(PERLEXE): $(PERLDLL) $(CONFIGPM) $(PERLEXE_OBJ) $(PERLEXE_RES)
 .ENDIF
        copy $(PERLEXE) $(WPERLEXE)
        $(MINIPERL) -I..\lib bin\exetype.pl $(WPERLEXE) WINDOWS
-       copy splittree.pl .. 
+       copy splittree.pl ..
        $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
 
 $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
@@ -1094,92 +1124,102 @@ $(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
 $(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
        copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
 
-$(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs
+$(DUMPER_DLL): $(PERLDEP) $(DUMPER).xs
        cd $(EXTDIR)\Data\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Data\$(*B) && $(MAKE)
 
-$(DPROF_DLL): $(PERLEXE) $(DPROF).xs
+$(DPROF_DLL): $(PERLDEP) $(DPROF).xs
        cd $(EXTDIR)\Devel\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Devel\$(*B) && $(MAKE)
 
-$(GLOB_DLL): $(PERLEXE) $(GLOB).xs
+$(GLOB_DLL): $(PERLDEP) $(GLOB).xs
        cd $(EXTDIR)\File\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\File\$(*B) && $(MAKE)
 
-$(PEEK_DLL): $(PERLEXE) $(PEEK).xs
+$(PEEK_DLL): $(PERLDEP) $(PEEK).xs
        cd $(EXTDIR)\Devel\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Devel\$(*B) && $(MAKE)
 
-$(RE_DLL): $(PERLEXE) $(RE).xs
+$(RE_DLL): $(PERLDEP) $(RE).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(B_DLL): $(PERLEXE) $(B).xs
+$(B_DLL): $(PERLDEP) $(B).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(THREAD_DLL): $(PERLEXE) $(THREAD).xs
+$(THREAD_DLL): $(PERLDEP) $(THREAD).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(ATTRS_DLL): $(PERLEXE) $(ATTRS).xs
+$(ATTRS_DLL): $(PERLDEP) $(ATTRS).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(POSIX_DLL): $(PERLEXE) $(POSIX).xs
+$(POSIX_DLL): $(PERLDEP) $(POSIX).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(IO_DLL): $(PERLEXE) $(IO).xs
+$(IO_DLL): $(PERLDEP) $(IO).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs
+$(SDBM_FILE_DLL) : $(PERLDEP) $(SDBM_FILE).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs
+$(FCNTL_DLL): $(PERLDEP) $(FCNTL).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs
+$(OPCODE_DLL): $(PERLDEP) $(OPCODE).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(SOCKET_DLL): $(PERLEXE) $(SOCKET).xs
+$(SOCKET_DLL): $(PERLDEP) $(SOCKET).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(HOSTNAME_DLL): $(PERLEXE) $(HOSTNAME).xs
+$(HOSTNAME_DLL): $(PERLDEP) $(HOSTNAME).xs
        cd $(EXTDIR)\Sys\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Sys\$(*B) && $(MAKE)
 
-$(BYTELOADER_DLL): $(PERLEXE) $(BYTELOADER).xs
+$(BYTELOADER_DLL): $(PERLDEP) $(BYTELOADER).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(STORABLE_DLL): $(PERLEXE) $(STORABLE).xs
+$(ENCODE_DLL): $(PERLDEP) $(ENCODE).xs
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
 
-$(ERRNO_PM): $(PERLEXE) $(ERRNO)_pm.PL
+$(STORABLE_DLL): $(PERLDEP) $(STORABLE).xs
+       cd $(EXTDIR)\$(*B) && \
+       ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+       cd $(EXTDIR)\$(*B) && $(MAKE)
+
+$(FILTER_DLL): $(PERLDEP) $(FILTER).xs
+       cd $(EXTDIR)\Filter\Util\Call && \
+       ..\..\..\..\miniperl -I..\..\..\..\lib Makefile.PL INSTALLDIRS=perl
+       cd $(EXTDIR)\Filter\Util\Call && $(MAKE)
+
+$(ERRNO_PM): $(PERLDEP) $(ERRNO)_pm.PL
        cd $(EXTDIR)\$(*B) && \
        ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\$(*B) && $(MAKE)
@@ -1220,10 +1260,13 @@ distclean: clean
        -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm
        -del /f $(LIBDIR)\File\Glob.pm
        -del /f $(LIBDIR)\Storable.pm
+       -del /f $(LIBDIR)\Filter\Util\Call\Call.pm
        -if exist $(LIBDIR)\IO rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO
        -if exist $(LIBDIR)\Thread rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread
        -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B
        -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data || rmdir /s $(LIBDIR)\Data
+       -if exist $(LIBDIR)\Filter\Util\Call rmdir /s /q $(LIBDIR)\Filter\Util\Call || rmdir /s $(LIBDIR)\Filter
+       -if exist $(LIBDIR)\Filter\Util rmdir /s /q $(LIBDIR)\Filter\Util || rmdir /s $(LIBDIR)\Filter
        -del /f $(PODDIR)\*.html
        -del /f $(PODDIR)\*.bat
        -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph h2xs perldoc \
@@ -1249,7 +1292,7 @@ installhtml : doc
        $(RCOPY) html\*.* $(INST_HTML)\*.*
 
 inst_lib : $(CONFIGPM)
-       copy splittree.pl .. 
+       copy splittree.pl ..
        $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" $(AUTODIR)
        $(RCOPY) ..\lib $(INST_LIB)\*.*
 
@@ -1290,7 +1333,7 @@ test-wide-notty : test-prep
            set HARNESS_PERL_SWITCHES=-C && \
            cd ..\t && $(PERLEXE) -I..\lib harness
 
-clean : 
+clean :
        -@erase miniperlmain$(o)
        -@erase $(MINIPERL)
        -@erase perlglob$(o)
@@ -1321,9 +1364,9 @@ ok: utils
 
 okfile: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -ok -s "(UNINSTALLED)" -F perl.ok
+
 nok: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)"
+
 nokfile: utils
        $(PERLEXE) -I..\lib ..\utils\perlbug -nok -s "(UNINSTALLED)" -F perl.nok
index 7807495..a260d08 100644 (file)
@@ -35,6 +35,7 @@ extern int            g_do_aspawn(void *vreally, void **vmark, void **vsp);
 class CPerlHost
 {
 public:
+    /* Constructors */
     CPerlHost(void);
     CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
                 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
@@ -197,8 +198,13 @@ protected:
 
     DWORD   m_dwEnvCount;
     LPSTR*  m_lppEnvList;
+    static long num_hosts;
+public:
+    inline  int LastHost(void) { return num_hosts == 1L; };
 };
 
+long CPerlHost::num_hosts = 0L;
+
 
 #define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
 
@@ -522,65 +528,65 @@ struct IPerlEnv perlEnv =
 #define IPERL2HOST(x) IPerlStdIO2Host(x)
 
 /* PerlStdIO */
-PerlIO*
+FILE*
 PerlStdIOStdin(struct IPerlStdIO* piPerl)
 {
-    return (PerlIO*)win32_stdin();
+    return win32_stdin();
 }
 
-PerlIO*
+FILE*
 PerlStdIOStdout(struct IPerlStdIO* piPerl)
 {
-    return (PerlIO*)win32_stdout();
+    return win32_stdout();
 }
 
-PerlIO*
+FILE*
 PerlStdIOStderr(struct IPerlStdIO* piPerl)
 {
-    return (PerlIO*)win32_stderr();
+    return win32_stderr();
 }
 
-PerlIO*
+FILE*
 PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
 {
-    return (PerlIO*)win32_fopen(path, mode);
+    return win32_fopen(path, mode);
 }
 
 int
-PerlStdIOClose(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_fclose(((FILE*)pf));
+    return win32_fclose((pf));
 }
 
 int
-PerlStdIOEof(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_feof((FILE*)pf);
+    return win32_feof(pf);
 }
 
 int
-PerlStdIOError(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_ferror((FILE*)pf);
+    return win32_ferror(pf);
 }
 
 void
-PerlStdIOClearerr(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    win32_clearerr((FILE*)pf);
+    win32_clearerr(pf);
 }
 
 int
-PerlStdIOGetc(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_getc((FILE*)pf);
+    return win32_getc(pf);
 }
 
 char*
-PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef FILE_base
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     return FILE_base(f);
 #else
     return Nullch;
@@ -588,10 +594,10 @@ PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf)
 }
 
 int
-PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef FILE_bufsiz
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     return FILE_bufsiz(f);
 #else
     return (-1);
@@ -599,10 +605,10 @@ PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf)
 }
 
 int
-PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef USE_STDIO_PTR
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     return FILE_cnt(f);
 #else
     return (-1);
@@ -610,10 +616,10 @@ PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf)
 }
 
 char*
-PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef USE_STDIO_PTR
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     return FILE_ptr(f);
 #else
     return Nullch;
@@ -621,150 +627,149 @@ PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf)
 }
 
 char*
-PerlStdIOGets(struct IPerlStdIO* piPerl, PerlIO* pf, char* s, int n)
+PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
 {
-    return win32_fgets(s, n, (FILE*)pf);
+    return win32_fgets(s, n, pf);
 }
 
 int
-PerlStdIOPutc(struct IPerlStdIO* piPerl, PerlIO* pf, int c)
+PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
 {
-    return win32_fputc(c, (FILE*)pf);
+    return win32_fputc(c, pf);
 }
 
 int
-PerlStdIOPuts(struct IPerlStdIO* piPerl, PerlIO* pf, const char *s)
+PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
 {
-    return win32_fputs(s, (FILE*)pf);
+    return win32_fputs(s, pf);
 }
 
 int
-PerlStdIOFlush(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_fflush((FILE*)pf);
+    return win32_fflush(pf);
 }
 
 int
-PerlStdIOUngetc(struct IPerlStdIO* piPerl, PerlIO* pf,int c)
+PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf)
 {
-    return win32_ungetc(c, (FILE*)pf);
+    return win32_ungetc(c, pf);
 }
 
 int
-PerlStdIOFileno(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_fileno((FILE*)pf);
+    return win32_fileno(pf);
 }
 
-PerlIO*
+FILE*
 PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
 {
-    return (PerlIO*)win32_fdopen(fd, mode);
+    return win32_fdopen(fd, mode);
 }
 
-PerlIO*
-PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, PerlIO* pf)
+FILE*
+PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
 {
-    return (PerlIO*)win32_freopen(path, mode, (FILE*)pf);
+    return win32_freopen(path, mode, (FILE*)pf);
 }
 
 SSize_t
-PerlStdIORead(struct IPerlStdIO* piPerl, PerlIO* pf, void *buffer, Size_t size)
+PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
 {
-    return win32_fread(buffer, 1, size, (FILE*)pf);
+    return win32_fread(buffer, size, count, pf);
 }
 
 SSize_t
-PerlStdIOWrite(struct IPerlStdIO* piPerl, PerlIO* pf, const void *buffer, Size_t size)
+PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
 {
-    return win32_fwrite(buffer, 1, size, (FILE*)pf);
+    return win32_fwrite(buffer, size, count, pf);
 }
 
 void
-PerlStdIOSetBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer)
+PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
 {
-    win32_setbuf((FILE*)pf, buffer);
+    win32_setbuf(pf, buffer);
 }
 
 int
-PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer, int type, Size_t size)
+PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
 {
-    return win32_setvbuf((FILE*)pf, buffer, type, size);
+    return win32_setvbuf(pf, buffer, type, size);
 }
 
 void
-PerlStdIOSetCnt(struct IPerlStdIO* piPerl, PerlIO* pf, int n)
+PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
 {
 #ifdef STDIO_CNT_LVALUE
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     FILE_cnt(f) = n;
 #endif
 }
 
 void
-PerlStdIOSetPtrCnt(struct IPerlStdIO* piPerl, PerlIO* pf, char * ptr, int n)
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
 {
 #ifdef STDIO_PTR_LVALUE
-    FILE *f = (FILE*)pf;
+    FILE *f = pf;
     FILE_ptr(f) = ptr;
-    FILE_cnt(f) = n;
 #endif
 }
 
 void
-PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0);
+    win32_setvbuf(pf, NULL, _IOLBF, 0);
 }
 
 int
-PerlStdIOPrintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format,...)
+PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
 {
     va_list(arglist);
     va_start(arglist, format);
-    return win32_vfprintf((FILE*)pf, format, arglist);
+    return win32_vfprintf(pf, format, arglist);
 }
 
 int
-PerlStdIOVprintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format, va_list arglist)
+PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
 {
-    return win32_vfprintf((FILE*)pf, format, arglist);
+    return win32_vfprintf(pf, format, arglist);
 }
 
 long
-PerlStdIOTell(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    return win32_ftell((FILE*)pf);
+    return win32_ftell(pf);
 }
 
 int
-PerlStdIOSeek(struct IPerlStdIO* piPerl, PerlIO* pf, off_t offset, int origin)
+PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, off_t offset, int origin)
 {
-    return win32_fseek((FILE*)pf, offset, origin);
+    return win32_fseek(pf, offset, origin);
 }
 
 void
-PerlStdIORewind(struct IPerlStdIO* piPerl, PerlIO* pf)
+PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    win32_rewind((FILE*)pf);
+    win32_rewind(pf);
 }
 
-PerlIO*
+FILE*
 PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
 {
-    return (PerlIO*)win32_tmpfile();
+    return win32_tmpfile();
 }
 
 int
-PerlStdIOGetpos(struct IPerlStdIO* piPerl, PerlIO* pf, Fpos_t *p)
+PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
 {
-    return win32_fgetpos((FILE*)pf, p);
+    return win32_fgetpos(pf, p);
 }
 
 int
-PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p)
+PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
 {
-    return win32_fsetpos((FILE*)pf, p);
+    return win32_fsetpos(pf, p);
 }
 void
 PerlStdIOInit(struct IPerlStdIO* piPerl)
@@ -789,39 +794,39 @@ PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
     return win32_get_osfhandle(filenum);
 }
 
-PerlIO*
-PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf)
+FILE*
+PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
 {
-    PerlIO* pfdup;
+    FILE* pfdup;
     fpos_t pos;
     char mode[3];
-    int fileno = win32_dup(win32_fileno((FILE*)pf));
+    int fileno = win32_dup(win32_fileno(pf));
 
     /* open the file in the same mode */
 #ifdef __BORLANDC__
-    if(((FILE*)pf)->flags & _F_READ) {
+    if((pf)->flags & _F_READ) {
        mode[0] = 'r';
        mode[1] = 0;
     }
-    else if(((FILE*)pf)->flags & _F_WRIT) {
+    else if((pf)->flags & _F_WRIT) {
        mode[0] = 'a';
        mode[1] = 0;
     }
-    else if(((FILE*)pf)->flags & _F_RDWR) {
+    else if((pf)->flags & _F_RDWR) {
        mode[0] = 'r';
        mode[1] = '+';
        mode[2] = 0;
     }
 #else
-    if(((FILE*)pf)->_flag & _IOREAD) {
+    if((pf)->_flag & _IOREAD) {
        mode[0] = 'r';
        mode[1] = 0;
     }
-    else if(((FILE*)pf)->_flag & _IOWRT) {
+    else if((pf)->_flag & _IOWRT) {
        mode[0] = 'a';
        mode[1] = 0;
     }
-    else if(((FILE*)pf)->_flag & _IORW) {
+    else if((pf)->_flag & _IORW) {
        mode[0] = 'r';
        mode[1] = '+';
        mode[2] = 0;
@@ -832,11 +837,11 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf)
      * file descriptor so binmode files will be handled
      * correctly
      */
-    pfdup = (PerlIO*)win32_fdopen(fileno, mode);
+    pfdup = win32_fdopen(fileno, mode);
 
     /* move the file pointer to the same position */
-    if (!fgetpos((FILE*)pf, &pos)) {
-       fsetpos((FILE*)pfdup, &pos);
+    if (!fgetpos(pf, &pos)) {
+       fsetpos(pfdup, &pos);
     }
     return pfdup;
 }
@@ -869,7 +874,7 @@ struct IPerlStdIO perlStdIO =
     PerlStdIOSetBuf,
     PerlStdIOSetVBuf,
     PerlStdIOSetCnt,
-    PerlStdIOSetPtrCnt,
+    PerlStdIOSetPtr,
     PerlStdIOSetlinebuf,
     PerlStdIOPrintf,
     PerlStdIOVprintf,
@@ -1586,13 +1591,13 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
 {
     dTHXo;
     PERL_FLUSHALL_FOR_CHILD;
-    return (PerlIO*)win32_popen(command, mode);
+    return win32_popen(command, mode);
 }
 
 int
 PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
 {
-    return win32_pclose((FILE*)stream);
+    return win32_pclose(stream);
 }
 
 int
@@ -1845,6 +1850,14 @@ PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp
     return do_aspawn(vreally, vmark, vsp);
 }
 
+int
+PerlProcLastHost(struct IPerlProc* piPerl)
+{
+ dTHXo;
+ CPerlHost *h = (CPerlHost*)w32_internal_host;
+ return h->LastHost();
+}
+
 struct IPerlProc perlProc =
 {
     PerlProcAbort,
@@ -1880,6 +1893,7 @@ struct IPerlProc perlProc =
     PerlProcSpawn,
     PerlProcSpawnvp,
     PerlProcASpawn,
+    PerlProcLastHost
 };
 
 
@@ -1889,6 +1903,8 @@ struct IPerlProc perlProc =
 
 CPerlHost::CPerlHost(void)
 {
+    /* Construct a host from scratch */
+    InterlockedIncrement(&num_hosts);
     m_pvDir = new VDir();
     m_pVMem = new VMem();
     m_pVMemShared = new VMem();
@@ -1937,6 +1953,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
                 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
                 struct IPerlProc** ppProc)
 {
+    InterlockedIncrement(&num_hosts);
     m_pvDir = new VDir(0);
     m_pVMem = new VMem();
     m_pVMemShared = new VMem();
@@ -1971,6 +1988,8 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 
 CPerlHost::CPerlHost(CPerlHost& host)
 {
+    /* Construct a host from another host */
+    InterlockedIncrement(&num_hosts);
     m_pVMem = new VMem();
     m_pVMemShared = host.GetMemShared();
     m_pVMemParse =  host.GetMemParse();
@@ -2011,6 +2030,7 @@ CPerlHost::CPerlHost(CPerlHost& host)
 CPerlHost::~CPerlHost(void)
 {
 //  Reset();
+    InterlockedDecrement(&num_hosts);
     delete m_pvDir;
     m_pVMemParse->Release();
     m_pVMemShared->Release();
index e2b245d..87b79c0 100644 (file)
@@ -1,8 +1,7 @@
 /*
  * "The Road goes ever on and on, down from the door where it began."
  */
-
-
+#define PERLIO_NOT_STDIO 0
 #include "EXTERN.h"
 #include "perl.h"
 
@@ -371,6 +370,12 @@ DllMain(HANDLE hModule,            /* DLL module handle */
         * process termination or call to FreeLibrary.
         */
     case DLL_PROCESS_DETACH:
+        /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill()
+           anything here had better be harmless if:
+            A. Not called at all.
+            B. Called after memory allocation for Heap has been forcibly removed by OS.
+            PerlIO_cleanup() was done here but fails (B).
+         */     
        EndSockets();
 #if defined(USE_THREADS) || defined(USE_ITHREADS)
        if (PL_curinterp)
index 37cb4a5..af769f1 100644 (file)
@@ -393,7 +393,7 @@ char *VDir::MapPathA(const char *pInName)
        /* has drive letter */
        if (IsPathSep(pInName[2])) {
            /* absolute with drive letter */
-           strcpy(szLocalBufferA, pInName);
+           DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
        }
        else {
            /* relative path with drive letter */
@@ -409,15 +409,14 @@ char *VDir::MapPathA(const char *pInName)
        /* no drive letter */
        if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
            /* UNC name */
-           strcpy(szLocalBufferA, pInName);
+           DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
        }
        else {
            strcpy(szBuffer, GetDefaultDirA());
            if (IsPathSep(pInName[0])) {
                /* absolute path */
-               szLocalBufferA[0] = szBuffer[0];
-               szLocalBufferA[1] = szBuffer[1];
-               strcpy(&szLocalBufferA[2], pInName);
+               strcpy(&szBuffer[2], pInName);
+               DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
            }
            else {
                /* relative path */
@@ -620,7 +619,7 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
        /* has drive letter */
        if (IsPathSep(pInName[2])) {
            /* absolute with drive letter */
-           wcscpy(szLocalBufferW, pInName);
+           DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
        }
        else {
            /* relative path with drive letter */
@@ -636,15 +635,14 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName)
        /* no drive letter */
        if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
            /* UNC name */
-           wcscpy(szLocalBufferW, pInName);
+           DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
        }
        else {
            wcscpy(szBuffer, GetDefaultDirW());
            if (IsPathSep(pInName[0])) {
                /* absolute path */
-               szLocalBufferW[0] = szBuffer[0];
-               szLocalBufferW[1] = szBuffer[1];
-               wcscpy(&szLocalBufferW[2], pInName);
+               wcscpy(&szBuffer[2], pInName);
+               DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
            }
            else {
                /* relative path */
index 2b31878..ba445a4 100644 (file)
@@ -581,7 +581,6 @@ do_aspawn(void *vreally, void **vmark, void **vsp)
     }
     else {
        if (status < 0) {
-           dTHR;
            if (ckWARN(WARN_EXEC))
                Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
            status = 255 * 256;
@@ -674,7 +673,6 @@ do_spawn2(char *cmd, int exectype)
     }
     else {
        if (status < 0) {
-           dTHR;
            if (ckWARN(WARN_EXEC))
                Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
                     (exectype == EXECF_EXEC ? "exec" : "spawn"),
@@ -977,6 +975,31 @@ chown(const char *path, uid_t owner, gid_t group)
     return 0;
 }
 
+/*
+ * XXX this needs strengthening  (for PerlIO)
+ *   -- BKS, 11-11-200
+*/
+int mkstemp(const char *path)
+{
+    dTHX;
+    char buf[MAX_PATH+1];
+    int i = 0, fd = -1;
+
+retry:
+    if (i++ > 10) { /* give up */
+       errno = ENOENT;
+       return -1;
+    }
+    if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
+       errno = ENOENT;
+       return -1;
+    }
+    fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
+    if (fd == -1)
+       goto retry;
+    return fd;
+}
+
 static long
 find_pid(int pid)
 {
@@ -1850,7 +1873,6 @@ win32_crypt(const char *txt, const char *salt)
 {
     dTHXo;
 #ifdef HAVE_DES_FCRYPT
-    dTHR;
     return des_fcrypt(txt, salt, w32_crypt_buffer);
 #else
     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
@@ -2106,7 +2128,6 @@ win32_str_os_error(void *sv, DWORD dwErr)
     }
 }
 
-
 DllExport int
 win32_fprintf(FILE *fp, const char *format, ...)
 {
@@ -2329,7 +2350,7 @@ win32_fstat(int fd,struct stat *sbufptr)
     }
     return rc;
 #else
-    return fstat(fd,sbufptr);
+    return my_fstat(fd,sbufptr);
 #endif
 }
 
@@ -2341,9 +2362,11 @@ win32_pipe(int *pfd, unsigned int size, int mode)
 
 /*
  * a popen() clone that respects PERL5SHELL
+ *
+ * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
  */
 
-DllExport FILE*
+DllExport PerlIO*
 win32_popen(const char *command, const char *mode)
 {
 #ifdef USE_RTL_POPEN
@@ -2417,7 +2440,7 @@ win32_popen(const char *command, const char *mode)
     }
 
     /* we have an fd, return a file stream */
-    return (win32_fdopen(p[parent], (char *)mode));
+    return (PerlIO_fdopen(p[parent], (char *)mode));
 
 cleanup:
     /* we don't need to check for errors here */
@@ -2437,7 +2460,7 @@ cleanup:
  */
 
 DllExport int
-win32_pclose(FILE *pf)
+win32_pclose(PerlIO *pf)
 {
 #ifdef USE_RTL_POPEN
     return _pclose(pf);
@@ -2447,7 +2470,7 @@ win32_pclose(FILE *pf)
     SV *sv;
 
     LOCK_FDPID_MUTEX;
-    sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE);
+    sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
 
     if (SvIOK(sv))
        childpid = SvIVX(sv);
@@ -2459,7 +2482,11 @@ win32_pclose(FILE *pf)
         return -1;
     }
 
-    win32_fclose(pf);
+#ifdef USE_PERLIO
+    PerlIO_close(pf);
+#else
+    fclose(pf);
+#endif
     SvIVX(sv) = 0;
     UNLOCK_FDPID_MUTEX;
 
@@ -2721,10 +2748,13 @@ win32_open(const char *path, int flag, ...)
     return open(PerlDir_mapA(path), flag, pmode);
 }
 
+/* close() that understands socket */
+extern int my_close(int);      /* in win32sck.c */
+
 DllExport int
 win32_close(int fd)
 {
-    return close(fd);
+    return my_close(fd);
 }
 
 DllExport int
@@ -3838,6 +3868,8 @@ XS(w32_Spawn)
 {
     dXSARGS;
     char *cmd, *args;
+    void *env;
+    char *dir;
     PROCESS_INFORMATION stProcInfo;
     STARTUPINFO stStartInfo;
     BOOL bSuccess = FALSE;
@@ -3848,6 +3880,9 @@ XS(w32_Spawn)
     cmd = SvPV_nolen(ST(0));
     args = SvPV_nolen(ST(1));
 
+    env = PerlEnv_get_childenv();
+    dir = PerlEnv_get_childdir();
+
     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
     stStartInfo.cb = sizeof(stStartInfo);          /* Set the structure size */
     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;            /* Enable wShowWindow control */
@@ -3860,8 +3895,8 @@ XS(w32_Spawn)
                NULL,                   /* Default thread security */
                FALSE,                  /* Must be TRUE to use std handles */
                NORMAL_PRIORITY_CLASS,  /* No special scheduling */
-               NULL,                   /* Inherit our environment block */
-               NULL,                   /* Inherit our currrent directory */
+               env,                    /* Inherit our environment block */
+               dir,                    /* Inherit our currrent directory */
                &stStartInfo,           /* -> Startup info */
                &stProcInfo))           /* <- Process info (if OK) */
     {
@@ -3872,6 +3907,8 @@ XS(w32_Spawn)
        CloseHandle(stProcInfo.hThread);/* library source code does this. */
        bSuccess = TRUE;
     }
+    PerlEnv_free_childenv(env);
+    PerlEnv_free_childdir(dir);
     XSRETURN_IV(bSuccess);
 }
 
index d9ffbfe..1040ef1 100644 (file)
@@ -302,6 +302,7 @@ extern  int kill(int pid, int sig);
 extern  void   *sbrk(int need);
 extern char *  getlogin(void);
 extern int     chown(const char *p, uid_t o, gid_t g);
+extern  int    mkstemp(const char *path);
 
 #undef  Stat
 #define  Stat          win32_stat
@@ -343,6 +344,7 @@ DllExport void              win32_get_child_IO(child_IO_table* ptr);
 extern FILE *          my_fdopen(int, char *);
 #endif
 extern int             my_fclose(FILE *);
+extern int             my_fstat(int fd, struct stat *sbufptr);
 extern int             do_aspawn(void *really, void **mark, void **sp);
 extern int             do_spawn(char *cmd);
 extern int             do_spawn_nowait(char *cmd);
@@ -543,11 +545,17 @@ EXTERN_C _CRTIMP ioinfo* __pioinfo[];
 #endif
 #endif
 
+#define PERLIO_NOT_STDIO 0
+
+#include "perlio.h"
+
 /*
  * This provides a layer of functions and macros to ensure extensions will
  * get to use the same RTL functions as the core.
  */
 #include "win32iop.h"
 
+#define EXEC_ARGV_CAST(x) ((const char *const *) x)
+
 #endif /* _INC_WIN32_PERL5 */
 
index d7c2ac4..5629bab 100644 (file)
@@ -72,8 +72,8 @@ DllExport  void               win32_abort(void);
 DllExport  int         win32_fstat(int fd,struct stat *sbufptr);
 DllExport  int         win32_stat(const char *name,struct stat *sbufptr);
 DllExport  int         win32_pipe( int *phandles, unsigned int psize, int textmode );
-DllExport  FILE*       win32_popen( const char *command, const char *mode );
-DllExport  int         win32_pclose( FILE *pf);
+DllExport  PerlIO*     win32_popen( const char *command, const char *mode );
+DllExport  int         win32_pclose( PerlIO *pf);
 DllExport  int         win32_rename( const char *oname, const char *newname);
 DllExport  int         win32_setmode( int fd, int mode);
 DllExport  long                win32_lseek( int fd, long offset, int origin);
index 3b81d8b..d169db6 100644 (file)
@@ -11,6 +11,7 @@
 #define WIN32IO_IS_STDIO
 #define WIN32SCK_IS_STDSCK
 #define WIN32_LEAN_AND_MEAN
+#define PERLIO_NOT_STDIO 0
 #ifdef __GNUC__
 #define Win32_Winsock
 #endif
@@ -418,6 +419,41 @@ win32_socket(int af, int type, int protocol)
     return s;
 }
 
+/*
+ * close RTL fd while respecting sockets
+ * added as temporary measure until PerlIO has real
+ * Win32 native layer
+ *   -- BKS, 11-11-2000
+*/
+
+int my_close(int fd)
+{
+    int osf;
+    if (!wsock_started)                /* No WinSock? */
+       return(close(fd));      /* Then not a socket. */
+    osf = TO_SOCKET(fd);/* Get it now before it's gone! */
+    if (osf != -1) {
+       int err;
+       err = closesocket(osf);
+       if (err == 0) {
+#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX)
+            _set_osfhnd(fd, INVALID_HANDLE_VALUE);
+#endif
+           (void)close(fd);    /* handle already closed, ignore error */
+           return 0;
+       }
+       else if (err == SOCKET_ERROR) {
+           err = WSAGetLastError();
+           if (err != WSAENOTSOCK) {
+               (void)close(fd);
+               errno = err;
+               return EOF;
+           }
+       }
+    }
+    return close(fd);
+}
+
 #undef fclose
 int
 my_fclose (FILE *pf)
@@ -425,14 +461,14 @@ my_fclose (FILE *pf)
     int osf;
     if (!wsock_started)                /* No WinSock? */
        return(fclose(pf));     /* Then not a socket. */
-    osf = TO_SOCKET(fileno(pf));/* Get it now before it's gone! */
+    osf = TO_SOCKET(win32_fileno(pf));/* Get it now before it's gone! */
     if (osf != -1) {
        int err;
        win32_fflush(pf);
        err = closesocket(osf);
        if (err == 0) {
 #if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX)
-            _set_osfhnd(fileno(pf), INVALID_HANDLE_VALUE);
+            _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE);
 #endif
            (void)fclose(pf);   /* handle already closed, ignore error */
            return 0;
@@ -449,6 +485,41 @@ my_fclose (FILE *pf)
     return fclose(pf);
 }
 
+#undef fstat
+int
+my_fstat(int fd, struct stat *sbufptr)
+{
+    /* This fixes a bug in fstat() on Windows 9x.  fstat() uses the
+     * GetFileType() win32 syscall, which will fail on Windows 9x.
+     * So if we recognize a socket on Windows 9x, we return the
+     * same results as on Windows NT/2000.
+     * XXX this should be extended further to set S_IFSOCK on
+     * sbufptr->st_mode.
+     */
+    int osf;
+    if (!wsock_started || IsWinNT())
+       return fstat(fd, sbufptr);
+
+    osf = TO_SOCKET(fd);
+    if (osf != -1) {
+       char sockbuf[256];
+       int optlen = sizeof(sockbuf);
+       int retval;
+
+       retval = getsockopt((SOCKET)osf, SOL_SOCKET, SO_TYPE, sockbuf, &optlen);
+       if (retval != SOCKET_ERROR || WSAGetLastError() != WSAENOTSOCK) {
+           sbufptr->st_mode = _S_IFIFO;
+           sbufptr->st_rdev = sbufptr->st_dev = (dev_t)fd;
+           sbufptr->st_nlink = 1;
+           sbufptr->st_uid = sbufptr->st_gid = sbufptr->st_ino = 0;
+           sbufptr->st_atime = sbufptr->st_mtime = sbufptr->st_ctime = 0;
+           sbufptr->st_size = (off_t)0;
+           return 0;
+       }
+    }
+    return fstat(fd, sbufptr);
+}
+
 struct hostent *
 win32_gethostbyaddr(const char *addr, int len, int type)
 {
index a52118b..1f8840c 100644 (file)
@@ -170,7 +170,7 @@ END_EXTERN_C
 #define ALLOC_THREAD_KEY \
     STMT_START {                                                       \
        if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) {          \
-           fprintf(stderr,"panic: TlsAlloc");                          \
+           PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc");                           \
            exit(1);                                                    \
        }                                                               \
     } STMT_END
index cd1a411..80fffb4 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:05 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index ac1d57a..2303ea3 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:06 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index b512cf9..cd667a3 100644 (file)
--- a/x2p/a2p.c
+++ b/x2p/a2p.c
@@ -5,7 +5,7 @@ static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
 #line 2 "a2p.y"
 /* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 51a69dd..cbcb80c 100644 (file)
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
@@ -1,6 +1,6 @@
 /* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index da9b628..beec3a6 100644 (file)
--- a/x2p/a2p.y
+++ b/x2p/a2p.y
@@ -1,7 +1,7 @@
 %{
 /* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 25d0135..4d74d06 100644 (file)
@@ -37,6 +37,7 @@ my \$perlpath = "$Config{perlpath}";
 print OUT <<'!NO!SUBS!';
 use strict;
 use vars qw/$statdone/;
+use File::Spec::Functions 'curdir';
 my $startperl = "#! $perlpath -w";
 
 #
@@ -57,7 +58,7 @@ my @roots = ();
 while ($ARGV[0] =~ /^[^-!(]/) {
     push(@roots, shift);
 }
-@roots = ('.') unless @roots;
+@roots = (curdir()) unless @roots;
 for (@roots) { $_ = &quote($_) }
 my $roots = join(', ', @roots);
 
@@ -674,6 +675,7 @@ sub n {
 
 sub quote {
     my $string = shift;
+    $string =~ s/\\/\\\\/g;
     $string =~ s/'/\\'/g;
     "'$string'";
 }
index 77b9ad8..a266403 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:20 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 377bfd2..7b2b668 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:21 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 85d7496..e57b4fc 100644 (file)
@@ -1,6 +1,6 @@
 /*    proto.h
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index b820a8d..310bcd6 100644 (file)
--- a/x2p/str.c
+++ b/x2p/str.c
@@ -1,6 +1,6 @@
 /* $RCSfile: str.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:26 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index a7eec88..311c5e6 100644 (file)
--- a/x2p/str.h
+++ b/x2p/str.h
@@ -1,6 +1,6 @@
 /* $RCSfile: str.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:27 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index d43a1eb..ab24808 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:29 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 34138c7..c5ebcec 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:30 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
index 3344688..59ac8a9 100644 (file)
@@ -1,6 +1,6 @@
 /* $RCSfile: walk.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:31 $
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.