This commit was generated by cvs2svn to compensate for changes in r62076,

which included commits to RCS files with non-trunk default branches.

contrib/perl5/AUTHORS

@@ -0,0 +1,120 @@
+# 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@slipper.ip.lu
+doug		Doug MacEachern		dougm@pobox.com
+doughera	Andy Dougherty		doughera@lafcol.lafayette.edu
+gbarr		Graham Barr		gbarr@ti.com
+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
+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@media.mit.edu
+jvromans	Johan Vromans		jvromans@squirrel.nl
+k		Andreas Koenig		andreas.koenig@franz.ww.tu-berlin.de
+kjahds		Kenneth Albanowski	kjahds@kjahds.com
+krishna		Krishna Sethuraman	krishna@sgi.com
+kstar		Kurt D. Starsinic	kstar@isinet.com
+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
+mike		Mike Stok		mike@stok.co.uk
+millert		Todd Miller		millert@openbsd.org
+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
+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
+spider		Spider Boardman		spider@Orb.Nashua.NH.US
+smccam		Stephen McCamant	smccam@uclink4.berkeley.edu
+sugalskd	Dan Sugalski		sugalskd@osshe.edu
+sundstrom	David Sundstrom		sunds@asictest.sc.ti.com
+tchrist		Tom Christiansen	tchrist@perl.com
+thomas.dorner	Dorner Thomas		Thomas.Dorner@start.de
+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
+
+PUMPKING	gsar
+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		vms,vmesa,posixbc
+filespec	kjahds
+freebsd		roberto
+hpux		okamoto,jhi
+irix		scotth,krishna,jfs,kstar
+jpl		gibreel
+linux		kjahds,kstar
+locale		jhi,domo
+lynxos		lynxos
+machten		domo
+mm		makemaker
+mvs		pvhp
+netbsd		jhi
+openbsd		millert
+os2		ilya
+plan9		lutherl
+posix-bc	thomas.dorner
+powerux		tom.horsley
+qnx		allen
+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

contrib/perl5/EXTERN.h

@@ -1,6 +1,6 @@
 /*    EXTERN.h
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -27,7 +27,7 @@
 #  define EXTCONST globalref
 #  define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
 #else
-#  if defined(WIN32) && !defined(PERL_STATIC_SYMS) && !defined(__GNUC__) && !defined(PERL_OBJECT)
+#  if defined(WIN32) && !defined(PERL_STATIC_SYMS) && !defined(PERL_OBJECT)
 #    ifdef PERLDLL
 #      define EXT extern __declspec(dllexport)
 #      define dEXT 
@@ -40,10 +40,17 @@
 #      define dEXTCONST const
 #    endif
 #  else
-#    define EXT extern
-#    define dEXT
-#    define EXTCONST extern const
-#    define dEXTCONST const
+#    if defined(__CYGWIN__) && defined(USEIMPORTLIB)
+#      define EXT extern __declspec(dllimport)
+#      define dEXT 
+#      define EXTCONST extern __declspec(dllimport) const
+#      define dEXTCONST const
+#    else
+#      define EXT extern
+#      define dEXT
+#      define EXTCONST extern const
+#      define dEXTCONST const
+#    endif
 #  endif
 #endif
 

contrib/perl5/INTERN.h

@@ -1,6 +1,6 @@
 /*    INTERN.h
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -27,11 +27,17 @@
 #  define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
 #  define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
 #else
-#  ifdef __cplusplus
-#   define EXT
-#   define dEXT
-#   define EXTCONST extern const
-#   define dEXTCONST const
+#if defined(WIN32) && defined(__MINGW32__)
+#  define EXT		__declspec(dllexport)
+#  define dEXT
+#  define EXTCONST	__declspec(dllexport) const
+#  define dEXTCONST	const
+#else
+#ifdef __cplusplus
+#  define EXT
+#  define dEXT
+#  define EXTCONST extern const
+#  define dEXTCONST const
 #else
 #  define EXT
 #  define dEXT
@@ -39,6 +45,7 @@
 #  define dEXTCONST const
 #endif
 #endif
+#endif
 
 #undef INIT
 #define INIT(x) = x

contrib/perl5/MAINTAIN

@@ -0,0 +1,879 @@
+# 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	
+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.mpeix			mpeix
+README.os2			os2
+README.os390			mvs
+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	
+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			cygwinx
+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			lynxos
+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			mvs
+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/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/Parser.pm		bradapp
+lib/Pod/PlainText.pm		bradapp
+lib/Pod/Select.pm		bradapp
+lib/Pod/Text.pm			tchrist
+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/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		stok
+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/perldiag.pod	
+pod/perldsc.pod			tchrist
+pod/perlembed.pod		doug,jon
+pod/perlfaq*			gnat
+pod/perlform.pod	
+pod/perlfunc.pod	
+pod/perlguts.pod	
+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	
+pod/perlobj.pod	
+pod/perlop.pod	
+pod/perlpod.pod			lwall
+pod/perlport.pod		pudge
+pod/perlre.pod			regex
+pod/perlref.pod	
+pod/perlreftut.pod		mjd
+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/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/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/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	
+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	

contrib/perl5/Makefile.SH

@@ -1,5 +1,5 @@
 #! /bin/sh
-case $CONFIG in
+case $CONFIGDOTSH in
 '')
 	if test -f config.sh; then TOP=.;
 	elif test -f ../config.sh; then TOP=..;
@@ -29,48 +29,69 @@ ldlibpth=''
 case "$useshrplib" in
 true)
 	# Prefix all runs of 'miniperl' and 'perl' with 
-	# $ldlibpth so that ./perl finds *this* libperl.so.
-	ldlibpth="LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH"
+	# $ldlibpth so that ./perl finds *this* shared libperl.
+	case "$LD_LIBRARY_PATH" in
+	'')
+		ldlibpth="LD_LIBRARY_PATH=`pwd`";;
+	*)
+		ldlibpth="LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}";;
+	esac
 
 	pldlflags="$cccdlflags"
-	# NeXT-4 specific stuff.  Can't we do this in the hint file?
 	case "${osname}${osvers}" in
 	next4*)
 		ld=libtool
 		lddlflags="-dynamic -undefined warning -framework System \
 		-compatibility_version 1 -current_version $patchlevel \
 		-prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@"
-		# NeXT uses a different name.
-		ldlibpth="DYLD_LIBRARY_PATH=`pwd`:$DYLD_LIBRARY_PATH"
 		;;
-	beos*)	ldlibpth="LIBRARY_PATH=`pwd`:$LIBRARY_PATH"
+	rhapsody*|darwin*)
+		shrpldflags="${ldflags} -dynamiclib \
+			     -compatibility_version 1 \
+			     -current_version \
+				${api_version}.${api_subversion} \
+			     -image_base 0x4be00000 \
+			     -install_name \$(shrpdir)/\$@"
 		;;
-	os2*)	# OS/2 doesn't need anything special for LD_LIBRARY_PATH.
-		ldlibpth=''
+	cygwin*)
+		linklibperl="-lperl"
 		;;
 	sunos*)
 		linklibperl="-lperl"
 		;;
-	netbsd*|freebsd[234]*)
+	netbsd*|freebsd[234]*|openbsd*)
 		linklibperl="-L. -lperl"
 		;;
 	aix*)
 		shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
 		case "$osvers" in
-		3*)
-			shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib"
+		3*)	shrpldflags="$shrpldflags -e _nostart"
 			;;
-		*)
-			shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib"
+		*)	shrpldflags="$shrpldflags -b noentry"
 			;;
 		esac
-		aixinstdir=`pwd | sed 's/\/UU$//'`
-		linklibperl="-L $archlibexp/CORE -L $aixinstdir -lperl"
+	        shrpldflags="$shrpldflags $ldflags $libs $cryptlib"
+		linklibperl="-L $archlibexp/CORE -L `pwd | sed 's/\/UU$//'` -lperl"
 		;;
-	hpux10*)
-		linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+b$archlibexp/CORE -lperl"
+	hpux*)
+		linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+s -Wl,+b$archlibexp/CORE -lperl"
 		;;
 	esac
+	case "$ldlibpthname" in
+	'') ;;
+	*)
+	    case "$osname" in
+	    os2)
+	        ldlibpth=''
+	        ;;
+	    *)
+		eval "ldlibpth=\"$ldlibpthname=`pwd`:\$$ldlibpthname\""
+		;;
+	    esac
+	    # Strip off any trailing :'s
+	    ldlibpth=`echo $ldlibpth | sed 's/:*$//'`
+	    ;;
+        esac
 	;;
 *)	pldlflags=''
 	;;
@@ -146,7 +167,7 @@ LLIBPERL= $linklibperl
 SHRPENV = $shrpenv
 
 # The following is used to include the current directory in
-# LD_LIBRARY_PATH if you are building a shared libperl.so.
+# the dynamic loader path you are building a shared libperl.
 LDLIBPTH = $ldlibpth
 
 dynamic_ext = $dynamic_list
@@ -185,6 +206,10 @@ SHELL = $sh
 # how to tr(anslate) newlines
 TRNL = '$trnl'
 
+# not used by Makefile but by installperl;
+# mentioned here so that metaconfig picks it up
+INSTALL_USR_BIN_PERL = $installusrbinperl
+
 !GROK!THIS!
 
 ## In the following dollars and backticks do not need the extra backslash.
@@ -197,36 +222,39 @@ private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm
 # Files to be built with variable substitution before miniperl
 # is available.
 sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \
-	makedir.SH perl_exp.SH writemain.SH
+	makedir.SH myconfig.SH writemain.SH
 
 shextract = Makefile cflags config.h makeaperl makedepend \
-	makedir perl.exp writemain
+	makedir myconfig writemain
 
 # Files to be built with variable substitution after miniperl is
 # available.  Dependencies handled manually below (for now).
 
-pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL
+pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL \
+	pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL
 
-plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text
+plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \
+	pod/pod2usage pod/podchecker pod/podselect
 
 addedbyconf = UU $(shextract) $(plextract) pstruct
 
 h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
 h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
-h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
+h3 = opcode.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
 h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
-h5 = bytecode.h byterun.h
+h5 = utf8.h warnings.h
 h = $(h1) $(h2) $(h3) $(h4) $(h5)
 
-c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c byterun.c
-c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c
-c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c globals.c perlio.c
+c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
+c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c
+c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c
+c4 = globals.c perlio.c perlapi.c
 
-c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c
+c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c
 
-obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) byterun$(OBJ_EXT)
+obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT)
 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
-obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT)
 
 obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
 
@@ -245,7 +273,7 @@ lintflags = -hbvxac
 .c$(OBJ_EXT):
 	$(CCCMD) $(PLDLFLAGS) $*.c
 
-all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext) $(nonxs_ext)
+all: $(FIRSTMAKEFILE) miniperl extra.pods $(private) $(public) $(dynamic_ext) $(nonxs_ext)
 	@echo " ";
 	@echo "	Everything is up to date. 'make test' to run test suite."
 
@@ -258,7 +286,7 @@ compile: all
 translators:	miniperl lib/Config.pm FORCE
 	@echo " "; echo "	Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all
 
-utilities:	miniperl lib/Config.pm FORCE
+utilities:	miniperl lib/Config.pm $(plextract) FORCE
 	@echo " "; echo "	Making utilities"; cd utils; $(LDLIBPTH) $(MAKE) all
 
 
@@ -270,12 +298,18 @@ utilities:	miniperl lib/Config.pm FORCE
 FORCE:
 	@sh -c true
 
+opmini$(OBJ_EXT): op.c
+	$(RMS) opmini.c
+	$(LNS) op.c opmini.c
+	$(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c
+	$(RMS) opmini.c
+
 miniperlmain$(OBJ_EXT): miniperlmain.c
 	$(CCCMD) $(PLDLFLAGS) $*.c
 
 perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE)
-	sh writemain $(DYNALOADER) $(static_ext) > tmp
-	sh mv-if-diff tmp perlmain.c
+	sh writemain $(DYNALOADER) $(static_ext) > writemain.tmp
+	sh mv-if-diff writemain.tmp perlmain.c
 
 perlmain$(OBJ_EXT): perlmain.c
 	$(CCCMD) $(PLDLFLAGS) $*.c
@@ -290,15 +324,81 @@ ext.libs: $(static_ext)
 
 # How to build libperl.  This is still rather convoluted.
 # Load up custom Makefile.SH fragment for shared loading and executables:
-if test -r $osname/Makefile.SHs ; then
-	. $osname/Makefile.SHs
+case "$osname" in
+*)
+	Makefile_s="$osname/Makefile.SHs"
+	;;
+esac
+
+case "$osname" in
+aix)
+	$spitshell >>Makefile <<!GROK!THIS!
+LIBS			= $libs
+# In AIX we need to change this for building Perl itself from
+# its earlier definition (which is for building external
+# extensions *after* Perl has been built and installed)
+CCDLFLAGS		= `echo $ccdlflags|sed -e 's@-bE:.*/perl\.exp@-bE:perl.exp@'`
+
+!GROK!THIS!
+	case "$useshrplib" in
+	define|true|[yY]*)
+		$spitshell >>Makefile <<'!NO!SUBS!'
+
+LIBPERL_NONSHR		= libperl_nonshr$(LIB_EXT)
+MINIPERL_NONSHR		= miniperl_nonshr$(EXE_EXT)
+
+$(LIBPERL_NONSHR): perl$(OBJ_EXT) $(obj)
+	$(RMS) $(LIBPERL_NONSHR)
+	$(AR) rcu $(LIBPERL_NONSHR) perl$(OBJ_EXT) $(obj)
+
+$(MINIPERL_NONSHR): $(LIBPERL_NONSHR) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT)
+	$(CC) $(LDFLAGS) -o $(MINIPERL_NONSHR) miniperlmain$(OBJ_EXT) \
+	    opmini$(OBJ_EXT) $(LIBPERL_NONSHR) $(LIBS)
+
+MINIPERLEXP		= $(MINIPERL_NONSHR)
+
+LIBPERLEXPORT		= perl.exp
+
+!NO!SUBS!
+		
+		;;
+	*)	
+		$spitshell >>Makefile <<'!NO!SUBS!'
+MINIPERLEXP		= miniperl$(EXE_EXT)
+
+PERLEXPORT		= perl.exp
+
+!NO!SUBS!
+	;;
+	esac
+	$spitshell >>Makefile <<'!NO!SUBS!'
+perl.exp: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH)
+	./$(MINIPERLEXP) makedef.pl PLATFORM=aix | sort -u | sort -f > perl.exp.tmp
+	sh mv-if-diff perl.exp.tmp perl.exp
+
+!NO!SUBS!
+	;;
+os2)
+	$spitshell >>Makefile <<'!NO!SUBS!'
+MINIPERLEXP		= miniperl
+
+perl5.def: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH) miniperl.map
+	./$(MINIPERLEXP) makedef.pl PLATFORM=os2 -DPERL_DLL=$(PERL_DLL) > perl.exp.tmp
+	sh mv-if-diff perl.exp.tmp perl5.def
+
+!NO!SUBS!
+	;;
+esac
+
+if test -r $Makefile_s ; then
+	. $Makefile_s
 	$spitshell >>Makefile <<!GROK!THIS!
 
-Makefile: $osname/Makefile.SHs
+Makefile: $Makefile_s
 !GROK!THIS!
 else
 	$spitshell >>Makefile <<'!NO!SUBS!'
-$(LIBPERL): $& perl$(OBJ_EXT) $(obj)
+$(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT)
 !NO!SUBS!
 	case "$useshrplib" in
 	true)
@@ -335,20 +435,48 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj)
 # build problems but that's not obvious to the novice.
 # The Module used here must not depend on Config or any extensions.
 
-miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)
-	$(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs)
-	$(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
+!NO!SUBS!
 
-perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+	case "${osname}${osvers}" in
+	next4*)
+		$spitshell >>Makefile <<'!NO!SUBS!'
+miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT)
+	$(CC) -o miniperl `echo $(obj) | sed 's/ op$(OBJ_EXT) / /'` \
+	    miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perl$(OBJ_EXT) $(libs)
+	$(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
+!NO!SUBS!
+		;;
+	aix*)
+		$spitshell >>Makefile <<'!NO!SUBS!'
+miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT)
+	$(CC) -o miniperl $(CLDFLAGS) \
+	    `echo $(obj) | sed 's/ op$(OBJ_EXT) / /'` \
+	    miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perl$(OBJ_EXT) $(libs)
+	$(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
+!NO!SUBS!
+		;;
+	*)
+		$spitshell >>Makefile <<'!NO!SUBS!'
+miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL) opmini$(OBJ_EXT)
+	$(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl \
+	    miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) $(LLIBPERL) $(libs)
+	$(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e '<?>' || $(MAKE) minitest
+!NO!SUBS!
+		;;
+	esac
+
+	$spitshell >>Makefile <<'!NO!SUBS!'
+
+perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
 	$(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
-pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
 	$(SHRPENV) $(LDLIBPTH) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
-purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
 	$(SHRPENV) $(LDLIBPTH) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
-quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
 	$(SHRPENV) $(LDLIBPTH) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 # This version, if specified in Configure, does ONLY those scripts which need
@@ -356,7 +484,7 @@ quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
 # checks as well as the special code to validate that the script in question
 # has been invoked correctly.
 
-suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(PERLEXPORT)
 	$(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
 
 !NO!SUBS!
@@ -374,7 +502,7 @@ sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h)
 # We have to call our ./makedir because Ultrix 4.3 make can't handle the line
 #	test -d lib/auto || mkdir lib/auto
 #
-preplibrary: miniperl lib/Config.pm $(plextract)
+preplibrary: miniperl lib/Config.pm
 	@sh ./makedir lib/auto
 	@echo "	AutoSplitting perl library"
 	$(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \
@@ -383,21 +511,34 @@ preplibrary: miniperl lib/Config.pm $(plextract)
 # Take care to avoid modifying lib/Config.pm without reason
 # (If trying to create a new port and having problems with the configpm script, 
 # try 'make minitest' and/or commenting out the tests at the end of configpm.)
-lib/Config.pm: config.sh miniperl configpm
-	$(LDLIBPTH) ./miniperl configpm tmp
-	sh mv-if-diff tmp $@
+lib/Config.pm: config.sh miniperl configpm lib/re.pm
+	$(LDLIBPTH) ./miniperl configpm configpm.tmp
+	sh mv-if-diff configpm.tmp $@
 
 lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm
-	$(LDLIBPTH) ./miniperl minimod.pl > tmp
-	sh mv-if-diff tmp $@
+	$(LDLIBPTH) ./miniperl minimod.pl > minimod.tmp
+	sh mv-if-diff minimod.tmp $@
 
 lib/re.pm: ext/re/re.pm
 	rm -f $@
 	cat ext/re/re.pm > $@
 
-$(plextract):	miniperl lib/Config.pm lib/re.pm
+$(plextract):	miniperl lib/Config.pm
 	$(LDLIBPTH) ./miniperl -Ilib $@.PL
-	
+
+extra.pods: miniperl
+	-@test -f extra.pods && rm -f `cat extra.pods`
+	-@rm -f extra.pods
+	-@for x in `grep -l '^=[a-z]' README.* | grep -v README.vms` ; do \
+	    nx=`echo $$x | sed -e "s/README\.//"`; \
+	    $(LNS) ../$$x "pod/perl"$$nx".pod" ; \
+	    echo "pod/perl"$$nx".pod" >> extra.pods ; \
+	done
+	-@test -f vms/perlvms.pod && $(LNS) ../vms/perlvms.pod pod/perlvms.pod && echo "pod/perlvms.pod" >> extra.pods
+
+install-strip:
+	$(MAKE) STRIPFLAGS=-s install
+
 install: all install.perl install.man
 
 install.perl:	all installperl
@@ -408,7 +549,7 @@ install.perl:	all installperl
 		cd ../pod; $(MAKE) compile; \
 	else :; \
 	fi
-	$(LDLIBPTH) ./perl installperl
+	$(LDLIBPTH) ./perl installperl $(STRIPFLAGS)
 
 install.man:	all installman
 	$(LDLIBPTH) ./perl installman
@@ -416,6 +557,7 @@ install.man:	all installman
 # XXX Experimental. Hardwired values, but useful for testing.
 # Eventually Configure could ask for some of these values.
 install.html: all installhtml
+	-@test -f README.vms && $(LNS) ../README.vms vms/README_vms.pod
 	$(LDLIBPTH) ./perl installhtml                   \
       --podroot=. --podpath=. --recurse  \
       --htmldir=$(privlib)/html     \
@@ -434,13 +576,12 @@ install.html: all installhtml
 # normally shouldn't remake perly.[ch].
 
 run_byacc:	FORCE
-	@ echo 'Expect' 113 shift/reduce and 1 reduce/reduce conflict
 	$(BYACC) -d perly.y
-	chmod 664 perly.c
+	-chmod 664 perly.c
 	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
-	echo 'extern YYSTYPE yylval;' >>y.tab.h
+	sed -e '/^extern YYSTYPE yy/D' y.tab.h >yh.tmp && mv yh.tmp y.tab.h
 	cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h perly.h
 	chmod 664 vms/perly_c.vms vms/perly_h.vms
 	perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
@@ -456,28 +597,43 @@ perly.h: perly.y
 
 # No compat3.sym here since and including the 5.004_50.
 # No interp.sym since 5.005_03.
-SYM  = global.sym perlio.sym thread.sym
+SYM  = global.sym globvar.sym perlio.sym pp.sym
 
-SYMH = perlvars.h thrdvar.h
+SYMH = perlvars.h intrpvar.h thrdvar.h
+
+CHMOD_W = chmod +w
 
 # The following files are generated automatically
-#	keywords.h:	keywords.pl
-#	opcode.h:	opcode.pl
-#	embed.h:  	embed.pl global.sym
-#	byterun.h:	bytecode.pl
-#	byterun.c:	bytecode.pl
-#	lib/B/Asmdata.pm:	bytecode.pl
-#	regnodes.h:	regcomp.pl
+#	keywords.pl:	keywords.h
+#	opcode.pl:	opcode.h opnames.h pp_proto.h pp.sym
+# [* embed.pl needs pp.sym generated by opcode.pl! *]
+#	embed.pl:	proto.h embed.h embedvar.h global.sym objXSUB.h
+#			perlapi.h perlapi.c pod/perlintern.pod
+#			pod/perlapi.pod
+#	bytecode.pl:	ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c
+#			ext/B/B/Asmdata.pm
+#	regcomp.pl:	regnodes.h
+#	warnings.pl:	warnings.h lib/warnings.pm
 # The correct versions should be already supplied with the perl kit,
 # in case you don't have perl available.
-# To force them to run, type
+# To force them to be regenerated, type
 #	make regen_headers
+
+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 \
+		objXSUB.h perlapi.h perlapi.c ext/ByteLoader/byterun.h \
+		ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm regnodes.h \
+		warnings.h lib/warnings.pm
+
 regen_headers:	FORCE
-	perl keywords.pl
-	perl opcode.pl
-	perl embed.pl
-	perl bytecode.pl
-	perl regcomp.pl
+	-$(CHMOD_W) $(AUTOGEN_FILES)
+	-perl keywords.pl
+	-perl opcode.pl
+	-perl embed.pl
+	-perl bytecode.pl
+	-perl regcomp.pl
+	-perl warnings.pl
 
 # Extensions:
 # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will
@@ -514,38 +670,42 @@ distclean:	clobber
 # Do not 'make _mopup' directly.
 _mopup:
 	rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c
-	rm -f perl.exp ext.libs
+	-@test -f extra.pods && rm -f `cat extra.pods`
+	-@test -f vms/README_vms.pod && rm -f vms/README_vms.pod
+	-rm -f perl.exp ext.libs extra.pods
 	-rm -f perl.export perl.dll perl.libexp perl.map perl.def
+	-rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap
 	rm -f perl suidperl miniperl $(LIBPERL)
 
 # Do not 'make _tidy' directly.
 _tidy:
-	-cd pod; $(MAKE) clean
-	-cd utils; $(MAKE) clean
-	-cd x2p; $(MAKE) clean
+	-cd pod; $(LDLIBPTH) $(MAKE) clean
+	-cd utils; $(LDLIBPTH) $(MAKE) clean
+	-cd x2p; $(LDLIBPTH) $(MAKE) clean
 	-@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
-	sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
+	$(LDLIBPTH) sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
 	done
 	rm -f testcompile compilelog
 
 # Do not 'make _cleaner' directly.
 _cleaner:
 	-cd os2; rm -f Makefile
-	-cd pod; $(MAKE) realclean
-	-cd utils; $(MAKE) realclean
-	-cd x2p; $(MAKE) realclean
+	-cd pod; $(LDLIBPTH) $(MAKE) realclean
+	-cd utils; $(LDLIBPTH) $(MAKE) realclean
+	-cd x2p; $(LDLIBPTH) $(MAKE) realclean
 	-@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
-	sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \
+	$(LDLIBPTH) sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \
 	done
-	rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl
+	rm -f *.orig */*.orig *~ */*~ core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/tmp* t/c t/perl .?*.c so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR)
 	rm -rf $(addedbyconf)
 	rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old
 	rm -f $(private)
 	rm -rf lib/auto
-	rm -f lib/.exists
+	rm -f lib/.exists lib/*/.exists
 	rm -f h2ph.man pstruct
 	rm -rf .config
 	rm -f testcompile compilelog
+	-rmdir lib/B lib/Data lib/IO/Socket lib/IO
 
 # The following lint has practically everything turned on.  Unfortunately,
 # you have to wade through a lot of mumbo jumbo that can't be suppressed.
@@ -567,10 +727,6 @@ $(FIRSTMAKEFILE):	README $(MAKEDEPEND)
 config.h: config_h.SH config.sh
 	$(SHELL) config_h.SH
 
-# This is an AIXism.
-perl.exp: perl_exp.SH config.sh $(SYM) $(SYMH)
-	$(SHELL) perl_exp.SH
-
 # When done, touch perlmain.c so that it doesn't get remade each time.
 depend: makedepend
 	sh ./makedepend MAKE=$(MAKE)
@@ -581,11 +737,26 @@ depend: makedepend
 makedepend: makedepend.SH config.sh
 	sh ./makedepend.SH
 
-test-prep: miniperl perl preplibrary utilities $(dynamic_ext) $(nonxs_ext)
+# Cannot delegate rebuilding of t/perl to make to allow interlaced
+# test and minitest
+test-prep: miniperl perl preplibrary utilities $(dynamic_ext) $(nonxs_ext) $(TEST_PERL_DLL)
 	cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT))
 
+# Second branch is for testing without a tty or controling terminal.
+# See t/op/stat.t
 test check: test-prep
-	cd t && $(LDLIBPTH) ./perl TEST </dev/tty
+	if (true </dev/tty) >/dev/null 2>&1; then \
+	  cd t && $(LDLIBPTH) ./perl TEST </dev/tty; \
+	else \
+	  cd t && PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) ./perl TEST; \
+	fi
+
+utest ucheck: test-prep
+	if (true </dev/tty) >/dev/null 2>&1; then \
+	  cd t && $(LDLIBPTH) ./perl UTEST </dev/tty; \
+	else \
+	  cd t && PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) ./perl UTEST; \
+	fi
 
 # For testing without a tty or controling terminal. See t/op/stat.t
 test-notty: test-prep
@@ -612,6 +783,9 @@ okfile:	utilities
 nok:	utilities
 	$(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)'
 
+nokfile:	utilities
+	$(LDLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)' -F perl.nok
+
 clist:	$(c)
 	echo $(c) | tr ' ' $(TRNL) >.clist
 
@@ -635,9 +809,19 @@ elc:	emacs/cperl-mode.elc
 emacs/cperl-mode.elc: emacs/cperl-mode.el
 	-cd emacs; emacs -batch -q -no-site-file -f batch-byte-compile cperl-mode.el
 
-etags:	emacs/cperl-mode.elc
+etags:	TAGS
+
+TAGS: emacs/cperl-mode.elc
 	sh emacs/ptags
 
+ctags:	tags
+
+# Let's hope make will not go into an infinite loop on case-unsensitive systems
+# This may also fail if . is in the head of the path, since perl will
+# require -Ilib
+tags:	TAGS
+	perl emacs/e2ctags.pl TAGS > tags
+
 # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
 # If this runs make out of memory, delete /usr/include lines.
 !NO!SUBS!
@@ -658,8 +842,9 @@ $define)
     xxx=''
     echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4
 case "$osname" in
-os390)
+os390|posix-bc)
     rm -f y.tab.c y.tab.h
+    # yacc must be a reentrant ("pure") Bison in BS2000 Posix!
     yacc -d perly.y >/dev/null 2>&1
     if cmp -s y.tab.c perly.c; then
         rm -f y.tab.c
@@ -667,8 +852,21 @@ os390)
         echo "perly.y -> perly.c" >&2
         mv -f y.tab.c perly.c
         chmod u+w 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
+        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 perly.tmp perly.c
         xxx="$xxx perly.c"
     fi
     if cmp -s y.tab.h perly.h; then
@@ -681,7 +879,15 @@ os390)
     if cd x2p
     then
         rm -f y.tab.c y.tab.h
-        yacc a2p.y >/dev/null 2>&1
+        case "$osname" in
+        posix-bc)
+           # we are using two different yaccs in BS2000 Posix!
+           byacc a2p.y >/dev/null 2>&1
+           ;;
+        *) # e.g. os390
+           yacc  a2p.y >/dev/null 2>&1
+           ;;
+        esac
         if cmp -s y.tab.c a2p.c
         then
             rm -f y.tab.c
@@ -708,6 +914,9 @@ os390)
         cd ..
     fi
     ;;
+vmesa)
+    # Do nothing in VM/ESA.
+    ;;
 *)
     echo "'$osname' is an EBCDIC system I don't know that well." >&4
     ;;
@@ -717,3 +926,4 @@ esac
     esac
     ;;
 esac
+

contrib/perl5/Policy_sh.SH

@@ -1,4 +1,4 @@
-case $CONFIG in
+case $CONFIGDOTSH in
 '') . ./config.sh ;;
 esac
 echo "Extracting Policy.sh (with variable substitutions)"
@@ -29,12 +29,25 @@ case "\$perladmin" in
 '') perladmin='$perladmin' ;;
 esac
 
-# Installation prefix.  Allow a Configure -D override.  You
+# Installation prefixes.  Allow a Configure -D override.  You
 # may wish to reinstall perl under a different prefix, perhaps
 # in order to test a different configuration.
+# For an explanation of the installation directories, see the
+# INSTALL file section on "Installation Directories".
 case "\$prefix" in
 '') prefix='$prefix' ;;
 esac
+case "\$siteprefix" in
+'') siteprefix='$siteprefix' ;;
+esac
+case "\$vendorprefix" in
+'') vendorprefix='$vendorprefix' ;;
+esac
+
+# Where installperl puts things.
+case "\$installprefix" in
+'') installprefix='$installprefix' ;;
+esac
 
 # Installation directives.  Note that each one comes in three flavors.
 # For example, we have privlib, privlibexp, and installprivlib.
@@ -44,7 +57,22 @@ esac
 #     out automatically by Configure, so you don't have to include it here.
 # installprivlib is for systems (such as those running AFS) that
 #     need to distinguish between the place where things
-#     get installed and where they finally will reside.
+#     get installed and where they finally will reside.  As of 5.005_6x,
+#     this too is handled automatically by Configure based on
+#     $installprefix, so it isn't included here either.
+#
+# Note also that there are three broad hierarchies of installation 
+# directories, as discussed in the INSTALL file under 
+# "Installation Directories":
+#
+#  =item Directories for the perl distribution
+#
+#  =item Directories for site-specific add-on files
+#
+#  =item Directories for vendor-supplied add-on files
+#
+#  See Porting/Glossary for the definitions of these names, and see the
+#  INSTALL file for further explanation and some examples.
 # 
 # In each case, if your previous value was the default, leave it commented
 # out.  That way, if you override prefix, all of these will be
@@ -56,13 +84,17 @@ esac
 
 !GROK!THIS!
 
-for var in bin scriptdir privlib archlib \
-	man1dir man3dir sitelib sitearch \
-	installbin installscript installprivlib installarchlib \
-	installman1dir installman3dir installsitelib installsitearch \
-	man1ext man3ext; do
+for var in \
+	bin scriptdir privlib archlib man1dir man3dir html1dir html3dir \
+	sitebin sitescript sitelib sitearch \
+		siteman1 siteman3 sitehtml1 sitehtml3 \
+	vendorbin vendorscript vendorlib vendorarch \
+		vendorman1 vendorman3 vendorhtml1 vendorhtml3
+do
 	
     case "$var" in
+
+    # Directories for the core perl components
     bin)	dflt=$prefix/bin ;;
     # The scriptdir test is more complex, but this is probably usually ok.
     scriptdir)
@@ -78,47 +110,73 @@ for var in bin scriptdir privlib archlib \
 	*)	dflt=$prefix/lib/$package/$version ;;
 	esac
 	;;
-    archlib)	
-	case "$prefix" in
-	*perl*)	dflt=$prefix/lib/$version/$archname ;;
-	*)	dflt=$prefix/lib/$package/$version/$archname ;;
-	esac
-	;;
-    sitelib)
-	case "$prefix" in
-	*perl*)	dflt=$prefix/lib/site_perl/$apiversion ;;
-	*)	dflt=$prefix/lib/$package/site_perl/$apiversion ;;
-	esac
-	;;
-    sitearch)	
-	case "$prefix" in
-	*perl*)	dflt=$prefix/lib/site_perl/$apiversion/$archname ;;
-	*)	dflt=$prefix/lib/$package/site_perl/$apiversion/$archname ;;
-	esac
-	;;
-    man1dir)	dflt="$prefix/man/man1" ;;
-    man3dir)
-	case "$prefix" in
-	*perl*) dflt=`echo $man1dir |
-		    sed -e 's/man1/man3/g' -e 's/man\.1/man\.3/g'` ;;
-	*)	dflt=$privlib/man/man3 ;;
-	esac
-	;;
+    archlib)	dflt="$privlib/$archname" ;;
 
+    man1dir)	dflt="$prefix/man/man1" ;;
+    man3dir)	dflt="$prefix/man/man3" ;;
     # Can we assume all sed's have greedy matching?
     man1ext)	dflt=`echo $man1dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;;
     man3ext)	dflt=`echo $man3dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;;
 
-    # It might be possible to fool these next tests.  Please let
-    # me know if they don't work right for you.
-    installbin)		dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;;
-    installscript)	dflt=`echo $scriptdirexp | sed 's#^/afs/#/afs/.#'`;;
-    installprivlib)	dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;;
-    installarchlib)	dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;;
-    installsitelib)	dflt=`echo $sitelibexp | sed 's#^/afs/#/afs/.#'`;;
-    installsitearch)	dflt=`echo $sitearchexp | sed 's#^/afs/#/afs/.#'`;;
-    installman1dir)	dflt=`echo $man1direxp | sed 's#^/afs/#/afs/.#'`;;
-    installman3dir)	dflt=`echo $man3direxp | sed 's#^/afs/#/afs/.#'`;;
+    # We don't know what to do with these yet.
+    html1dir)	dflt='' ;;
+    htm31dir)	dflt='' ;;
+
+    # Directories for site-specific add-on files
+    sitebin)	dflt=$siteprefix/bin ;;
+    sitescript)
+	if $test -d $siteprefix/script; then
+	    dflt=$siteprefix/script
+	else
+	    dflt=$sitebin
+	fi
+	;;
+    sitelib)
+	case "$siteprefix" in
+	*perl*)	dflt=$prefix/lib/site_perl/$version ;;
+	*)	dflt=$prefix/lib/$package/site_perl/$version ;;
+	esac
+	;;
+    sitearch)	dflt="$sitelib/$archname" ;;
+
+    siteman1)	dflt="$siteprefix/man/man1" ;;
+    siteman3)	dflt="$siteprefix/man/man3" ;;
+    # We don't know what to do with these yet.
+    sitehtml1)	dflt='' ;;
+    sitehtm31dir)	dflt='' ;;
+    
+    # Directories for vendor-supplied add-on files
+    # These are all usually empty.
+    vendor*)
+	if test X"$vendorprefix" = X""; then
+	    dflt=''
+	else
+	    case "$var" in
+	    vendorbin)	dflt=$vendorprefix/bin ;;
+	    vendorscript)
+		if $test -d $vendorprefix/script; then
+		    dflt=$vendorprefix/script
+		else
+		    dflt=$vendorbin
+		fi
+		;;
+	    vendorlib)
+		case "$vendorprefix" in
+		*perl*)	dflt=$prefix/lib/vendor_perl/$version ;;
+		*)	dflt=$prefix/lib/$package/vendor_perl/$version ;;
+		esac
+		;;
+	    vendorarch)	dflt="$vendorlib/$archname" ;;
+
+	    vendorman1)	dflt="$vendorprefix/man/man1" ;;
+	    vendorman3)	dflt="$vendorprefix/man/man3" ;;
+	    # We don't know what to do with these yet.
+	    vendorhtml1)	dflt='' ;;
+	    vendorhtm3)	dflt='' ;;
+
+	    esac  # End of vendorprefix != ''
+	fi
+	;;
     esac
     
     eval val="\$$var"
@@ -148,6 +206,5 @@ $spitshell <<!GROK!THIS! >>Policy.sh
 #   The original design for this Policy.sh file came from Wayne Davison,
 #   maintainer of trn.
 #   This version for Perl5.004_61 originally written by
-#   Andy Dougherty <doughera@lafcol.lafayette.edu>.
+#   Andy Dougherty <doughera@lafayette.edu>.
 #   This file may be distributed under the same terms as Perl itself.
-

contrib/perl5/Porting/config.sh

@@ -8,9 +8,9 @@
 
 # Package name      : perl5
 # Source directory  : .
-# Configuration time: Tue Jul 21 10:03:27 EDT 1998
-# Configured by     : doughera
-# Target system     : linux fractal 2.0.34 #1 tue jun 23 10:09:17 edt 1998 i686 unknown 
+# Configuration time: Tue Mar 21 23:22:20 EET 2000
+# Configured by     : jhi
+# Target system     : osf1 alpha.hut.fi v4.0 878 alpha 
 
 Author=''
 Date='$Date'
@@ -27,33 +27,40 @@ _a='.a'
 _exe=''
 _o='.o'
 afs='false'
-alignbytes='4'
+alignbytes='8'
 ansi2knr=''
 aphostname=''
-apiversion='5.005'
+api_revision='5'
+api_subversion='0'
+api_version='5'
+api_versionstring='5.005'
 ar='ar'
-archlib='/opt/perl/lib/5.005/i686-linux-thread'
-archlibexp='/opt/perl/lib/5.005/i686-linux-thread'
-archname='i686-linux-thread'
+archlib='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi'
+archlibexp='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi'
+archname64=''
+archname='alpha-dec_osf-thread-multi'
 archobjs=''
 awk='awk'
 baserev='5.0'
 bash=''
 bin='/opt/perl/bin'
+bincompat5005='undef'
 binexp='/opt/perl/bin'
 bison=''
 byacc='byacc'
-byteorder='1234'
-c=''
+byteorder='12345678'
+c='\c'
 castflags='0'
 cat='cat'
 cc='cc'
-cccdlflags='-fpic'
-ccdlflags='-rdynamic'
-ccflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -I/usr/local/include'
-cf_by='doughera'
+cccdlflags=' '
+ccdlflags='  -Wl,-rpath,/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi/CORE'
+ccflags='-pthread -std -DLANGUAGE_C'
+ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_BSD=1 SYSTYPE_BSD=1 unix=1'
+cf_by='jhi'
 cf_email='yourname@yourhost.yourplace.com'
-cf_time='Tue Jul 21 10:03:27 EDT 1998'
+cf_time='Tue Mar 21 23:22:20 EET 2000'
+charsize='1'
 chgrp=''
 chmod=''
 chown=''
@@ -65,23 +72,42 @@ cp='cp'
 cpio=''
 cpp='cpp'
 cpp_stuff='42'
-cppflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -I/usr/local/include'
-cpplast='-'
-cppminus='-'
-cpprun='cc -E'
-cppstdin='cc -E'
+cppccsymbols='LANGUAGE_C=1'
+cppflags='-pthread -std -DLANGUAGE_C'
+cpplast=''
+cppminus=''
+cpprun='/usr/bin/cpp'
+cppstdin='cppstdin'
+cppsymbols='_AES_SOURCE=1 __alpha=1 __ALPHA=1 _ANSI_C_SOURCE=1 __LANGUAGE_C__=1 _LONGLONG=1 __osf__=1 _OSF_SOURCE=1 _POSIX_C_SOURCE=199506 _POSIX_SOURCE=1 _REENTRANT=1 __STDC__=1 _SYSTYPE_BSD=1 __unix__=1 _XOPEN_SOURCE=1'
+crosscompile='undef'
 cryptlib=''
 csh='csh'
 d_Gconvert='gcvt((x),(n),(b))'
+d_PRIEldbl='define'
+d_PRIFldbl='define'
+d_PRIGldbl='define'
+d_PRIX64='define'
+d_PRId64='define'
+d_PRIeldbl='define'
+d_PRIfldbl='define'
+d_PRIgldbl='define'
+d_PRIi64='define'
+d_PRIo64='define'
+d_PRIu64='define'
+d_PRIx64='define'
 d_access='define'
+d_accessx='undef'
 d_alarm='define'
 d_archlib='define'
-d_attribut='define'
+d_atolf='undef'
+d_atoll='undef'
+d_attribut='undef'
 d_bcmp='define'
 d_bcopy='define'
+d_bincompat5005='undef'
 d_bsd='undef'
 d_bsdgetpgrp='undef'
-d_bsdsetpgrp='undef'
+d_bsdsetpgrp='define'
 d_bzero='define'
 d_casti32='undef'
 d_castneg='define'
@@ -96,18 +122,21 @@ d_csh='define'
 d_cuserid='define'
 d_dbl_dig='define'
 d_difftime='define'
-d_dirnamlen='undef'
+d_dirnamlen='define'
 d_dlerror='define'
 d_dlopen='define'
 d_dlsymun='undef'
 d_dosuid='undef'
+d_drand48proto='define'
 d_dup2='define'
+d_eaccess='undef'
 d_endgrent='define'
 d_endhent='define'
 d_endnent='define'
 d_endpent='define'
 d_endpwent='define'
 d_endsent='define'
+d_endspent='undef'
 d_eofnblk='define'
 d_eunice='undef'
 d_fchmod='define'
@@ -121,16 +150,26 @@ d_flexfnam='define'
 d_flock='define'
 d_fork='define'
 d_fpathconf='define'
+d_fpos64_t='undef'
+d_fs_data_s='undef'
+d_fseeko='undef'
 d_fsetpos='define'
+d_fstatfs='define'
+d_fstatvfs='define'
+d_ftello='undef'
 d_ftime='undef'
+d_getcwd='define'
+d_getfsstat='define'
 d_getgrent='define'
 d_getgrps='define'
 d_gethbyaddr='define'
 d_gethbyname='define'
 d_gethent='define'
-d_gethname='undef'
+d_gethname='define'
 d_gethostprotos='define'
 d_getlogin='define'
+d_getmnt='undef'
+d_getmntent='undef'
 d_getnbyaddr='define'
 d_getnbyname='define'
 d_getnent='define'
@@ -149,38 +188,62 @@ d_getsbyname='define'
 d_getsbyport='define'
 d_getsent='define'
 d_getservprotos='define'
+d_getspent='undef'
+d_getspnam='undef'
 d_gettimeod='define'
-d_gnulibc='define'
+d_gnulibc='undef'
 d_grpasswd='define'
+d_hasmntopt='undef'
 d_htonl='define'
+d_iconv='define'
 d_index='undef'
 d_inetaton='define'
+d_int64_t='undef'
 d_isascii='define'
 d_killpg='define'
-d_lchown='undef'
+d_lchown='define'
+d_ldbl_dig='define'
 d_link='define'
 d_locconv='define'
 d_lockf='define'
 d_longdbl='define'
 d_longlong='define'
+d_lseekproto='define'
 d_lstat='define'
+d_madvise='define'
 d_mblen='define'
 d_mbstowcs='define'
 d_mbtowc='define'
+d_memchr='define'
 d_memcmp='define'
 d_memcpy='define'
 d_memmove='define'
 d_memset='define'
 d_mkdir='define'
+d_mkdtemp='undef'
 d_mkfifo='define'
+d_mkstemp='define'
+d_mkstemps='undef'
 d_mktime='define'
+d_mmap='define'
+d_mprotect='define'
 d_msg='define'
+d_msg_ctrunc='define'
+d_msg_dontroute='define'
+d_msg_oob='define'
+d_msg_peek='define'
+d_msg_proxy='undef'
 d_msgctl='define'
 d_msgget='define'
 d_msgrcv='define'
 d_msgsnd='define'
+d_msync='define'
+d_munmap='define'
 d_mymalloc='undef'
 d_nice='define'
+d_nv_preserves_uv='undef'
+d_off64_t='undef'
+d_old_pthread_create_joinable='undef'
 d_oldpthreads='undef'
 d_oldsock='undef'
 d_open3='define'
@@ -191,15 +254,16 @@ d_pipe='define'
 d_poll='define'
 d_portable='define'
 d_pthread_yield='undef'
-d_pthreads_created_joinable='define'
 d_pwage='undef'
 d_pwchange='undef'
 d_pwclass='undef'
-d_pwcomment='undef'
+d_pwcomment='define'
 d_pwexpire='undef'
 d_pwgecos='define'
-d_pwquota='undef'
 d_pwpasswd='define'
+d_pwquota='define'
+d_qgcvt='undef'
+d_quad='define'
 d_readdir='define'
 d_readlink='define'
 d_rename='define'
@@ -209,6 +273,7 @@ d_safebcpy='define'
 d_safemcpy='undef'
 d_sanemcmp='define'
 d_sched_yield='define'
+d_scm_rights='define'
 d_seekdir='define'
 d_select='define'
 d_sem='define'
@@ -235,10 +300,11 @@ d_setregid='define'
 d_setresgid='undef'
 d_setresuid='undef'
 d_setreuid='define'
-d_setrgid='undef'
-d_setruid='undef'
+d_setrgid='define'
+d_setruid='define'
 d_setsent='define'
 d_setsid='define'
+d_setspent='undef'
 d_setvbuf='define'
 d_sfio='undef'
 d_shm='define'
@@ -250,10 +316,16 @@ d_shmget='define'
 d_sigaction='define'
 d_sigsetjmp='define'
 d_socket='define'
+d_socklen_t='undef'
 d_sockpair='define'
-d_statblks='undef'
-d_stdio_cnt_lval='undef'
+d_sqrtl='define'
+d_statblks='define'
+d_statfs_f_flags='define'
+d_statfs_s='define'
+d_statvfs='define'
+d_stdio_cnt_lval='define'
 d_stdio_ptr_lval='define'
+d_stdio_stream_array='define'
 d_stdiobase='define'
 d_stdstdio='define'
 d_strchr='define'
@@ -263,7 +335,11 @@ d_strerrm='strerror(e)'
 d_strerror='define'
 d_strtod='define'
 d_strtol='define'
+d_strtold='undef'
+d_strtoll='undef'
 d_strtoul='define'
+d_strtoull='undef'
+d_strtouq='undef'
 d_strxfrm='define'
 d_suidsafe='undef'
 d_symlink='define'
@@ -275,13 +351,18 @@ d_system='define'
 d_tcgetpgrp='define'
 d_tcsetpgrp='define'
 d_telldir='define'
+d_telldirproto='define'
 d_time='define'
 d_times='define'
 d_truncate='define'
 d_tzname='define'
 d_umask='define'
 d_uname='define'
-d_union_semun='define'
+d_union_semun='undef'
+d_ustat='define'
+d_vendorarch='undef'
+d_vendorbin='undef'
+d_vendorlib='undef'
 d_vfork='undef'
 d_void_closedir='undef'
 d_voidsig='define'
@@ -301,7 +382,8 @@ direntrytype='struct dirent'
 dlext='so'
 dlsrc='dl_dlopen.xs'
 doublesize='8'
-dynamic_ext='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re'
+drand01='drand48()'
+dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog Thread attrs re'
 eagain='EAGAIN'
 ebcdic='undef'
 echo='echo'
@@ -310,17 +392,24 @@ emacs=''
 eunicefix=':'
 exe_ext=''
 expr='expr'
-extensions='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re Errno'
-find='find'
+extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog Thread attrs re Errno'
+fflushNULL='define'
+fflushall='undef'
+find=''
 firstmakefile='makefile'
 flex=''
+fpossize='8'
 fpostype='fpos_t'
 freetype='void'
-full_csh='/bin/csh'
-full_sed='/bin/sed'
-gccversion='2.7.2.3'
+full_ar='/usr/bin/ar'
+full_csh='/usr/bin/csh'
+full_sed='/usr/bin/sed'
+gccversion=''
+gidformat='"u"'
+gidsign='1'
+gidsize='4'
 gidtype='gid_t'
-glibpth='/usr/shlib  /shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/local/lib '
+glibpth='/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /usr/local/lib /var/shlib'
 grep='grep'
 groupcat='cat /etc/group'
 groupstype='gid_t'
@@ -330,6 +419,14 @@ h_sysfile='true'
 hint='recommended'
 hostcat='cat /etc/hosts'
 huge=''
+i16size='2'
+i16type='short'
+i32size='4'
+i32type='int'
+i64size='8'
+i64type='long'
+i8size='1'
+i8type='char'
 i_arpainet='define'
 i_bsdioctl=''
 i_db='define'
@@ -339,88 +436,131 @@ i_dld='undef'
 i_dlfcn='define'
 i_fcntl='undef'
 i_float='define'
-i_gdbm='define'
+i_gdbm='undef'
 i_grp='define'
+i_iconv='define'
+i_ieeefp='undef'
+i_inttypes='undef'
 i_limits='define'
 i_locale='define'
+i_machcthr='undef'
 i_malloc='define'
 i_math='define'
 i_memory='undef'
+i_mntent='undef'
 i_ndbm='define'
 i_netdb='define'
 i_neterrno='undef'
+i_netinettcp='define'
 i_niin='define'
+i_poll='define'
+i_pthread='define'
 i_pwd='define'
 i_rpcsvcdbm='undef'
 i_sfio='undef'
 i_sgtty='undef'
+i_shadow='undef'
+i_socks='undef'
 i_stdarg='define'
 i_stddef='define'
 i_stdlib='define'
 i_string='define'
+i_sunmath='undef'
+i_sysaccess='define'
 i_sysdir='define'
 i_sysfile='define'
 i_sysfilio='undef'
 i_sysin='undef'
 i_sysioctl='define'
+i_syslog='define'
+i_sysmman='define'
+i_sysmode='define'
+i_sysmount='define'
 i_sysndir='undef'
 i_sysparam='define'
 i_sysresrc='define'
+i_syssecrt='define'
 i_sysselct='define'
 i_syssockio=''
 i_sysstat='define'
+i_sysstatfs='undef'
+i_sysstatvfs='define'
 i_systime='define'
 i_systimek='undef'
 i_systimes='define'
 i_systypes='define'
+i_sysuio='define'
 i_sysun='define'
+i_sysutsname='define'
+i_sysvfs='undef'
 i_syswait='define'
 i_termio='undef'
 i_termios='define'
 i_time='undef'
 i_unistd='define'
+i_ustat='define'
 i_utime='define'
 i_values='define'
 i_varargs='undef'
 i_varhdr='stdarg.h'
 i_vfork='undef'
+ignore_versioned_solibs=''
+inc_version_list=' '
+inc_version_list_init='0'
 incpath=''
 inews=''
-installarchlib='/opt/perl/lib/5.005/i686-linux-thread'
+installarchlib='/opt/perl/lib/5.6.0/alpha-dec_osf-thread-multi'
 installbin='/opt/perl/bin'
 installman1dir='/opt/perl/man/man1'
 installman3dir='/opt/perl/man/man3'
-installprivlib='/opt/perl/lib/5.005'
-installscript='/opt/perl/script'
-installsitearch='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
-installsitelib='/opt/perl/lib/site_perl/5.005'
+installprefix='/opt/perl'
+installprefixexp='/opt/perl'
+installprivlib='/opt/perl/lib/5.6.0'
+installscript='/opt/perl/bin'
+installsitearch='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi'
+installsitebin='/opt/perl/bin'
+installsitelib='/opt/perl/lib/site_perl/5.6.0'
+installstyle='lib'
+installusrbinperl='define'
+installvendorarch=''
+installvendorbin=''
+installvendorlib=''
 intsize='4'
-known_extensions='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re'
+ivdformat='"ld"'
+ivsize='8'
+ivtype='long'
+known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog Thread attrs re'
 ksh=''
 large=''
-ld='cc'
-lddlflags='-shared -L/usr/local/lib'
-ldflags=' -L/usr/local/lib'
+ld='ld'
+lddlflags='-shared -expect_unresolved "*" -msym -std -s'
+ldflags=''
+ldlibpthname='LD_LIBRARY_PATH'
 less='less'
 lib_ext='.a'
-libc=''
-libperl='libperl.a'
-libpth='/usr/local/lib /lib /usr/lib'
-libs='-lnsl -lndbm -lgdbm -ldbm -ldb -ldl -lm -lpthread -lc -lposix -lcrypt'
-libswanted='sfio socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m pthread c cposix posix ndir dir crypt ucb BSD PW x'
-line='line'
+libc='/usr/shlib/libc.so'
+libperl='libperl.so'
+libpth='/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /var/shlib'
+libs='-lgdbm -ldbm -ldb -lm -liconv -lpthread -lexc'
+libsdirs=' /usr/shlib /usr/ccs/lib'
+libsfiles=' libgdbm.so libdbm.a libdb.so libm.so libiconv.so libpthread.so libexc.so'
+libsfound=' /usr/shlib/libgdbm.so /usr/ccs/lib/libdbm.a /usr/shlib/libdb.so /usr/shlib/libm.so /usr/shlib/libiconv.so /usr/shlib/libpthread.so /usr/shlib/libexc.so'
+libspath=' /usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc /usr/lib /var/shlib'
+libswanted='sfio socket bind inet nsl nm gdbm dbm db malloc dld ld sun m cposix posix ndir dir crypt sec ucb BSD x iconv pthread exc'
+line=''
 lint=''
 lkflags=''
 ln='ln'
-lns='/bin/ln -s'
+lns='/usr/bin/ln -s'
 locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
 loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
-longdblsize='12'
+longdblsize='8'
 longlongsize='8'
-longsize='4'
+longsize='8'
 lp=''
 lpr=''
 ls='ls'
+lseeksize='8'
 lseektype='off_t'
 mail=''
 mailx=''
@@ -436,64 +576,90 @@ man3dir='/opt/perl/man/man3'
 man3direxp='/opt/perl/man/man3'
 man3ext='3'
 medium=''
-mips=''
 mips_type=''
 mkdir='mkdir'
+mmaptype='void *'
 models='none'
 modetype='mode_t'
 more='more'
+multiarch='undef'
 mv=''
-myarchname='i686-linux'
+myarchname='alpha-dec_osf'
 mydomain='.yourplace.com'
 myhostname='yourhost'
-myuname='linux fractal 2.0.34 #1 tue jun 23 10:09:17 edt 1998 i686 unknown '
-n='-n'
+myuname='osf1 alpha.hut.fi v4.0 878 alpha '
+n=''
 netdb_hlen_type='int'
 netdb_host_type='const char *'
 netdb_name_type='const char *'
-netdb_net_type='unsigned long'
+netdb_net_type='int'
 nm='nm'
-nm_opt=''
-nm_so_opt='--dynamic'
+nm_opt='-p'
+nm_so_opt=''
 nonxs_ext='Errno'
 nroff='nroff'
+nvsize='8'
+nvtype='double'
 o_nonblock='O_NONBLOCK'
 obj_ext='.o'
+old_pthread_create_joinable=''
 optimize='-O'
 orderlib='false'
-osname='linux'
-osvers='2.0.34'
+osname='dec_osf'
+osvers='4.0'
 package='perl5'
-pager='/usr/bin/less'
+pager='/c/bin/less'
 passcat='cat /etc/passwd'
-patchlevel='5'
+patchlevel='6'
 path_sep=':'
-perl='perl'
+perl5='/u/vieraat/vieraat/jhi/Perl/bin/perl'
+perl=''
 perladmin='yourname@yourhost.yourplace.com'
 perlpath='/opt/perl/bin/perl'
 pg='pg'
 phostname=''
 pidtype='pid_t'
 plibpth=''
+pm_apiversion='5.005'
 pmake=''
 pr=''
 prefix='/opt/perl'
 prefixexp='/opt/perl'
-privlib='/opt/perl/lib/5.005'
-privlibexp='/opt/perl/lib/5.005'
+privlib='/opt/perl/lib/5.6.0'
+privlibexp='/opt/perl/lib/5.6.0'
 prototype='define'
-ptrsize='4'
-randbits='31'
+ptrsize='8'
+quadkind='2'
+quadtype='long'
+randbits='48'
+randfunc='drand48'
+randseedtype='long'
 ranlib=':'
 rd_nodata='-1'
+revision='5'
 rm='rm'
 rmail=''
-runnm='false'
-scriptdir='/opt/perl/script'
-scriptdirexp='/opt/perl/script'
+runnm='true'
+sPRIEldbl='"E"'
+sPRIFldbl='"F"'
+sPRIGldbl='"G"'
+sPRIX64='"lX"'
+sPRId64='"ld"'
+sPRIeldbl='"e"'
+sPRIfldbl='"f"'
+sPRIgldbl='"g"'
+sPRIi64='"li"'
+sPRIo64='"lo"'
+sPRIu64='"lu"'
+sPRIx64='"lx"'
+sched_yield='sched_yield()'
+scriptdir='/opt/perl/bin'
+scriptdirexp='/opt/perl/bin'
 sed='sed'
+seedfunc='srand48'
+selectminbits='32'
 selecttype='fd_set *'
-sendmail='sendmail'
+sendmail=''
 sh='/bin/sh'
 shar=''
 sharpbang='#!'
@@ -501,14 +667,22 @@ shmattype='void *'
 shortsize='2'
 shrpenv=''
 shsharp='true'
-sig_name='ZERO HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM PROF WINCH IO PWR UNUSED IOT CLD POLL '
-sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "IOT", "CLD", "POLL", 0'
-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, 6, 17, 29, 0'
+sig_count='49'
+sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM IOINT STOP TSTP CONT CHLD TTIN TTOU AIO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 RESV RTMIN NUM34 NUM35 NUM36 NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 NUM43 NUM44 NUM45 NUM46 NUM47 MAX IOT LOST URG CLD IO POLL PTY PWR RTMAX '
+sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE", "KILL", "BUS", "SEGV", "SYS", "PIPE", "ALRM", "TERM", "IOINT", "STOP", "TSTP", "CONT", "CHLD", "TTIN", "TTOU", "AIO", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "INFO", "USR1", "USR2", "RESV", "RTMIN", "NUM34", "NUM35", "NUM36", "NUM37", "NUM38", "NUM39", "NUM40", "NUM41", "NUM42", "NUM43", "NUM44", "NUM45", "NUM46", "NUM47", "MAX", "IOT", "LOST", "URG", "CLD", "IO", "POLL", "PTY", "PWR", "RTMAX", 0'
+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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 6 6 16 20 23 23 23 29 48 '
+sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0'
 signal_t='void'
-sitearch='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
-sitearchexp='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
-sitelib='/opt/perl/lib/site_perl/5.005'
-sitelibexp='/opt/perl/lib/site_perl/5.005'
+sitearch='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi'
+sitearchexp='/opt/perl/lib/site_perl/5.6.0/alpha-dec_osf-thread-multi'
+sitebin='/opt/perl/bin'
+sitebinexp='/opt/perl/bin'
+sitelib='/opt/perl/lib/site_perl/5.6.0'
+sitelib_stem='/opt/perl/lib/site_perl'
+sitelibexp='/opt/perl/lib/site_perl/5.6.0'
+siteprefix='/opt/perl'
+siteprefixexp='/opt/perl'
+sizesize='8'
 sizetype='size_t'
 sleep=''
 smail=''
@@ -516,6 +690,7 @@ small=''
 so='so'
 sockethdr=''
 socketlib=''
+socksizetype='int'
 sort='sort'
 spackage='Perl5'
 spitshell='cat'
@@ -525,12 +700,13 @@ ssizetype='ssize_t'
 startperl='#!/opt/perl/bin/perl'
 startsh='#!/bin/sh'
 static_ext=' '
-stdchar='char'
-stdio_base='((fp)->_IO_read_base)'
-stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)'
-stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)'
+stdchar='unsigned char'
+stdio_base='((fp)->_base)'
+stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
+stdio_cnt='((fp)->_cnt)'
 stdio_filbuf=''
-stdio_ptr='((fp)->_IO_read_ptr)'
+stdio_ptr='((fp)->_ptr)'
+stdio_stream_array='_iob'
 strings='/usr/include/string.h'
 submit=''
 subversion='0'
@@ -538,7 +714,7 @@ sysman='/usr/man/man1'
 tail=''
 tar=''
 tbl=''
-tee='tee'
+tee=''
 test='test'
 timeincl='/usr/include/sys/time.h '
 timetype='time_t'
@@ -546,40 +722,85 @@ touch='touch'
 tr='tr'
 trnl='\n'
 troff=''
+u16size='2'
+u16type='unsigned short'
+u32size='4'
+u32type='unsigned int'
+u64size='8'
+u64type='unsigned long'
+u8size='1'
+u8type='unsigned char'
+uidformat='"u"'
+uidsign='1'
+uidsize='4'
 uidtype='uid_t'
 uname='uname'
 uniq='uniq'
+uquadtype='unsigned long'
+use5005threads='undef'
+use64bitall='define'
+use64bitint='define'
 usedl='define'
+useithreads='define'
+uselargefiles='define'
+uselongdouble='undef'
+usemorebits='undef'
+usemultiplicity='define'
 usemymalloc='n'
-usenm='false'
+usenm='true'
 useopcode='true'
 useperlio='undef'
 useposix='true'
 usesfio='false'
-useshrplib='false'
+useshrplib='true'
+usesocks='undef'
 usethreads='define'
+usevendorprefix='undef'
 usevfork='false'
 usrinc='/usr/include'
 uuname=''
-version='5.005'
+uvoformat='"lo"'
+uvsize='8'
+uvtype='unsigned long'
+uvuformat='"lu"'
+uvxformat='"lx"'
+vendorarch=''
+vendorarchexp=''
+vendorbin=''
+vendorbinexp=''
+vendorlib=''
+vendorlib_stem=''
+vendorlibexp=''
+vendorprefix=''
+vendorprefixexp=''
+version='5.6.0'
 vi=''
 voidflags='15'
 xlibpth='/usr/lib/386 /lib/386'
+xs_apiversion='5.6.0'
 zcat=''
 zip='zip'
 # Configure command line arguments.
 config_arg0='Configure'
-config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE'
-config_argc=9
+config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Duse64bitint -Duselargefiles -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE'
+config_argc=11
 config_arg1='-Dprefix=/opt/perl'
 config_arg2='-Doptimize=-O'
 config_arg3='-Dusethreads'
-config_arg4='-Dcf_by=yourname'
-config_arg5='-Dcf_email=yourname@yourhost.yourplace.com'
-config_arg6='-Dperladmin=yourname@yourhost.yourplace.com'
-config_arg7='-Dmydomain=.yourplace.com'
-config_arg8='-Dmyhostname=yourhost'
-config_arg9='-dE'
-PATCHLEVEL=5
-SUBVERSION=0
-CONFIG=true
+config_arg4='-Duse64bitint'
+config_arg5='-Duselargefiles'
+config_arg6='-Dcf_by=yourname'
+config_arg7='-Dcf_email=yourname@yourhost.yourplace.com'
+config_arg8='-Dperladmin=yourname@yourhost.yourplace.com'
+config_arg9='-Dmydomain=.yourplace.com'
+config_arg10='-Dmyhostname=yourhost'
+config_arg11='-dE'
+PERL_REVISION=5
+PERL_VERSION=6
+PERL_SUBVERSION=0
+PERL_API_REVISION=5
+PERL_API_VERSION=5
+PERL_API_SUBVERSION=0
+CONFIGDOTSH=true
+# Variables propagated from previous config.sh file.
+pp_sys_cflags='ccflags="$ccflags -DNO_EFF_ONLY_OK"'

contrib/perl5/Porting/findvars

@@ -11,15 +11,17 @@ chop $pat if $pat =~ /\|$/;
 
 # grep
 while (<>) {
-    if (/^(.*?)\b($pat)\b(.*)$/o) {
-        my $head = "$1#$2#";
-        $_ = $3;
-        while (/^(.*?)\b($pat)\b(.*)$/o) {
-            $head .= "$1#$2#";
-            $_ = $3;
-        }
-	print "$ARGV\:$.\:$head$_\n";
-    }
+    print "$ARGV\:$.\:$_" if s/\b($pat)\b/#$1#/og;
+# this variant might useful if the transformation is more complicated
+#    if (/^(.*?)\b($pat)\b(.*)$/o) {
+#        my $head = "$1#$2#";
+#        $_ = $3;
+#        while (/^(.*?)\b($pat)\b(.*)$/o) {
+#            $head .= "$1#$2#";
+#            $_ = $3;
+#        }
+#	print "$ARGV\:$.\:$head$_\n";
+#    }
 }
 continue {
     close ARGV if eof;
@@ -238,7 +240,6 @@ osname
 pad_reset_pending
 padix
 padix_floor
-parsehook
 patchlevel
 patleave
 pending_ident

contrib/perl5/Porting/genlog

@@ -12,7 +12,7 @@
 #
 # Outputs the changelist to stdout.
 #
-# Gurusamy Sarathy <gsar@umich.edu>
+# Gurusamy Sarathy <gsar@activestate.com>
 #
 
 use Text::Wrap;
@@ -107,8 +107,9 @@ EOT
 		my $files = $files{$branch}{$kind};
 		# don't show large branches and integrations
 		$files = ["($kind " . scalar(@$files) . ' files)']
-		    if (@$files > 25
-		        && ( $kind eq 'integrate' || $kind eq 'branch'));
+		    if (@$files > 25 && ($kind eq 'integrate'
+		    			 || $kind eq 'branch'))
+		       || @$files > 100;
 	        print wrap(sprintf("%12s ", $editkind{$kind}),
 			   sprintf("%12s ", $editkind{$kind}),
 			   "@$files\n");

contrib/perl5/Porting/makerel

@@ -20,19 +20,14 @@ die "Must be in root of the perl source tree.\n"
 open PATCHLEVEL,"<patchlevel.h" or die;
 my @patchlevel_h = <PATCHLEVEL>;
 close PATCHLEVEL;
-my $patchlevel_h = join "", grep { /^#define/ } @patchlevel_h;
+my $patchlevel_h = join "", grep { /^#\s*define/ } @patchlevel_h;
 print $patchlevel_h;
-$patchlevel = $1 if $patchlevel_h =~ /PATCHLEVEL\s+(\d+)/;
-$subversion = $1 if $patchlevel_h =~ /SUBVERSION\s+(\d+)/;
+$revision = $1 if $patchlevel_h =~ /PERL_REVISION\s+(\d+)/;
+$patchlevel = $1 if $patchlevel_h =~ /PERL_VERSION\s+(\d+)/;
+$subversion = $1 if $patchlevel_h =~ /PERL_SUBVERSION\s+(\d+)/;
 die "Unable to parse patchlevel.h" unless $subversion >= 0;
-$vers = sprintf("5.%03d", $patchlevel);
-$vms_vers = sprintf("5_%03d", $patchlevel);
-if ($subversion) {
-    $vers.= sprintf( "_%02d", $subversion);
-    $vms_vers.= sprintf( "%02d", $subversion);
-} else {
-    $vms_vers.= "  ";
-}
+$vers = sprintf("%d.%d.%d", $revision, $patchlevel, $subversion);
+$vms_vers = sprintf("%d_%d_%d", $revision, $patchlevel, $subversion);
 
 # fetch list of local patches
 my (@local_patches, @lpatch_tags, $lpatch_tags);
@@ -41,7 +36,7 @@ my (@local_patches, @lpatch_tags, $lpatch_tags);
 @lpatch_tags   = map  {  /^\s*,"(\w+)/ } @local_patches;
 $lpatch_tags   = join "-", @lpatch_tags;
 
-$perl = "perl$vers";
+$perl = "perl-$vers";
 $reldir = "$perl";
 $reldir .= "-$lpatch_tags" if $lpatch_tags;
 
@@ -93,7 +88,6 @@ my @exe = qw(
     installperl
     installman
     keywords.pl
-    myconfig
     opcode.pl
     perly.fixer
     t/TEST
@@ -107,6 +101,27 @@ my @exe = qw(
 );
 system("chmod +x @exe");
 
+my @writables = qw(
+    embed.h
+    embedvar.h
+    ext/B/B/Asmdata.pm
+    ext/ByteLoader/byterun.c
+    ext/ByteLoader/byterun.h
+    global.sym
+    keywords.h
+    lib/warnings.pm
+    objXSUB.h
+    opcode.h
+    pp.sym
+    pp_proto.h
+    regnodes.h
+    warnings.h
+    win32/config_H.bc
+    win32/config_H.gc
+    win32/config_H.vc
+);
+system("chmod +w @writables");
+
 print "Adding CRs to DOSish files...\n";
 my @crlf = qw(
     djgpp/configure.bat

contrib/perl5/Porting/p4d2p

@@ -4,7 +4,7 @@
 # reads a perforce style diff on stdin and outputs appropriate headers
 # so the diff can be applied with the patch program
 #
-# Gurusamy Sarathy <gsar@umich.edu>
+# Gurusamy Sarathy <gsar@activestate.com>
 #
 
 BEGIN {

contrib/perl5/Porting/p4desc

@@ -0,0 +1,118 @@
+#!/usr/bin/perl -wpi.bak
+
+#
+# Munge "p4 describe ..." output to include new files.
+#
+# Gurusamy Sarathy <gsar@activestate.com>
+#
+
+use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles);
+
+BEGIN {
+    $0 =~ s|^.*/||;
+    $p4port = $ENV{P4PORT} || 'localhost:1666';
+    for (@ARGV) {
+        if ($p4port =~ /^\s+$/) {
+	   $p4port = $_;
+	}
+        elsif (/^-p(.*)$/) {
+	    $p4port = $1 || ' ';
+	}
+	elsif (/^-v$/) {
+	    $v++;
+	}
+	elsif (/^-h/) {
+	    $h++;
+	}
+	else {
+	    push @files, $_;
+	}
+    }
+    unless (@files) { @files = '-'; undef $^I; }
+    @ARGV = @files;
+    if ($h) {
+	print STDERR <<USAGE;
+Usage: $0 [-p \$P4PORT] [-v] [-h] [files]
+
+	-p host:port	p4 port (e.g. myhost:1666)
+	-h		print this help
+	-v		output progress messages
+
+A smart 'cat'.  When fed the spew from "p4 describe ..." on STDIN,
+spits it right out on STDOUT, followed by patches for any new files
+detected in the spew.  Can also be used to edit insitu a bunch of
+files containing said spew.
+
+WARNING: Currently only emits unified diffs.
+
+Examples:
+	p4 describe -du 123 | $0 > change-123.desc
+	p4 describe -du 123 | $0 | p4d2p > change-123.patch
+
+USAGE
+	exit(0);
+    }
+    $thisfile = "";
+}
+
+
+if ($ARGV ne $thisfile) {
+    warn "processing patchfile [$ARGV]\n" unless $ARGV eq '-';
+    $thisfile = $ARGV;
+}
+
+my $cur = m|^Affected files| ... m|^Differences|;
+
+# while we are within range
+if ($cur) {
+    if (m{^\.\.\. (//depot/.+?#\d+) (add|branch)$}) {
+	my $newfile = $1;
+	push @addfiles, $newfile;
+	warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/;
+    }
+    warn "file [$file] line [$cur] file# [$fnum]\n" if $v;
+}
+
+if (/^Change (\d+) by/) {
+    $_ = "\n\n" . $_ if $change;	# start of a new change list
+    $change = $1;
+    my $new = newfiles();
+    if ($new) {
+	$_ = $new . $_;
+    }
+}
+
+if (eof) {
+    $_ .= newfiles();
+}
+
+sub newfiles {
+    my $addfile;
+    my $ret = "";
+    for $addfile (@addfiles) {
+	my $type = `p4 -p $p4port files '$addfile'`;
+	if ($?) {
+	    warn "$0: `p4 -p $p4port print '$addfile'` failed, status[$?]\n";
+	    next;
+	}
+	$type =~ m|^//.*\((.+)\)$| or next;
+	$type = $1;
+	unless ($type =~ /text/) {
+	    $ret .= "\n==== $addfile ($type) ====\n\n";
+	    next;
+	}
+	my @new = `p4 -p $p4port print '$addfile'`;
+	if ($?) {
+	    die "$0: `p4 -p $p4port print '$addfile'` failed, status[$?]\n";
+	}
+	my $desc = shift @new;		# discard initial description
+	$ret .= "\n==== $addfile ($type) ====\n\n";
+	my $lines = "," . @new;
+	$lines = "" if @new < 2;
+	$ret .= "\@\@ -0,0 +1$lines \@\@\n";
+	$ret .= join("+","",@new);
+	$ret .= "\n\\ No newline at end of file\n" if $ret !~ /\n$/;
+    }
+    @addfiles = ();
+    return $ret;
+}

contrib/perl5/Porting/patching.pod

@@ -30,7 +30,7 @@ attempt to make everybody's life easier.
 
 The most common problems appear to be patches being mangled by certain
 mailers (I won't name names, but most of these seem to be originating on
-boxes running a certain popular commercial operating system). Other problems
+boxes running a certain popular commercial operating system).  Other problems
 include patches not rooted in the appropriate place in the directory structure,
 and patches not produced using standard utilities (such as diff).
 
@@ -52,7 +52,7 @@ First, back up the original files.  This can't be stressed enough,
 back everything up _first_.
 
 Also, please create patches against a clean distribution of the perl source.
-This insures that everyone else can apply your patch without clobbering their
+This ensures that everyone else can apply your patch without clobbering their
 source tree.
 
 =item diff
@@ -63,15 +63,18 @@ respectively, unified diffs (where the changed line appears immediately next
 to the original) and context diffs (where several lines surrounding the changes
 are included).  See the manpage for diff for more details.
 
-Also, the preferred method for patching is -
+The preferred method for creating a unified diff suitable for feeding
+to the patch program is:
 
-C<diff [C<-c> | C<-u>] E<lt>old-fileE<gt> E<lt>new-fileE<gt>>
+	diff -u old-file new-file > patch-file
 
-Note the order of files.
+Note the order of files.  See below for how to create a patch from
+two directory trees.
 
-Also, if your patch is to the core (rather than to a module) it
-is better to create it as a context diff as some machines have
-broken patch utilities that choke on unified diffs.
+If your patch is for wider consumption, it may be better to create it as
+a context diff as some machines have broken patch utilities that choke on
+unified diffs.  A context diff is made using C<diff -c> rather than
+C<diff -u>.
 
 GNU diff has many desirable features not provided by most vendor-supplied
 diffs.  Some examples using GNU diff:
@@ -94,23 +97,34 @@ diffs.  Some examples using GNU diff:
 
 =item Directories
 
-Patches should be generated from the source root directory, not from the
-directory that the patched file resides in.  This insures that the maintainer
-patches the proper file and avoids name collisions (especially common when trying
-to apply patches to files that appear in both $src_root/ext/* and $src_root/lib/*).
-It is better to diff the file in $src_root/ext than the file in $src_root/lib.
+IMPORTANT: Patches should be generated from the source root directory, not
+from the directory that the patched file resides in.  This ensures that the
+maintainer patches the proper file.
+
+Many files in the distribution are derivative--avoid patching them.
+Patch the originals instead.  Most utilities (like perldoc) are in
+this category, i.e. patch utils/perldoc.PL rather than utils/perldoc.
+Similarly, don't create patches for files under $src_root/ext from
+their copies found in $install_root/lib.  If you are unsure about the
+proper location of a file that may have gotten copied while building
+the source distribution, consult the C<MANIFEST>.
 
 =item Filenames
 
 The most usual convention when submitting patches for a single file is to make
 your changes to a copy of the file with the same name as the original.  Rename
-the original file in such a way that it is obvious what is being patched ($file~ or
-$file.old seem to be popular).
+the original file in such a way that it is obvious what is being patched
+($file.dist or $file.old seem to be popular).
 
-If you are submitting patches that affect multiple files then you should backup
-the entire directory tree (to $source_root.old/ for example).  This will allow
-C<diff C<-c> E<lt>old-dirE<gt> E<lt>new-dirE<gt>> to create all the patches
-at once.
+If you are submitting patches that affect multiple files then you should
+backup the entire directory tree (to $source_root.old/ for example).  This
+will allow C<diff -ruN old-dir new-dir> to create all the patches at once.
+
+=item Try it yourself
+
+Just to make sure your patch "works", be sure to apply it to the Perl
+distribution, rebuild everything, and make sure the testsuite runs
+without incident.
 
 =back
 
@@ -125,7 +139,7 @@ the patch corrects.  If it is a code patch (rather than a documentation
 patch) you should also include a small test case that illustrates the
 bug.
 
-=item Direction for application
+=item Directions for application
 
 You should include instructions on how to properly apply your patch.
 These should include the files affected, any shell scripts or commands
@@ -150,15 +164,35 @@ side of adding too many comments than too few.
 
 =item Style
 
-Please follow the indentation style and nesting style in use in the
-block of code that you are patching.
+In general, please follow the particular style of the code you are patching.
+
+In particular, follow these general guidelines for patching Perl sources:
+
+    8-wide tabs (no exceptions!)
+    4-wide indents for code, 2-wide indents for nested CPP #defines
+    try hard not to exceed 79-columns
+    ANSI C prototypes
+    uncuddled elses and "K&R" style for indenting control constructs
+    no C++ style (//) comments, most C compilers will choke on them
+    mark places that need to be revisited with XXX (and revisit often!)
+    opening brace lines up with "if" when conditional spans multiple
+        lines; should be at end-of-line otherwise
+    in function definitions, name starts in column 0 (return value is on
+        previous line)
+    single space after keywords that are followed by parens, no space
+        between function name and following paren
+    avoid assignments in conditionals, but if they're unavoidable, use
+        extra paren, e.g. "if (a && (b = c)) ..."
+    "return foo;" rather than "return(foo);"
+    "if (!foo) ..." rather than "if (foo == FALSE) ..." etc.
+
 
 =item Testsuite
 
 When submitting a patch you should make every effort to also include
 an addition to perl's regression tests to properly exercise your
 patch.  Your testsuite additions should generally follow these
-guidelines (courtesy of Gurusamy Sarathy (gsar@engin.umich.edu))-
+guidelines (courtesy of Gurusamy Sarathy <gsar@activestate.com>):
 
 	Know what you're testing.  Read the docs, and the source.
 	Tend to fail, not succeed.
@@ -173,16 +207,16 @@ guidelines (courtesy of Gurusamy Sarathy (gsar@engin.umich.edu))-
 	  do use them, make sure that you cover _all_ perl platforms.
 	Unlink any temporary files you create.
 	Promote unforeseen warnings to errors with $SIG{__WARN__}.
-	Be sure to use the libraries and modules shipped with version 
+	Be sure to use the libraries and modules shipped with the version 
           being tested, not those that were already installed.
 	Add comments to the code explaining what you are testing for.
 	Make updating the '1..42' string unnecessary.  Or make sure that 
           you update it.
-	Test _all_ behaviors of a given operator, library, or function-
-	  All optional arguments
-	  Return values in various contexts (boolean, scalar, list, lvalue)
-	  Use both global and lexical variables
-	  Don't forget the exceptional, pathological cases.
+	Test _all_ behaviors of a given operator, library, or function:
+	  - All optional arguments
+	  - Return values in various contexts (boolean, scalar, list, lvalue)
+	  - Use both global and lexical variables
+	  - Don't forget the exceptional, pathological cases.
 
 =back
 
@@ -196,7 +230,7 @@ patch, didn't you).
 
 =head2 An example patch creation
 
-This should work for most patches-
+This should work for most patches:
 
       cp MANIFEST MANIFEST.old
       emacs MANIFEST
@@ -222,7 +256,7 @@ word wraps your patch or that MIME encodes it.  Both of these leave
 the patch essentially worthless to the maintainer.
 
 If you have no choice in mailers and no way to get your hands on a
-better one there is, of course, a perl solution.  Just do this-
+better one there is, of course, a perl solution.  Just do this:
 
       perl -ne 'print pack("u*",$_)' patch > patch.uue
 
@@ -234,27 +268,37 @@ and post patch.uue with a note saying to unpack it using
 
 The subject line on your patch should read
 
-[PATCH]5.xxx_xx (Area) Description
+    [PATCH 5.xxx_xx AREA] Description
 
-where the x's are replaced by the appropriate version number,
-area is a short keyword identifying what area of perl you are
-patching, and description is a very brief summary of the
+where the x's are replaced by the appropriate version number.
+The description should be a very brief but accurate summary of the
 problem (don't forget this is an email header).
 
-Examples-
+Examples:
 
-[PATCH]5.004_04 (DOC) fix minor typos
+    [PATCH 5.004_04 DOC] fix minor typos
 
-[PATCH]5.004_99 (CORE) New warning for foo() when frobbing
+    [PATCH 5.004_99 CORE] New warning for foo() when frobbing
 
-[PATCH]5.005_42 (CONFIG) Added support for fribnatz 1.5
+    [PATCH 5.005_42 CONFIG] Added support for fribnatz 1.5
+
+The name of the file being patched makes for a poor subject line if
+no other descriptive text accompanies it.
 
 =item Where to send your patch
 
-If your patch is for the perl core it should be sent perlbug@perl.org.
+If your patch is for a specific bug in the Perl core, it should be sent
+using the perlbug utility.  Don't forget to describe the problem and the
+fix adequately.
+
 If it is a patch to a module that you downloaded from CPAN you should
 submit your patch to that module's author.
 
+If your patch addresses one of the items described in perltodo.pod,
+please discuss your approach B<before> you make the patch at
+<perl5-porters@perl.org>.  Be sure to browse the archives of past
+discussions (see perltodo.pod for archive locations).
+
 =back
 
 =head2 Applying a patch
@@ -270,19 +314,21 @@ to your perl distribution.
 
 =item patch C<-p>
 
-It is generally easier to apply patches with the C<-p> argument to
-patch.  This helps reconcile differing paths between the machine the
-patch was created on and the machine on which it is being applied.
+It is generally easier to apply patches with the C<-p N> argument to
+patch (where N is the number of path components to skip in the files
+found in the headers).  This helps reconcile differing paths between
+the machine the patch was created on and the machine on which it is
+being applied.
 
 =item Cut and paste
 
-_Never_ cut and paste a patch into your editor.  This usually clobbers
+B<Never> cut and paste a patch into your editor.  This usually clobbers
 the tabs and confuses patch.
 
 =item Hand editing patches
 
-Avoid hand editing patches as this frequently screws up the whitespace
-in the patch and confuses the patch program.
+Avoid hand editing patches as this almost always screws up the line
+numbers and offsets in the patch, making it useless.
 
 =back
 

contrib/perl5/Porting/patchls

@@ -17,7 +17,7 @@ use Text::Tabs qw(expand unexpand);
 use strict;
 use vars qw($VERSION);
 
-$VERSION = 2.08;
+$VERSION = 2.11;
 
 sub usage {
 die qq{
@@ -35,6 +35,7 @@ die qq{
            (F has \$ appended unless it contains a /).
     -e     Expect patched files to Exist (relative to current directory)
            Will print warnings for files which don't. Also affects -4 option.
+    -      Read patch from STDIN
   other options for special uses:
     -I     just gather and display summary Information about the patches.
     -4     write to stdout the PerForce commands to prepare for patching.
@@ -93,7 +94,7 @@ my %cat_title = (
     'UTIL'	=> 'UTILITIES',
     'OTHER'	=> 'OTHER CHANGES',
     'EXT'	=> 'EXTENSIONS',
-    'UNKNOWN'	=> 'UNKNOWN - NO FILES PATCH',
+    'UNKNOWN'	=> 'UNKNOWN - NO FILES PATCHED',
 );
 
 
@@ -131,7 +132,11 @@ sub get_meta_info {
 # Style 2:
 #	--- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
 #	+++ perl5.004-bc/mg.c   Sun Jun 08 11:56:08 1997
-#	@@ -656,9 +656,27 @@
+#	@@ .. @@
+# or for deletions
+#	--- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
+#	+++ /dev/null   Sun Jun 08 11:56:08 1997
+#	@@ ... @@
 # or (rcs, note the different date format)
 #	--- 1.18	1997/05/23 19:22:04
 #	+++ ./pod/perlembed.pod	1997/06/03 21:41:38
@@ -145,13 +150,19 @@ my $in;
 my $ls;
 my $prevline = '';
 my $prevtype = '';
-my (@removed, @added);
+my (%removed, %added);
 my $prologue = 1;	# assume prologue till patch or /^exit\b/ seen
 
 
 foreach my $argv (@ARGV) {
     $in = $argv;
-    unless (open F, "<$in") {
+    if (-d $in) {
+	warn "Ignored directory $in\n";
+	next;
+    }
+    if ($in eq "-") {
+      *F = \*STDIN;
+    } elsif (not open F, "<$in") {
 	warn "Unable to open $in: $!\n";
 	next;
     }
@@ -163,8 +174,8 @@ foreach my $argv (@ARGV) {
 	    # not an interesting patch line
 	    # but possibly meta-information or prologue
 	    if ($prologue) {
-		push @added, $1     if /^touch\s+(\S+)/;
-		push @removed, $1   if /^rm\s+(?:-f)?\s*(\S+)/;
+		$added{$1}   = 1    if /^touch\s+(\S+)/;
+		$removed{$1} = 1    if /^rm\s+(?:-f)?\s*(\S+)/;
 		$prologue = 0       if /^exit\b/;
 	    }
 	    get_meta_info($ls, $_) if $::opt_m;
@@ -182,7 +193,7 @@ foreach my $argv (@ARGV) {
 	# to the file which describes the problem being fixed.
 	if (/^Index:\s+(.*)/) {
 	    my $f;
-	    foreach $f (split(/ /, $1)) { add_file($ls, $f) }
+	    foreach $f (split(/ /, $1)) { add_patched_file($ls, $f) }
 	    next;
 	}
 
@@ -190,7 +201,13 @@ foreach my $argv (@ARGV) {
 	    or	($type eq '+++' and $prevtype eq '---')	# Style 2
 	) {
 	    if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) {	# double check
-		add_file($ls, $1);
+		if ($1 eq "/dev/null") {
+		    $prevline =~ /^[-+*]{3} (\S+)\s*/;
+		    add_deleted_file($ls, $1);
+		}
+		else {
+		    add_patched_file($ls, $1);
+		}
 	    }
 	    else {
 		warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
@@ -226,7 +243,7 @@ foreach my $argv (@ARGV) {
     }
 
     # if we don't have a title for -m then use the file name
-    $ls->{Title}{$in}=1 if $::opt_m
+    $ls->{Title}{"Untitled: $in"}=1 if $::opt_m
 	and !$ls->{Title} and $ls->{out};
 
     $ls->{category} = $::opt_c
@@ -263,16 +280,18 @@ if ($::opt_f) {		# filter out patches based on -f <regexp>
 
 if ($::opt_4) {
     my $tail = ($::opt_5) ? "|| exit 1" : "";
-    print map { "p4 delete $_$tail\n" } @removed if @removed;
-    print map { "p4 add    $_$tail\n" } @added   if @added;
+    print map { "p4 delete $_$tail\n" } sort keys %removed if %removed;
+    print map { "p4 add    $_$tail\n" } sort keys %added   if %added;
     my @patches = sort grep { $_->{is_in} } @ls;
     my @no_outs = grep { keys %{$_->{out}} == 0 } @patches;
     warn "Warning: Some files contain no patches:",
 	join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs;
+
     my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
-    delete @patched{@added};
+    delete @patched{keys %added};
     my @patched = sort keys %patched;
     foreach(@patched) {
+	next if $removed{$_};
 	my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
 	print "p4 $edit   $_$tail\n";
     }
@@ -312,8 +331,8 @@ if ($::opt_I) {
 	    print "\n";
 	}
     }
-    print "Added files:   @added\n"   if @added;
-    print "Removed files: @removed\n" if @removed;
+    print "Added files:   ".join(" ",sort keys %added  )."\n" if %added;
+    print "Removed files: ".join(" ",sort keys %removed)."\n" if %removed;
     exit 0+@missing;
 }
 
@@ -353,12 +372,15 @@ exit 0;
 # ---
 
 
-sub add_file {
+sub add_patched_file {
     my $ls = shift;
-	print "add_file '$_[0]'\n" if $::opt_d;
-    my $out = trim_name(shift);
+	my $raw_name = shift;
+    my $action = shift || 1;	# 1==patched, 2==deleted
 
-    $ls->{out}->{$out} = 1;
+    my $out = trim_name($raw_name);
+    print "add_patched_file '$out' ($raw_name, $action)\n" if $::opt_d;
+
+    $ls->{out}->{$out} = $action;
 
     warn "$out patched but not present\n" if $::opt_e && !-f $out;
 
@@ -371,13 +393,24 @@ sub add_file {
     $i->{out}->{$in} = 1;
 }
 
+sub add_deleted_file {
+    my $ls = shift;
+	my $raw_name = shift;
+    my $out = trim_name($raw_name);
+    print "add_deleted_file '$out' ($raw_name)\n" if $::opt_d;
+	$removed{$out} = 1;
+    #add_patched_file(@_[0,1], 2);
+}
+
 
 sub trim_name {		# reduce/tidy file paths from diff lines
     my $name = shift;
-    $name = "$name ($in)" if $name eq "/dev/null";
     $name =~ s:\\:/:g;	# adjust windows paths
     $name =~ s://:/:g;	# simplify (and make win \\share into absolute path)
-    if (defined $::opt_p) {
+    if ($name eq "/dev/null") {
+	# do nothing (XXX but we need a way to record deletions)
+    }
+    elsif (defined $::opt_p) {
 	# strip on -p levels of directory prefix
 	my $dc = $::opt_p;
 	$name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
@@ -385,7 +418,7 @@ sub trim_name {		# reduce/tidy file paths from diff lines
     else {	# try to strip off leading path to perl directory
 	# if absolute path, strip down to any *perl* directory first
 	$name =~ s:^/.*?perl.*?/::i;
-	$name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i;
+	$name =~ s:.*(perl|maint)[-_]?5?[._]?[-_a-z0-9.+]*/::i;
 	$name =~ s:^\./::;
     }
     return $name;
@@ -436,7 +469,9 @@ sub list_files_by_patch {
     # a twisty maze of little options
     my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
     print "$name$cat: "	unless ($::opt_h and !$::opt_v) or !"$name$cat";
-    print join('',"\n",@meta) if @meta;
+    my $sep = "\n";
+    $sep = "" if @show_meta==1 && $::opt_c && $::opt_h;
+    print join('', $sep, @meta) if @meta;
 
     return if $::opt_m && !$show_meta{Files};
     my @v = sort PATORDER keys %{ $ls->{out} };
@@ -467,7 +502,7 @@ sub categorize_files {
 	$c{UTIL} += 10,next  if m:^(utils|x2p|h2pl)/:;
 	$c{PORT1}+= 15,next  if m:^win32:;
 	$c{PORT2} += 15,next
-	    if m:^(cygwin32|os2|plan9|qnx|vms)/:
+	    if m:^(cygwin|os2|plan9|qnx|vms)/:
 	    or m:^(hints|Porting|ext/DynaLoader)/:
 	    or m:^README\.:;
 	$c{EXT}  += 10,next

contrib/perl5/Porting/pumpkin.pod

@@ -8,8 +8,8 @@ There is no simple synopsis, yet.
 
 =head1 DESCRIPTION
 
-This document attempts to begin to describe some of the
-considerations involved in patching and maintaining perl.
+This document attempts to begin to describe some of the considerations
+involved in patching, porting, and maintaining perl.
 
 This document is still under construction, and still subject to
 significant changes.  Still, I hope parts of it will be useful,
@@ -47,93 +47,68 @@ Archives of the list are held at:
 
 =head1 How are Perl Releases Numbered?
 
-Perl version numbers are floating point numbers, such as 5.004.
-(Observations about the imprecision of floating point numbers for
-representing reality probably have more relevance than you might
-imagine :-) The major version number is 5 and the '004' is the
-patchlevel.  (Questions such as whether or not '004' is really a minor
-version number can safely be ignored.:)
+Beginning with v5.6.0, even versions will stand for maintenance releases
+and odd versions for development releases, i.e., v5.6.x for maintenance
+releases, and v5.7.x for development releases.  Before v5.6.0, subversions
+_01 through _49 were reserved for bug-fix maintenance releases, and
+subversions _50 through _99 for unstable development versions.
 
-The version number is available as the magic variable $],
-and can be used in comparisons, e.g.
+For example, in v5.6.1, the revision number is 5, the version is 6,
+and 1 is the subversion.
 
-	print "You've got an old perl\n" if $] < 5.002;
+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
+can still be used in comparisons.
 
-You can also require particular version (or later) with
+	print "You've got an old perl\n" if $] < 5.005_03;
 
-	use 5.002;
+In addition, the version is also available as a string in $^V.
+
+	print "You've got a new perl\n" if $^V and $^V ge v5.6.0;
+
+You can also require particular version (or later) with:
+
+        use 5.006;
+
+or using the new syntax available only from v5.6 onward:
+
+	use v5.6.0;
 
 At some point in the future, we may need to decide what to call the
 next big revision.  In the .package file used by metaconfig to
 generate Configure, there are two variables that might be relevant:
-$baserev=5.0 and $package=perl5.   At various times, I have suggested
-we might change them to $baserev=5.1 and $package=perl5.1 if want
-to signify a fairly major update.  Or, we might want to jump to perl6.
-Let's worry about that problem when we get there.
+$baserev=5 and $package=perl5.
 
-=head2 Subversions
-
-In addition, there may be "developer" sub-versions available.  These
-are not official releases.  They may contain unstable experimental
-features, and are subject to rapid change.  Such developer
-sub-versions are numbered with sub-version numbers.  For example,
-version 5.003_04 is the 4'th developer version built on top of
-5.003.  It might include the _01, _02, and _03 changes, but it
-also might not.  Sub-versions are allowed to be subversive. (But see
-the next section for recent changes.)
-
-These sub-versions can also be used as floating point numbers, so
-you can do things such as
-
-	print "You've got an unstable perl\n" if $] == 5.00303;
-
-You can also require particular version (or later) with
-
-	use 5.003_03;    # the "_" is optional
-
-Sub-versions produced by the members of perl5-porters are usually
-available on CPAN in the F<src/5.0/unsupported> directory.
+Perl releases produced by the members of perl5-porters are usually
+available on CPAN in the F<src/5.0/maint> and F<src/5.0/devel>
+directories.
 
 =head2 Maintenance and Development Subversions
 
-As an experiment, starting with version 5.004, subversions _01 through
-_49 will be reserved for bug-fix maintenance releases, and subversions
-_50 through _99 will be available for unstable development versions.
-
-The separate bug-fix track is being established to allow us an easy
-way to distribute important bug fixes without waiting for the
-developers to untangle all the other problems in the current
-developer's release.
+The first rule of maintenance work is "First, do no harm."
 
 Trial releases of bug-fix maintenance releases are announced on
 perl5-porters. Trial releases use the new subversion number (to avoid
 testers installing it over the previous release) and include a 'local
-patch' entry in patchlevel.h.
+patch' entry in patchlevel.h. The distribution file contains the
+string C<MAINT_TRIAL> to make clear that the file is not meant for
+public consumption.
 
-Watch for announcements of maintenance subversions in
-comp.lang.perl.announce.
+In general, the names of official distribution files for the public
+always match the regular expression:
 
-The first rule of maintenance work is "First, do no harm."
+    ^perl\d+\.(\d+)\.\d+(-MAINT_TRIAL_\d+)\.tar\.gz$
 
-=head2 Why such a complicated scheme?
+C<$1> in the pattern is always an even number for maintenance
+versions, and odd for developer releases.
 
-Two reasons, really.  At least.
-
-First, we need some way to identify and release collections of patches
-that are known to have new features that need testing and exploration.  The
-subversion scheme does that nicely while fitting into the
-C<use 5.004;> mold.
-
-Second, since most of the folks who help maintain perl do so on a
-free-time voluntary basis, perl development does not proceed at a
-precise pace, though it always seems to be moving ahead quickly.
-We needed some way to pass around the "patch pumpkin" to allow
-different people chances to work on different aspects of the
-distribution without getting in each other's way.  It wouldn't be
-constructive to have multiple people working on incompatible
-implementations of the same idea.  Instead what was needed was
-some kind of "baton" or "token" to pass around so everyone knew
-whose turn was next.
+In the past it has been observed that pumkings tend to invent new
+naming conventions on the fly. If you are a pumpking, before you
+invent a new name for any of the three types of perl distributions,
+please inform the guys from the CPAN who are doing indexing and
+provide the trees of symlinks and the like. They will have to know
+I<in advance> what you decide.
 
 =head2 Why is it called the patch pumpkin?
 
@@ -155,7 +130,7 @@ No one was allowed to make backups unless they had the "backup pumpkin".
 
 The name has stuck.
 
-=head1 Philosophical Issues in Patching Perl
+=head1 Philosophical Issues in Patching and Porting Perl
 
 There are no absolute rules, but there are some general guidelines I
 have tried to follow as I apply patches to the perl sources.
@@ -174,6 +149,16 @@ generalized the process of building libperl so that NeXT and SVR4 users
 could still get their work done, but others could build a shared
 libperl if they wanted to as well.
 
+Contain your changes carefully.  Assume nothing about other operating
+systems, not even closely related ones.  Your changes must not affect
+other platforms.
+
+Spy shamelessly on how similar patching or porting issues have been
+settled elsewhere.
+
+If feasible, try to keep filenames 8.3-compliant to humor those poor
+souls that get joy from running Perl under such dire limitations.
+
 =head2 Seek consensus on major changes
 
 If you are making big changes, don't do it in secret.  Discuss the
@@ -196,6 +181,88 @@ that the machine-specific #ifdef's may not be valid across major
 releases of the operating system.  Further, the feature-specific tests
 may help out folks on another platform who have the same problem.
 
+=head2 Machine-specific files
+
+=over 4
+
+=item source code
+
+If you have many machine-specific #defines or #includes, consider
+creating an "osish.h" (os2ish.h, vmsish.h, and so on) and including
+that in perl.h.  If you have several machine-specific files (function
+emulations, function stubs, build utility wrappers) you may create a
+separate subdirectory (djgpp, win32) and put the files in there.
+Remember to update C<MANIFEST> when you add files.
+
+If your system supports dynamic loading but none of the existing
+methods at F<ext/DynaLoader/dl_*.xs> work for you, you must write
+a new one.  Study the existing ones to see what kind of interface
+you must supply.
+
+=item build hints
+
+There are two kinds of hints: hints for building Perl and hints for
+extensions.   The former live in the C<hints> subdirectory, the latter
+in C<ext/*/hints> subdirectories.
+
+The top level hints are Bourne-shell scripts that set, modify and
+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
+miniperl has been built) and control the building of their respective
+extensions.  They can be used to for example manipulate compilation
+and linking flags.
+
+=item build and installation Makefiles, scripts, and so forth
+
+Sometimes you will also need to tweak the Perl build and installation
+procedure itself, like for example F<Makefile.SH> and F<installperl>.
+Tread very carefully, even more than usual.  Contain your changes
+with utmost care.
+
+=item test suite
+
+Many of the tests in C<t> subdirectory assume machine-specific things
+like existence of certain functions, something about filesystem
+semantics, certain external utilities and their error messages.  Use
+the C<$^O> and the C<Config> module (which contains the results of the
+Configure run, in effect the C<config.sh> converted to Perl) to either
+skip (preferably not) or customize (preferable) the tests for your
+platform.
+
+=item modules
+
+Certain standard modules may need updating if your operating system
+sports for example a native filesystem naming.  You may want to update
+some or all of the modules File::Basename, File::Spec, File::Path, and
+File::Copy to become aware of your native filesystem syntax and
+peculiarities.
+
+=item documentation
+
+If your operating system comes from outside UNIX you almost certainly
+will have differences in the available operating system functionality
+(missing system calls, different semantics, whatever).  Please
+document these at F<pod/perlport.pod>.  If your operating system is
+the first B<not> to have a system call also update the list of
+"portability-bewares" at the beginning of F<pod/perlfunc.pod>.
+
+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.
+
+You may also want to write a separate F<.pod> file for your operating
+system to tell about existing mailing lists, os-specific modules,
+documentation, whatever.  Please name these along the lines of
+F<perl>I<youros>.pod.  [unfinished: where to put this file (the pod/
+subdirectory, of course: but more importantly, which/what index files
+should be updated?)]
+
+=back
+
 =head2 Allow for lots of testing
 
 We should never release a main version without testing it as a
@@ -211,7 +278,7 @@ that some of those things will be just plain broken and need to be fixed,
 but, in general, we ought to try to avoid breaking widely-installed
 things.
 
-=head2 Automate generation of derivative files
+=head2 Automated generation of derivative files
 
 The F<embed.h>, F<keywords.h>, F<opcode.h>, and F<perltoc.pod> files
 are all automatically generated by perl scripts.  In general, don't
@@ -219,11 +286,14 @@ patch these directly; patch the data files instead.
 
 F<Configure> and F<config_h.SH> are also automatically generated by
 B<metaconfig>.  In general, you should patch the metaconfig units
-instead of patching these files directly.  However, very minor changes to
-F<Configure> may be made in between major sync-ups with the metaconfig
-units, which tends to be complicated operations.  But be careful, this
-can quickly spiral out of control.  Running metaconfig is not really
-hard.
+instead of patching these files directly.  However, very minor changes
+to F<Configure> may be made in between major sync-ups with the
+metaconfig units, which tends to be complicated operations.  But be
+careful, this can quickly spiral out of control.  Running metaconfig
+is not really hard.
+
+Also F<Makefile> is automatically produced from F<Makefile.SH>.
+In general, look out for all F<*.SH> files.
 
 Finally, the sample files in the F<Porting/> subdirectory are
 generated automatically by the script F<U/mksample> included 
@@ -411,6 +481,9 @@ 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>.
+
 Some additional notes from Larry on this:
 
 Don't forget to regenerate perly_c.diff.
@@ -520,8 +593,8 @@ things that need to be fixed in Configure.
 
 =head2 VMS-specific updates
 
-If you have changed F<perly.y>, then you may want to update
-F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>.
+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>.
 
 The Perl version number appears in several places under F<vms>.
 It is courteous to update these versions.  For example, if you are
@@ -628,6 +701,42 @@ supports dynamic loading, you can also test static loading with
 You can also hand-tweak your config.h to try out different #ifdef
 branches.
 
+=head1 Running Purify
+
+Purify is a commercial tool that is helpful in identifying memory
+overruns, wild pointers, memory leaks and other such badness.  Perl
+must be compiled in a specific way for optimal testing with Purify.
+
+Use the following commands to test perl with Purify:
+
+	sh Configure -des -Doptimize=-g -Uusemymalloc -Dusemultiplicity \
+	    -Accflags=-DPURIFY
+	setenv PURIFYOPTIONS "-chain-length=25"
+	make all pureperl
+	cd t
+	ln -s ../pureperl perl
+	setenv PERL_DESTRUCT_LEVEL 5
+	./perl TEST
+
+Disabling Perl's malloc allows Purify to monitor allocations and leaks
+more closely; using Perl's malloc will make Purify report most leaks
+in the "potential" leaks category.  Enabling the multiplicity option
+allows perl to clean up thoroughly when the interpreter shuts down, which
+reduces the number of bogus leak reports from Purify.  The -DPURIFY
+enables any Purify-specific debugging code in the sources.
+
+Purify outputs messages in "Viewer" windows by default.  If you don't have
+a windowing environment or if you simply want the Purify output to
+unobtrusively go to a log file instead of to the interactive window,
+use the following options instead:
+
+	setenv PURIFYOPTIONS "-chain-length=25 -windows=no -log-file=perl.log \
+	    -append-logfile=yes"
+
+The only currently known leaks happen when there are compile-time errors
+within eval or require.  (Fixing these is non-trivial, unfortunately, but
+they must be fixed eventually.)
+
 =head1 Common Gotcha's
 
 =over 4
@@ -1008,33 +1117,6 @@ may find metaconfig's units clumsy to work with.
 
 =back
 
-=head2 @INC search order
-
-By default, the list of perl library directories in @INC is the
-following:
-
-    $archlib
-    $privlib
-    $sitearch
-    $sitelib
-
-Specifically, on my Solaris/x86 system, I run
-B<sh Configure -Dprefix=/opt/perl> and I have the following
-directories:
-
-    /opt/perl/lib/i86pc-solaris/5.00307
-    /opt/perl/lib
-    /opt/perl/lib/site_perl/i86pc-solaris
-    /opt/perl/lib/site_perl
-
-That is, perl's directories come first, followed by the site-specific
-directories.
-
-The site libraries come second to support the usage of extensions
-across perl versions.  Read the relevant section in F<INSTALL> for
-more information.  If we ever make $sitearch version-specific, this
-topic could be revisited.
-
 =head2 Why isn't there a directory to override Perl's library?
 
 Mainly because no one's gotten around to making one.  Note that
@@ -1158,18 +1240,6 @@ what I came up with off the top of my head.
 
 =over 4
 
-=item installprefix
-
-I think we ought to support
-
-    Configure -Dinstallprefix=/blah/blah
-
-Currently, we support B<-Dprefix=/blah/blah>, but the changing the install
-location has to be handled by something like the F<config.over> trick
-described in F<INSTALL>.  AFS users also are treated specially.
-We should probably duplicate the metaconfig prefix stuff for an
-install prefix.
-
 =item Configure -Dsrc=/blah/blah
 
 We should be able to emulate B<configure --srcdir>.  Tom Tromey
@@ -1178,16 +1248,6 @@ the dist-users mailing list along these lines.  They have been folded
 back into the main distribution, but various parts of the perl
 Configure/build/install process still assume src='.'.
 
-=item Directory for vendor-supplied modules?
-
-If a vendor supplies perl, but wants to leave $siteperl and $sitearch
-for the local user to use, where should the vendor put vendor-supplied
-modules (such as Tk.so?)  If the vendor puts them in $archlib, then
-they need to be updated each time the perl version is updated.
-Perhaps we need a set of libries $vendorperl and $vendorarch that
-track $apiversion (like the $sitexxx directories do) rather than
-just $version (like the main perl directory).
-
 =item Hint file fixes
 
 Various hint files work around Configure problems.  We ought to fix
@@ -1198,47 +1258,6 @@ Configure so that most of them aren't needed.
 Some of the hint file information (particularly dynamic loading stuff)
 ought to be fed back into the main metaconfig distribution.
 
-=item Catch GNU Libc "Stub" functions
-
-Some functions (such as lchown()) are present in libc, but are
-unimplmented.  That is, they always fail and set errno=ENOSYS.
-
-Thomas Bushnell provided the following sample code and the explanation
-that follows:
-
-    /* System header to define __stub macros and hopefully few prototypes,
-	which can conflict with char FOO(); below.  */
-    #include <assert.h>
-    /* Override any gcc2 internal prototype to avoid an error.  */
-    /* We use char because int might match the return type of a gcc2
-	builtin and then its argument prototype would still apply.  */
-    char FOO();
-
-    int main() {
-
-    /* The GNU C library defines this for functions which it implements
-	to always fail with ENOSYS.  Some functions are actually named
-	something starting with __ and the normal name is an alias.  */
-    #if defined (__stub_FOO) || defined (__stub___FOO)
-    choke me
-    #else
-    FOO();
-    #endif
-
-    ; return 0; }
-
-The choice of <assert.h> is essentially arbitrary.  The GNU libc
-macros are found in <gnu/stubs.h>.  You can include that file instead
-of <assert.h> (which itself includes <gnu/stubs.h>) if you test for
-its existence first.  <assert.h> is assumed to exist on every system,
-which is why it's used here.  Any GNU libc header file will include
-the stubs macros.  If either __stub_NAME or __stub___NAME is defined,
-then the function doesn't actually exist.  Tests using <assert.h> work
-on every system around.
-
-The declaration of FOO is there to override builtin prototypes for
-ANSI C functions.
-
 =back
 
 =head2 Probably good ideas waiting for round tuits
@@ -1320,4 +1339,4 @@ All opinions expressed herein are those of the authorZ<>(s).
 
 =head1 LAST MODIFIED
 
-$Id: pumpkin.pod,v 1.22 1998/07/22 16:33:55 doughera Released $
+$Id: pumpkin.pod,v 1.23 2000/01/13 19:45:13 doughera Released $

contrib/perl5/README

@@ -1,7 +1,7 @@
 
 			   Perl Kit, Version 5.0
 
-		       Copyright 1989-1999, Larry Wall
+		       Copyright 1989-2000, Larry Wall
 			    All rights reserved.
 
     This program is free software; you can redistribute it and/or modify
@@ -50,9 +50,9 @@
 --------------------------------------------------------------------------
 
 Perl is a language that combines some of the features of C, sed, awk
-and shell.  See the manual page for more hype.  There are also two Nutshell
-Handbooks published by O'Reilly & Assoc.  See pod/perlbook.pod
-for more information.
+and shell.  See the manual page for more hype.  There are also many Perl
+books available, covering a wide variety of topics, from various publishers.
+See pod/perlbook.pod for more information.
 
 Please read all the directions below before you proceed any further, and
 then follow them carefully.
@@ -62,16 +62,10 @@ in MANIFEST.
 
 Installation
 
-1) Detailed instructions are in the file INSTALL which you should read.
-In brief, the following should work on most systems:
-	rm -f config.sh
-	sh Configure
-	make
-	make test
-	make install
-For most systems, it should be safe to accept all the Configure defaults.
-(It is recommended that you accept the defaults the first time you build
-or if you have any problems building.)
+1) Detailed instructions are in the file "INSTALL", which you should
+read if you are either installing on a system resembling Unix
+or porting perl to another platform.  For non-Unix platforms, see the
+corresponding README.
 
 2) Read the manual entries before running perl.
 
@@ -81,18 +75,16 @@ If you have a problem, there's someone else out there who either has had
 or will have the same problem.  It's usually helpful if you send the
 output of the "myconfig" script in the main perl directory.
 
-If you've succeeded in compiling perl, the perlbug script in the utils/
+If you've succeeded in compiling perl, the perlbug script in the "utils"
 subdirectory can be used to help mail in a bug report.
 
 If possible, send in patches such that the patch program will apply them.
 Context diffs are the best, then normal diffs.  Don't send ed scripts--
 I've probably changed my copy since the version you have.
 
-Watch for perl patches in comp.lang.perl.announce.  Patches will generally
-be in a form usable by the patch program.  If you are just now bringing
-up perl and aren't sure how many patches there are, write to me and I'll
-send any you don't have.  Your current patch level is shown in
-patchlevel.h.
+The latest versions of perl are always available on the various CPAN
+(Comprehensive Perl Archive Network) sites around the world.
+See <URL:http://www.perl.com/CPAN/src/>.
 
 
 Just a personal note:  I want you to know that I create nice things like this

contrib/perl5/README.Y2K

@@ -0,0 +1,47 @@
+The following information about Perl and the year 2000 is a modified
+version of the information that can be found in the Frequently Asked
+Question (FAQ) documents.
+
+Does Perl have a year 2000 problem?  Is Perl Y2K compliant?
+
+Short answer: No, Perl does not have a year 2000 problem.  Yes,
+       Perl is Y2K compliant (whatever that means).  The
+       programmers you've hired to use it, however, probably are
+       not.  If you want perl to complain when your programmers
+       create programs with certain types of possible year 2000
+       problems, a build option allows you to turn on warnings.
+
+Long answer: The question belies a true understanding of the
+       issue.  Perl is just as Y2K compliant as your pencil
+       --no more, and no less.  Can you use your pencil to write
+       a non-Y2K-compliant memo?  Of course you can.  Is that
+       the pencil's fault?  Of course it isn't.
+
+       The date and time functions supplied with perl (gmtime and
+       localtime) supply adequate information to determine the
+       year well beyond 2000 (2038 is when trouble strikes for
+       32-bit machines).  The year returned by these functions
+       when used in an array context is the year minus 1900.  For
+       years between 1910 and 1999 this happens to be a 2-digit
+       decimal number. To avoid the year 2000 problem simply do
+       not treat the year as a 2-digit number.  It isn't.
+
+       When gmtime() and localtime() are used in scalar context
+       they return a timestamp string that contains a fully-
+       expanded year.  For example, $timestamp =
+       gmtime(1005613200) sets $timestamp to "Tue Nov 13 01:00:00
+       2001".  There's no year 2000 problem here.
+
+       That doesn't mean that Perl can't be used to create non-
+       Y2K compliant programs.  It can.  But so can your pencil.
+       It's the fault of the user, not the language.  At the risk
+       of inflaming the NRA: ``Perl doesn't break Y2K, people
+       do.''  See http://language.perl.com/news/y2k.html for a
+       longer exposition.
+
+       If you want perl to warn you when it sees a program which
+       catenates a number with the string "19" -- a common
+       indication of a year 2000 problem -- build perl using the
+       Configure option  "-Accflags=-DPERL_Y2KWARN".
+       (See the file INSTALL for more information about building
+       perl.)

contrib/perl5/README.posix-bc

@@ -0,0 +1,131 @@
+This is a first ported perl for the POSIX subsystem in BS2000 VERSION
+'V121', OSD V3.1, POSIX Shell V03.1A55.  It may work on other
+versions, but that's the one we've tested it on.
+
+You may need the following GNU programs in order to install perl:
+
+gzip:
+
+We used version 1.2.4, which could be installed out of the box with
+one failure during 'make check'.
+
+bison:
+
+The yacc coming with BS2000 POSIX didn't work for us.  So we had to
+use bison.  We had to make a few changes to perl in order to use the
+pure (reentrant) parser of bison.  We used version 1.25, but we had to
+add a few changes due to EBCDIC.
+
+
+UNPACKING:
+==========
+
+To extract an ASCII tar archive on BS2000 POSIX you need an ASCII
+filesystem (we used the mountpoint /usr/local/ascii for this).  Now
+you extract the archive in the ASCII filesystem without I/O-conversion:
+
+cd /usr/local/ascii
+export IO_CONVERSION=NO
+gunzip < /usr/local/src/perl.tar.gz | pax -r
+
+You may ignore the error message for the first element of the archive
+(this doesn't look like a tar archive / skipping to next file...),
+it's only the directory which will be made anyway.
+
+After extracting the archive you copy the whole directory tree to your
+EBCDIC filesystem.  This time you use I/O-conversion:
+
+cd /usr/local/src
+IO_CONVERSION=YES
+cp -r /usr/local/ascii/perl5.005_02 ./
+
+
+COMPILING:
+==========
+
+There is a "hints" file for posix-bc that specifies the correct values
+for most things.  The major problem is (of course) the EBCDIC character
+set.
+
+Configure did everything except the perl parser.
+
+Because of our problems with the native yacc we used GNU bison to
+generate a pure (=reentrant) parser for perly.y.  So our yacc is
+really the following script:
+
+-----8<-----/usr/local/bin/yacc-----8<-----
+#! /usr/bin/sh
+
+# Bison as a reentrant yacc:
+
+# save parameters:
+params=""
+while [[ $# -gt 1 ]]; do
+    params="$params $1"
+    shift
+done
+
+# add flag %pure_parser:
+
+tmpfile=/tmp/bison.$$.y
+echo %pure_parser > $tmpfile
+cat $1 >> $tmpfile
+
+# call bison:
+
+echo "/usr/local/bin/bison --yacc $params $1\t\t\t(Pure Parser)"
+/usr/local/bin/bison --yacc $params $tmpfile
+
+# cleanup:
+
+rm -f $tmpfile
+-----8<----------8<-----
+
+We still use the normal yacc for a2p.y though!!!  We made a softlink
+called byacc to distinguish between the two versions:
+
+ln -s /usr/bin/yacc /usr/local/bin/byacc
+ 
+We build perl using both GNU make and the native make.
+
+
+TESTING:
+========
+
+We still got a few errors during 'make test'.  Most of them are the
+result of using bison.  Bison prints 'parser error' instead of 'syntax
+error', so we may ignore them.  One error in the test op/regexp (and
+op/regexp_noamp) seems a bit critical, the result was an 'Out of
+memory' (core dump with op/regexp_noamp).  The following list shows
+our errors, your results may differ:
+
+op/misc.............FAILED tests 45-46
+op/pack.............FAILED tests 58-60
+op/regexp...........FAILED tests 405-492      (core dump)
+op/regexp_noamp.....FAILED tests 405-492      (core dump)
+pragma/overload.....FAILED tests 152-153, 170-171
+pragma/subs.........FAILED tests 1-2
+pragma/warning......FAILED tests 121, 127, 130, 142
+lib/cgi-html........dubious, FAILED tests 1-17 (ALL)
+lib/complex.........FAILED tests 264, 484
+lib/dumper..........FAILED tests MANY
+Failed 7/190 test scripts, 96.32% okay. 234/6549 subtests failed, 96.43% okay.
+
+
+INSTALLING:
+===========
+
+We have no nroff on BS2000 POSIX (yet), so we ignored any errors while
+installing the documentation.
+
+
+USING PERL:
+===========
+
+BS2000 POSIX doesn't support the shebang notation
+('#!/usr/local/bin/perl'), so you have to use the following lines
+instead:
+
+: # use perl
+    eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
+        if $running_under_some_shell;

contrib/perl5/README.threads

@@ -1,53 +1,89 @@
-NOTE
+NOTE: This documentation describes the style of threading that was
+available in 5.005.  Perl v5.6 also has the early beginnings of
+interpreter-based threads support (which is what will be enabled by
+default when you simply ask for -Dusethreads).  However, be advised
+that interpreter threads cannot as yet be created from the Perl level
+yet.  If you're looking to create threads from within Perl, chances
+are you _don't_ want interpreter threads, but want the older support
+for threads described below, enabled with:
 
-Threading is a highly experimental feature.  There are still a 
-few race conditions that show up under high contention on SMP
+    sh Configure -Dusethreads -Duse5005threads
+
+The rest of this document only applies to the use5005threads style of
+threads.
+---------------------------------------------------------------------------
+
+Support for threading is still in the highly experimental stages.  There
+are known race conditions that show up under high contention on SMP
 machines.  Internal implementation is still subject to changes.
 It is not recommended for production use at this time.
 
+---------------------------------------------------------------------------
+
 Building
 
-If you want to build with multi-threading support and you are
-running one of the following:
+If your system is in the following list you should be able to just:
 
-  * Linux 2.x (with the LinuxThreads library installed: that's
-    the linuxthreads and linuxthreads-devel RPMs for RedHat)
-
-  * Digital UNIX 4.x
-
-  * Digital UNIX 3.x (Formerly DEC OSF/1), see additional note below
-
-  * Solaris 2.x for recentish x (2.5 is OK)
-
-  * IRIX 6.2 or newer. 6.2 will require a few os patches.
-    IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will
-    cause your machine to panic and crash when running threaded perl.
-    IRIX 6.3 and up should be OK. See lower down for patch details.
-
-then you should be able to use
-
-    ./Configure -Dusethreads -des
+    ./Configure -Dusethreads -Duse5005threads -des
     make
 
-and ignore the rest of this "Building" section. If it doesn't
-work or you are using another platform which you believe supports
-POSIX.1c threads then read on.  Additional information may be in
-a platform-specific "hints" file in the hints/ subdirectory.
+and ignore the rest of this "Building" section.  If not, continue
+from the "Problems" section.
 
-On other platforms that use Configure to build perl, omit the -d
-from your ./Configure arguments. For example, use:
+	* Linux 2.* (with the LinuxThreads library installed:
+	  that's the linuxthreads and linuxthreads-devel RPMs
+	  for RedHat)
 
-    ./Configure -Dusethreads
+	* Tru64 UNIX (formerly Digital UNIX formerly DEC OSF/1)
+	  (see additional note below)
+
+	* Solaris 2.* for recentish x (2.5 is OK)
+
+	* IRIX 6.2 or newer. 6.2 will require a few OS patches.
+	  IMPORTANT: Without patch 2401 (or its replacement),
+	  a kernel bug in IRIX 6.2 will cause your machine to
+	  panic and crash when running threaded perl.
+	  IRIX 6.3 and up should be OK. See lower down for patch details.
+
+	* AIX 4.1.5 or newer.
+
+	* FreeBSD 2.2.8 or newer.
+
+	* OpenBSD
+
+	* NeXTstep, OpenStep
+
+	* OS/2
+
+	* DOS DJGPP
+
+	* VM/ESA
+
+---------------------------------------------------------------------------
+
+Problems
+
+If the simple way doesn't work or you are using another platform which
+you believe supports POSIX.1c threads then read on.  Additional
+information may be in a platform-specific "hints" file in the hints/
+subdirectory.
+
+On platforms that use Configure to build perl, omit the -d from your
+./Configure arguments. For example, use:
+
+    ./Configure -Dusethreads -Duse5005threads
 
 When Configure prompts you for ccflags, insert any other arguments in
-there that your compiler needs to use POSIX threads. When Configure
-prompts you for linking flags, include any flags required for
-threading (usually nothing special is required here).  Finally, when
-COnfigure prompts you for libraries, include any necessary libraries
-(e.g. -lpthread).  Pay attention to the order of libraries.  It is
-probably necessary to specify your threading library *before* your
-standard C library, e.g.  it might be necessary to have -lpthread -lc,
-instead of -lc -lpthread.
+there that your compiler needs to use POSIX threads (-D_REENTRANT,
+-pthreads, -threads, -pthread, -thread, are good guesses). When
+Configure prompts you for linking flags, include any flags required
+for threading (usually nothing special is required here).  Finally,
+when Configure prompts you for libraries, include any necessary
+libraries (e.g. -lpthread).  Pay attention to the order of libraries.
+It is probably necessary to specify your threading library *before*
+your standard C library, e.g.  it might be necessary to have -lpthread
+-lc, instead of -lc -lpthread.  You may also need to use -lc_r instead
+of -lc.
 
 Once you have specified all your compiler flags, you can have Configure
 accept all the defaults for the remainder of the session by typing  &-d
@@ -71,7 +107,7 @@ For Digital Unix 4.x:
 
 For Digital Unix 3.x (Formerly DEC OSF/1):
     Add -DOLD_PTHREADS_API to ccflags
-    If compiling with the GNU cc compiler, remove -thread from ccflags
+    If compiling with the GNU cc compiler, remove -threads from ccflags
 
     (The following should be done automatically if you call Configure
       with the -Dusethreads option).
@@ -93,6 +129,7 @@ For IRIX:
     For IRIX 6.3 and 6.4 the pthreads should work out of the box.
     Thanks to Hannu Napari <Hannu.Napari@hut.fi> for the IRIX
     pthreads patches information.
+
 For AIX:
     (This should all be done automatically by the hint file).
     Change cc to xlc_r or cc_r.
@@ -107,6 +144,12 @@ For Win32:
 Now you can do a
     make
 
+When you succeed in compiling and testing ("make test" after your
+build) a threaded Perl in a platform previosuly unknown to support
+threaded perl, please let perlbug@perl.com know about your victory.
+Explain what you did in painful detail.
+
+---------------------------------------------------------------------------
 
 O/S specific bugs
 
@@ -138,8 +181,8 @@ has this fixed but the following patch can be applied to 0.5 for now:
 Building the Thread extension
 
 The Thread extension is now part of the main perl distribution tree.
-If you did Configure -Dusethreads then it will have been added to
-the list of extensions automatically.
+If you did Configure -Dusethreads -Duse5005threads then it will have been
+added to the list of extensions automatically.
 
 You can try some of the tests with
     cd ext/Thread
@@ -155,6 +198,7 @@ Try running the main perl test suite too. There are known
 failures for some of the DBM/DB extensions (if their underlying
 libraries were not compiled to be thread-aware).
 
+---------------------------------------------------------------------------
 
 Bugs
 
@@ -164,8 +208,7 @@ tested at all in recent times.)
 
 * There may still be races where bugs show up under contention.
 
-* Need to document "lock", Thread.pm, Queue.pm, ...
-
+---------------------------------------------------------------------------
 
 Debugging
 
@@ -178,6 +221,7 @@ have to delete the lines in perl.c which say
         DEBUG_S(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
     #endif
 
+---------------------------------------------------------------------------
 
 Background
 
@@ -287,3 +331,6 @@ Andy Dougherty <doughera@lafayette.edu>
 
 Other minor updates 10 Feb 1999 by
 Gurusamy Sarathy
+
+More platforms added 26 Jul 1999 by
+Jarkko Hietaniemi

contrib/perl5/Todo

@@ -1,3 +1,11 @@
+Always check out the latest perl5-porters discussions on these subjects
+before embarking on an implementation tour.
+
+Bugs
+	remove recursion in regular expression engine
+	fix memory leaks during compile failures
+	make signal handling safe
+
 Tie Modules
 	VecArray		Implement array using vec()
 	SubstrArray		Implement array using substr()
@@ -5,54 +13,80 @@ Tie Modules
 	ShiftSplice		Defines shift et al in terms of splice method
 
 Would be nice to have
-	pack "(stuff)*"
-	Contiguous bitfields in pack/unpack
+	pack "(stuff)*", "(stuff)?", "(stuff)+", "(stuff)4", ...
+	contiguous bitfields in pack/unpack
 	lexperl
-	Bundled perl preprocessor
-	Use posix calls internally where possible
+	bundled perl preprocessor/macro facility
+	    this would solve many of the syntactic nice-to-haves
+	use posix calls internally where possible
 	gettimeofday (possibly best left for a module?)
 	format BOTTOM
 	-i rename file only when successfully changed
-	All ARGV input should act like <>
+	all ARGV input should act like <>
 	report HANDLE [formats].
 	support in perlmain to rerun debugger
 	regression tests using __DIE__ hook
-	reference to compiled regexp
 	lexically scoped functions: my sub foo { ... }
-	lvalue functions
+		the basic concept is easy and sound,
+		the difficulties begin with self-referential
+		and mutually referential lexical subs: how to
+		declare the subs?
+	lexically scoped typeglobs? (lexical I/O handles work now)
+        wantlvalue?  more generalized want()/caller()?
+	named prototypes: sub foo ($foo, @bar) { ... } ?
 	regression/sanity tests for suidperl
-	Full 64 bit support (i.e. "long long")
-	Generalise Errno way of extracting cpp symbols and use that in
-	    Errno and Fcntl (ExtUtils::CppSymbol?)
+	iterators/lazy evaluation/continuations/first/
+	    first_defined/short-circuiting grep/??
+	    This is a very thorny and hotly debated subject,
+	    tread carefully and do your homework first
+	generalise Errno way of extracting cpp symbols and use that in
+	    Errno, Fcntl, POSIX (ExtUtils::CppSymbol?)
+	the _r-problem: for all the {set,get,end}*() system database
+	     calls (and a couple more: readdir, *rand*, crypt, *time,
+	     tmpnam) there are in many systems the _r versions
+	     to be used in re-entrant (=multithreaded) code
+	     Icky things: the _r API is not standardized and
+	     the _r-forms require per-thread data to store their state
+	memory profiler: turn malloc.c:Perl_get_mstats() into
+	    an extension (Devel::MProf?) that would return the malloc
+	    stats in a nice Perl datastructure (also a simple interface
+	    to return just the grand total would be good)
+	cross-compilation support
+	    host vs target: compile in the host, get the executable to
+	    the target, get the possible input files to the target,
+	    execute in the target (and do not assume a UNIXish shell
+	    in the target! e.g. no command redirection can be assumed),
+	    get possible output files back to to host.  this needs to work
+	    both during Configure and during the build.  You cannot assume
+	    shared filesystems between the host and the target (you may need
+	    e.g. ftp), executing the target executable may involve e.g. rsh
+	a way to make << and >> to shift bitvectors instead of numbers
 
 Possible pragmas
 	debugger
-	optimize (use less memory, CPU)
+	optimize (use less qw[memory cpu])
 
 Optimizations
 	constant function cache
 	switch structures
-	eval qw() at compile time
 	foreach(reverse...)
-	Set KEEP on constant split
-	Cache eval tree (unless lexical outer scope used (mark in &compiling?))
+	cache eval tree (unless lexical outer scope used (mark in &compiling?))
 	rcatmaybe
-	Shrink opcode tables via multiple implementations selected in peep
-	Cache hash value?  (Not a win, according to Guido)
-	Optimize away @_ where possible
+	shrink opcode tables via multiple implementations selected in peep
+	cache hash value?  (Not a win, according to Guido)
+	optimize away @_ where possible
+	tail recursion removal
 	"one pass" global destruction
-	Optimize sort by { $a <=> $b }
-	Rewrite regexp parser for better integrated optimization
+	rewrite regexp parser for better integrated optimization
 	LRU cache of regexp: foreach $pat (@pats) { foo() if /$pat/ }
 
 Vague possibilities
-	ref function in list context
+	ref function in list context?
 	make tr/// return histogram in list context?
-	Loop control on do{} et al
-	Explicit switch statements
+	loop control on do{} et al
+	explicit switch statements
 	built-in globbing
 	compile to real threaded code
 	structured types
 	autocroak?
-	Modifiable $1 et al
-
+	modifiable $1 et al

contrib/perl5/Todo-5.6

@@ -0,0 +1,156 @@
+Unicode support
+    finish byte <-> utf8 and localencoding <-> utf8 conversions
+    make substr($bytestr,0,0,$charstr) do the right conversion
+    add Unicode::Map equivivalent to core
+    add support for I/O disciplines
+        - a way to specify disciplines when opening things:
+	    open(F, "<:crlf :utf16", $file)
+        - a way to specify disciplines for an already opened handle:
+	    binmode(STDIN, ":slurp :raw")
+	- a way to set default disciplines for all handle constructors:
+	    use open IN => ":any", OUT => ":utf8", SYS => ":utf16"
+    eliminate need for "use utf8;"
+    autoload byte.pm when byte:: is seen by the parser
+    check uv_to_utf8() calls for buffer overflow
+    (see also "Locales", "Regexen", and "Miscellaneous")
+
+Multi-threading
+    support "use Thread;" under useithreads
+    add mechanism to:
+      - create new interpreter in a different thread
+      - exchange data between interpreters/threads
+      - share namespaces between interpreters/threads
+    work out consistent semantics for exit/die in threads
+    support for externally created threads?
+    Thread::Pool?
+
+Compiler
+    auto-produce executable
+    typed lexicals should affect B::CC::load_pad
+    workarounds to help Win32
+    END blocks need saving in compiled output
+    _AUTOLOAD prodding
+    fix comppadlist (names in comppad_name can have fake SvCUR
+	from where newASSIGNOP steals the field)
+
+Namespace cleanup
+    CPP-space:	  restrict what we export from headers when !PERL_CORE
+    header-space: move into CORE/perl/?
+    API-space:    complete the list of things that constitute public api
+
+Configure
+    fix the vicious cyclic multidependency of cc <-> libpth <-> loclibpth
+	libswanted <-> usethreads <-> use64bitint <-> use64bitall <->
+  	uselargefiles <-> ...  
+    make configuring+building away from source directory work (VPATH et al)
+	this is related to: cross-compilation configuring (see Todo)
+    _r support (see Todo for mode detailed description)
+    POSIX 1003.1 1996 Edition support--realtime stuff:
+	POSIX semaphores, message queues, shared memory, realtime clocks,
+	timers, signals (the metaconfig units mostly already exist for these)
+    UNIX98 support: reader-writer locks, realtime/asynchronous IO
+    IPv6 support: see RFC2292, RFC2553
+
+Long doubles
+    figure out where the PV->NV->PV conversion gets it wrong at least
+    in AIX and Tru64 (V5.0 and onwards) when using long doubles: see the
+    regexp tricks we had to insert to t/comp/use.t and t/lib/bigfltpm.t,
+     (?:9|8999\d+) and the like.
+
+64-bit support
+    Configure probe for quad_t, uquad_t, and (argh) u_quad_t, they might
+    be in some systems the only thing working as quadtype and uquadtype.
+
+Locales
+    deprecate traditional/legacy locales?
+    How do locales work across packages?
+    figure out how to support Unicode locales
+	suggestion: integrate the IBM Classes for Unicode (ICU)
+	http://oss.software.ibm.com/developerworks/opensource/icu/project/
+	and check out also the Locale Converter:
+	http://alphaworks.ibm.com/tech/localeconverter
+    ICU is "portable, open-source Unicode library with:
+    charset-independent locales (with multiple locales simultaneously
+    supported in same thread; character conversions; formatting/parsing
+    for numbers, currencies, date/time and messages; message catalogs
+    (resources) ; transliteration, collation, normalization, and text
+    boundaries (grapheme, word, line-break))".
+    There is also 'iconv', either from XPG4 or GNU (glibc).
+    iconv is about character set conversions.
+    Either ICU or iconv would be valuable to get integrated
+    into Perl, Configure already probes for libiconv and <iconv.h>. 
+
+Regexen
+   make RE engine thread-safe
+   a way to do full character set arithmetics: now one can do
+	addition, negate a whole class, and negate certain subclasses
+	(e.g. \D, [:^digit:]), but a more generic way to add/subtract/
+	intersect characters/classes, like described in the Unicode technical
+	report on Regular Expression Guidelines,
+	http://www.unicode.org/unicode/reports/tr18/
+	(amusingly, the TR notes that difference and intersection
+	 can be done using "Perl-style look-ahead")
+	difference syntax?  maybe [[:alpha:][^abc]] meaning
+	"all alphabetic expect a, b, and c"? or [[:alpha:]-[abc]]?
+	(maybe bad, as we explicitly disallow such 'ranges')
+	intersection syntax? maybe [[..]&[...]]?
+   POSIX [=bar=] and [.zap.] would nice too but there's no API for them
+   	=bar= could be done with Unicode, though, see the Unicode TR #15 about
+	normalization forms:
+	http://www.unicode.org/unicode/reports/tr15/
+	this is also a part of the Unicode 3.0:
+	http://www.unicode.org/unicode/uni2book/u2.html
+	executive summary: there are several different levels of 'equivalence'
+   approximate matching
+
+Security
+    use fchown, fchmod (and futimes?) internally when possible
+    use fchdir(how portable?)
+    create secure reliable portable temporary file modules
+    audit the standard utilities for security problems and fix them
+
+Reliable Signals
+    custom opcodes
+    alternate runops() for signal despatch
+    figure out how to die() in delayed sighandler
+    make Thread::Signal work under useithreads
+
+Win32 stuff
+    sort out the spawnvp() mess for system('a','b','c') compatibility
+    work out DLL versioning
+
+Miscellaneous
+    add new modules (Archive::Tar, Compress::Zlib, CPAN::FTP?)
+    sub-second sleep()? alarm()? time()? (integrate Time::HiRes?
+	Configure doesn't yet probe for usleep/nanosleep/ualarm but
+	the units exist)
+    floating point handling: nans, infinities, fp exception masks, etc.
+	at least the following interfaces exist: fp_classify(), fp_class(),
+	class(), isnan(), isinf(), isfinite(), finite(), isnormal(),
+	ordered(), fp_setmask(), fp_getmask(), fp_setround(), fp_getround(), 
+	ieeefp.h, fp_class.h.  There are metaconfig units for most of these.
+        Search for ifdef __osf__ in pp.c to find a temporary fix that
+	needs to be done right.
+    fix the basic arithmetics (+ - * / %) to preserve IVness/UVness if
+	both arguments are IVs/UVs
+    replace pod2html with new PodtoHtml? (requires other modules from CPAN)
+    automate testing with large parts of CPAN
+    Unicode collation? http://www.unicode.org/unicode/reports/tr10/
+    turn Cwd into an XS module?  (Configure already probes for getcwd())
+    mmap for speeding up input? (Configure already probes for the mmap family)
+    sendmsg, recvmsg? (Configure doesn't probe for these but the units exist)
+    setitimer, getitimer? (the metaconfig units exist)
+
+Ongoing
+    keep filenames 8.3 friendly, where feasible
+    upgrade to newer versions of all independently maintained modules
+    comprehensive perldelta.pod
+
+Documentation
+    describe new age patterns
+    update perl{guts,call,embed,xs} with additions, changes to API
+    convert more examples to use autovivified filehandles
+    document Win32 choices
+    spot-check all new modules for completeness
+    better docs for pack()/unpack()
+    reorg tutorials vs. reference sections

contrib/perl5/XSUB.h

@@ -1,13 +1,56 @@
+#ifndef _INC_PERL_XSUB_H
+#define _INC_PERL_XSUB_H 1
+
+/* first, some documentation for xsubpp-generated items */
+
+/*
+=for apidoc Amn|char*|CLASS
+Variable which is setup by C<xsubpp> to indicate the 
+class name for a C++ XS constructor.  This is always a C<char*>.  See C<THIS>.
+
+=for apidoc Amn|(whatever)|RETVAL
+Variable which is setup by C<xsubpp> to hold the return value for an 
+XSUB. This is always the proper type for the XSUB. See 
+L<perlxs/"The RETVAL Variable">.
+
+=for apidoc Amn|(whatever)|THIS
+Variable which is setup by C<xsubpp> to designate the object in a C++ 
+XSUB.  This is always the proper type for the C++ object.  See C<CLASS> and 
+L<perlxs/"Using XS With C++">.
+
+=for apidoc Amn|I32|items
+Variable which is setup by C<xsubpp> to indicate the number of 
+items on the stack.  See L<perlxs/"Variable-length Parameter Lists">.
+
+=for apidoc Amn|I32|ix
+Variable which is setup by C<xsubpp> to indicate which of an 
+XSUB's aliases was used to invoke it.  See L<perlxs/"The ALIAS: Keyword">.
+
+=for apidoc Am|SV*|ST|int ix
+Used to access elements on the XSUB's stack.
+
+=for apidoc AmU||XS
+Macro to declare an XSUB and its C parameter list.  This is handled by
+C<xsubpp>.
+
+=for apidoc Ams||dXSARGS
+Sets up stack and mark pointers for an XSUB, calling dSP and dMARK.  This
+is usually handled automatically by C<xsubpp>.  Declares the C<items>
+variable to indicate the number of items on the stack.
+
+=for apidoc Ams||dXSI32
+Sets up the C<ix> variable for an XSUB which has aliases.  This is usually
+handled automatically by C<xsubpp>.
+
+=cut
+*/
+
 #define ST(off) PL_stack_base[ax + (off)]
 
-#ifdef CAN_PROTOTYPE
-#ifdef PERL_OBJECT
-#define XS(name) void name(CV* cv, CPerlObj* pPerl)
+#if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
+#  define XS(name) __declspec(dllexport) void name(pTHXo_ CV* cv)
 #else
-#define XS(name) void name(CV* cv)
-#endif
-#else
-#define XS(name) void name(cv) CV* cv;
+#  define XS(name) void name(pTHXo_ CV* cv)
 #endif
 
 #define dXSARGS				\
@@ -15,6 +58,12 @@
 	I32 ax = mark - PL_stack_base + 1;	\
 	I32 items = sp - mark
 
+#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
+			     ? PAD_SV(PL_op->op_targ) : sv_newmortal())
+
+/* Should be used before final PUSHi etc. if not in PPCODE section. */
+#define XSprePUSH (sp = PL_stack_base + ax - 1)
+
 #define XSANY CvXSUBANY(cv)
 
 #define dXSI32 I32 ix = XSANY.any_i32
@@ -25,9 +74,86 @@
 #  define XSINTERFACE_CVT(ret,name) ret (*name)()
 #endif
 #define dXSFUNCTION(ret)		XSINTERFACE_CVT(ret,XSFUNCTION)
-#define XSINTERFACE_FUNC(ret,cv,f)	((XSINTERFACE_CVT(ret,))(f))
+#define XSINTERFACE_FUNC(ret,cv,f)	((XSINTERFACE_CVT(ret,cv))(f))
 #define XSINTERFACE_FUNC_SET(cv,f)	\
-		CvXSUBANY(cv).any_dptr = (void (*) _((void*)))(f)
+		CvXSUBANY(cv).any_dptr = (void (*) (pTHXo_ void*))(f)
+
+/* Simple macros to put new mortal values onto the stack.   */
+/* Typically used to return values from XS functions.       */
+
+/*
+=for apidoc Am|void|XST_mIV|int pos|IV iv
+Place an integer into the specified position C<pos> on the stack.  The
+value is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mNV|int pos|NV nv
+Place a double into the specified position C<pos> on the stack.  The value
+is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mPV|int pos|char* str
+Place a copy of a string into the specified position C<pos> on the stack. 
+The value is stored in a new mortal SV.
+
+=for apidoc Am|void|XST_mNO|int pos
+Place C<&PL_sv_no> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XST_mYES|int pos
+Place C<&PL_sv_yes> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XST_mUNDEF|int pos
+Place C<&PL_sv_undef> into the specified position C<pos> on the
+stack.
+
+=for apidoc Am|void|XSRETURN|int nitems
+Return from XSUB, indicating number of items on the stack.  This is usually
+handled by C<xsubpp>.
+
+=for apidoc Am|void|XSRETURN_IV|IV iv
+Return an integer from an XSUB immediately.  Uses C<XST_mIV>.
+
+=for apidoc Am|void|XSRETURN_NV|NV nv
+Return an double from an XSUB immediately.  Uses C<XST_mNV>.
+
+=for apidoc Am|void|XSRETURN_PV|char* str
+Return a copy of a string from an XSUB immediately.  Uses C<XST_mPV>.
+
+=for apidoc Ams||XSRETURN_NO
+Return C<&PL_sv_no> from an XSUB immediately.  Uses C<XST_mNO>.
+
+=for apidoc Ams||XSRETURN_YES
+Return C<&PL_sv_yes> from an XSUB immediately.  Uses C<XST_mYES>.
+
+=for apidoc Ams||XSRETURN_UNDEF
+Return C<&PL_sv_undef> from an XSUB immediately.  Uses C<XST_mUNDEF>.
+
+=for apidoc Ams||XSRETURN_EMPTY
+Return an empty list from an XSUB immediately.
+
+=for apidoc AmU||newXSproto
+Used by C<xsubpp> to hook up XSUBs as Perl subs.  Adds Perl prototypes to
+the subs.
+
+=for apidoc AmU||XS_VERSION
+The version identifier for an XS module.  This is usually
+handled automatically by C<ExtUtils::MakeMaker>.  See C<XS_VERSION_BOOTCHECK>.
+
+=for apidoc Ams||XS_VERSION_BOOTCHECK
+Macro to verify that a PM module's $VERSION variable matches the XS
+module's C<XS_VERSION> variable.  This is usually handled automatically by
+C<xsubpp>.  See L<perlxs/"The VERSIONCHECK: Keyword">.
+
+=cut
+*/
+
+#define XST_mIV(i,v)  (ST(i) = sv_2mortal(newSViv(v))  )
+#define XST_mNV(i,v)  (ST(i) = sv_2mortal(newSVnv(v))  )
+#define XST_mPV(i,v)  (ST(i) = sv_2mortal(newSVpv(v,0)))
+#define XST_mPVN(i,v,n)  (ST(i) = sv_2mortal(newSVpvn(v,n)))
+#define XST_mNO(i)    (ST(i) = &PL_sv_no   )
+#define XST_mYES(i)   (ST(i) = &PL_sv_yes  )
+#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)
 
 #define XSRETURN(off)					\
     STMT_START {					\
@@ -35,18 +161,10 @@
 	return;						\
     } STMT_END
 
-/* Simple macros to put new mortal values onto the stack.   */
-/* Typically used to return values from XS functions.       */
-#define XST_mIV(i,v)  (ST(i) = sv_2mortal(newSViv(v))  )
-#define XST_mNV(i,v)  (ST(i) = sv_2mortal(newSVnv(v))  )
-#define XST_mPV(i,v)  (ST(i) = sv_2mortal(newSVpv(v,0)))
-#define XST_mNO(i)    (ST(i) = &PL_sv_no   )
-#define XST_mYES(i)   (ST(i) = &PL_sv_yes  )
-#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)
- 
 #define XSRETURN_IV(v) STMT_START { XST_mIV(0,v);  XSRETURN(1); } STMT_END
 #define XSRETURN_NV(v) STMT_START { XST_mNV(0,v);  XSRETURN(1); } STMT_END
 #define XSRETURN_PV(v) STMT_START { XST_mPV(0,v);  XSRETURN(1); } STMT_END
+#define XSRETURN_PVN(v,n) STMT_START { XST_mPVN(0,v,n);  XSRETURN(1); } STMT_END
 #define XSRETURN_NO    STMT_START { XST_mNO(0);    XSRETURN(1); } STMT_END
 #define XSRETURN_YES   STMT_START { XST_mYES(0);   XSRETURN(1); } STMT_END
 #define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
@@ -55,7 +173,7 @@
 #define newXSproto(a,b,c,d)	sv_setpv((SV*)newXS(a,b,c), d)
 
 #ifdef XS_VERSION
-# define XS_VERSION_BOOTCHECK \
+#  define XS_VERSION_BOOTCHECK \
     STMT_START {							\
 	SV *tmpsv; STRLEN n_a;						\
 	char *vn = Nullch, *module = SvPV(ST(0),n_a);			\
@@ -63,95 +181,220 @@
 	    tmpsv = ST(1);						\
 	else {								\
 	    /* XXX GV_ADDWARN */					\
-	    tmpsv = perl_get_sv(form("%s::%s", module,			\
-				  vn = "XS_VERSION"), FALSE);		\
+	    tmpsv = get_sv(Perl_form(aTHX_ "%s::%s", module,		\
+				vn = "XS_VERSION"), FALSE);		\
 	    if (!tmpsv || !SvOK(tmpsv))					\
-		tmpsv = perl_get_sv(form("%s::%s", module,		\
-				      vn = "VERSION"), FALSE);		\
+		tmpsv = get_sv(Perl_form(aTHX_ "%s::%s", module,	\
+				    vn = "VERSION"), FALSE);		\
 	}								\
 	if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, n_a))))	\
-	    croak("%s object version %s does not match %s%s%s%s %_",	\
+	    Perl_croak(aTHX_ "%s object version %s does not match %s%s%s%s %"SVf,\
 		  module, XS_VERSION,					\
 		  vn ? "$" : "", vn ? module : "", vn ? "::" : "",	\
 		  vn ? vn : "bootstrap parameter", tmpsv);		\
     } STMT_END
 #else
-# define XS_VERSION_BOOTCHECK
+#  define XS_VERSION_BOOTCHECK
 #endif
 
-#ifdef PERL_CAPI
-#  define VTBL_sv		get_vtbl(want_vtbl_sv)
-#  define VTBL_env		get_vtbl(want_vtbl_env)
-#  define VTBL_envelem		get_vtbl(want_vtbl_envelem)
-#  define VTBL_sig		get_vtbl(want_vtbl_sig)
-#  define VTBL_sigelem		get_vtbl(want_vtbl_sigelem)
-#  define VTBL_pack		get_vtbl(want_vtbl_pack)
-#  define VTBL_packelem		get_vtbl(want_vtbl_packelem)
-#  define VTBL_dbline		get_vtbl(want_vtbl_dbline)
-#  define VTBL_isa		get_vtbl(want_vtbl_isa)
-#  define VTBL_isaelem		get_vtbl(want_vtbl_isaelem)
-#  define VTBL_arylen		get_vtbl(want_vtbl_arylen)
-#  define VTBL_glob		get_vtbl(want_vtbl_glob)
-#  define VTBL_mglob		get_vtbl(want_vtbl_mglob)
-#  define VTBL_nkeys		get_vtbl(want_vtbl_nkeys)
-#  define VTBL_taint		get_vtbl(want_vtbl_taint)
-#  define VTBL_substr		get_vtbl(want_vtbl_substr)
-#  define VTBL_vec		get_vtbl(want_vtbl_vec)
-#  define VTBL_pos		get_vtbl(want_vtbl_pos)
-#  define VTBL_bm		get_vtbl(want_vtbl_bm)
-#  define VTBL_fm		get_vtbl(want_vtbl_fm)
-#  define VTBL_uvar		get_vtbl(want_vtbl_uvar)
-#  define VTBL_defelem		get_vtbl(want_vtbl_defelem)
-#  define VTBL_regexp		get_vtbl(want_vtbl_regexp)
+#if 1		/* for compatibility */
+#  define VTBL_sv		&PL_vtbl_sv
+#  define VTBL_env		&PL_vtbl_env
+#  define VTBL_envelem		&PL_vtbl_envelem
+#  define VTBL_sig		&PL_vtbl_sig
+#  define VTBL_sigelem		&PL_vtbl_sigelem
+#  define VTBL_pack		&PL_vtbl_pack
+#  define VTBL_packelem		&PL_vtbl_packelem
+#  define VTBL_dbline		&PL_vtbl_dbline
+#  define VTBL_isa		&PL_vtbl_isa
+#  define VTBL_isaelem		&PL_vtbl_isaelem
+#  define VTBL_arylen		&PL_vtbl_arylen
+#  define VTBL_glob		&PL_vtbl_glob
+#  define VTBL_mglob		&PL_vtbl_mglob
+#  define VTBL_nkeys		&PL_vtbl_nkeys
+#  define VTBL_taint		&PL_vtbl_taint
+#  define VTBL_substr		&PL_vtbl_substr
+#  define VTBL_vec		&PL_vtbl_vec
+#  define VTBL_pos		&PL_vtbl_pos
+#  define VTBL_bm		&PL_vtbl_bm
+#  define VTBL_fm		&PL_vtbl_fm
+#  define VTBL_uvar		&PL_vtbl_uvar
+#  define VTBL_defelem		&PL_vtbl_defelem
+#  define VTBL_regexp		&PL_vtbl_regexp
+#  define VTBL_regdata		&PL_vtbl_regdata
+#  define VTBL_regdatum		&PL_vtbl_regdatum
 #  ifdef USE_LOCALE_COLLATE
-#    define VTBL_collxfrm	get_vtbl(want_vtbl_collxfrm)
-#  endif
-#  ifdef OVERLOAD
-#    define VTBL_amagic		get_vtbl(want_vtbl_amagic)
-#    define VTBL_amagicelem	get_vtbl(want_vtbl_amagicelem)
-#  endif
-#else
-#  define VTBL_sv		&vtbl_sv
-#  define VTBL_env		&vtbl_env
-#  define VTBL_envelem		&vtbl_envelem
-#  define VTBL_sig		&vtbl_sig
-#  define VTBL_sigelem		&vtbl_sigelem
-#  define VTBL_pack		&vtbl_pack
-#  define VTBL_packelem		&vtbl_packelem
-#  define VTBL_dbline		&vtbl_dbline
-#  define VTBL_isa		&vtbl_isa
-#  define VTBL_isaelem		&vtbl_isaelem
-#  define VTBL_arylen		&vtbl_arylen
-#  define VTBL_glob		&vtbl_glob
-#  define VTBL_mglob		&vtbl_mglob
-#  define VTBL_nkeys		&vtbl_nkeys
-#  define VTBL_taint		&vtbl_taint
-#  define VTBL_substr		&vtbl_substr
-#  define VTBL_vec		&vtbl_vec
-#  define VTBL_pos		&vtbl_pos
-#  define VTBL_bm		&vtbl_bm
-#  define VTBL_fm		&vtbl_fm
-#  define VTBL_uvar		&vtbl_uvar
-#  define VTBL_defelem		&vtbl_defelem
-#  define VTBL_regexp		&vtbl_regexp
-#  ifdef USE_LOCALE_COLLATE
-#    define VTBL_collxfrm	&vtbl_collxfrm
-#  endif
-#  ifdef OVERLOAD
-#    define VTBL_amagic		&vtbl_amagic
-#    define VTBL_amagicelem	&vtbl_amagicelem
+#    define VTBL_collxfrm	&PL_vtbl_collxfrm
 #  endif
+#  define VTBL_amagic		&PL_vtbl_amagic
+#  define VTBL_amagicelem	&PL_vtbl_amagicelem
 #endif
 
-#ifdef PERL_OBJECT
+#include "perlapi.h"
 #include "objXSUB.h"
-#ifndef NO_XSLOCKS
-#ifdef WIN32
-#include "XSlock.h"
-#endif  /* WIN32 */
-#endif  /* NO_XSLOCKS */
-#else
-#ifdef PERL_CAPI
-#include "perlCAPI.h"
+
+#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_GET_CONTEXT) && !defined(PERL_CORE)
+#  undef aTHX
+#  undef aTHX_
+#  define aTHX		PERL_GET_THX
+#  define aTHX_		aTHX,
 #endif
-#endif	/* PERL_OBJECT */
+
+#if (defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS)) && !defined(PERL_CORE)
+#  ifndef NO_XSLOCKS
+#    undef closedir
+#    undef opendir
+#    undef stdin
+#    undef stdout
+#    undef stderr
+#    undef feof
+#    undef ferror
+#    undef fgetpos
+#    undef ioctl
+#    undef getlogin
+#    undef setjmp
+#    undef getc
+#    undef ungetc
+#    undef fileno
+
+#    define mkdir		PerlDir_mkdir
+#    define chdir		PerlDir_chdir
+#    define rmdir		PerlDir_rmdir
+#    define closedir		PerlDir_close
+#    define opendir		PerlDir_open
+#    define readdir		PerlDir_read
+#    define rewinddir		PerlDir_rewind
+#    define seekdir		PerlDir_seek
+#    define telldir		PerlDir_tell
+#    define putenv		PerlEnv_putenv
+#    define getenv		PerlEnv_getenv
+#    define uname		PerlEnv_uname
+#    define stdin		PerlIO_stdin()
+#    define stdout		PerlIO_stdout()
+#    define stderr		PerlIO_stderr()
+#    define fopen		PerlIO_open
+#    define fclose		PerlIO_close
+#    define feof		PerlIO_eof
+#    define ferror		PerlIO_error
+#    define fclearerr		PerlIO_clearerr
+#    define getc		PerlIO_getc
+#    define fputc(c, f)		PerlIO_putc(f,c)
+#    define fputs(s, f)		PerlIO_puts(f,s)
+#    define fflush		PerlIO_flush
+#    define ungetc(c, f)	PerlIO_ungetc((f),(c))
+#    define fileno		PerlIO_fileno
+#    define fdopen		PerlIO_fdopen
+#    define freopen		PerlIO_reopen
+#    define fread(b,s,c,f)	PerlIO_read((f),(b),(s*c))
+#    define fwrite(b,s,c,f)	PerlIO_write((f),(b),(s*c))
+#    define setbuf		PerlIO_setbuf
+#    define setvbuf		PerlIO_setvbuf
+#    define setlinebuf		PerlIO_setlinebuf
+#    define stdoutf		PerlIO_stdoutf
+#    define vfprintf		PerlIO_vprintf
+#    define ftell		PerlIO_tell
+#    define fseek		PerlIO_seek
+#    define fgetpos		PerlIO_getpos
+#    define fsetpos		PerlIO_setpos
+#    define frewind		PerlIO_rewind
+#    define tmpfile		PerlIO_tmpfile
+#    define access		PerlLIO_access
+#    define chmod		PerlLIO_chmod
+#    define chsize		PerlLIO_chsize
+#    define close		PerlLIO_close
+#    define dup			PerlLIO_dup
+#    define dup2		PerlLIO_dup2
+#    define flock		PerlLIO_flock
+#    define fstat		PerlLIO_fstat
+#    define ioctl		PerlLIO_ioctl
+#    define isatty		PerlLIO_isatty
+#    define link                PerlLIO_link
+#    define lseek		PerlLIO_lseek
+#    define lstat		PerlLIO_lstat
+#    define mktemp		PerlLIO_mktemp
+#    define open		PerlLIO_open
+#    define read		PerlLIO_read
+#    define rename		PerlLIO_rename
+#    define setmode		PerlLIO_setmode
+#    define stat(buf,sb)	PerlLIO_stat(buf,sb)
+#    define tmpnam		PerlLIO_tmpnam
+#    define umask		PerlLIO_umask
+#    define unlink		PerlLIO_unlink
+#    define utime		PerlLIO_utime
+#    define write		PerlLIO_write
+#    define malloc		PerlMem_malloc
+#    define realloc		PerlMem_realloc
+#    define free		PerlMem_free
+#    define abort		PerlProc_abort
+#    define exit		PerlProc_exit
+#    define _exit		PerlProc__exit
+#    define execl		PerlProc_execl
+#    define execv		PerlProc_execv
+#    define execvp		PerlProc_execvp
+#    define getuid		PerlProc_getuid
+#    define geteuid		PerlProc_geteuid
+#    define getgid		PerlProc_getgid
+#    define getegid		PerlProc_getegid
+#    define getlogin		PerlProc_getlogin
+#    define kill		PerlProc_kill
+#    define killpg		PerlProc_killpg
+#    define pause		PerlProc_pause
+#    define popen		PerlProc_popen
+#    define pclose		PerlProc_pclose
+#    define pipe		PerlProc_pipe
+#    define setuid		PerlProc_setuid
+#    define setgid		PerlProc_setgid
+#    define sleep		PerlProc_sleep
+#    define times		PerlProc_times
+#    define wait		PerlProc_wait
+#    define setjmp		PerlProc_setjmp
+#    define longjmp		PerlProc_longjmp
+#    define signal		PerlProc_signal
+#    define getpid		PerlProc_getpid
+#    define htonl		PerlSock_htonl
+#    define htons		PerlSock_htons
+#    define ntohl		PerlSock_ntohl
+#    define ntohs		PerlSock_ntohs
+#    define accept		PerlSock_accept
+#    define bind		PerlSock_bind
+#    define connect		PerlSock_connect
+#    define endhostent		PerlSock_endhostent
+#    define endnetent		PerlSock_endnetent
+#    define endprotoent		PerlSock_endprotoent
+#    define endservent		PerlSock_endservent
+#    define gethostbyaddr	PerlSock_gethostbyaddr
+#    define gethostbyname	PerlSock_gethostbyname
+#    define gethostent		PerlSock_gethostent
+#    define gethostname		PerlSock_gethostname
+#    define getnetbyaddr	PerlSock_getnetbyaddr
+#    define getnetbyname	PerlSock_getnetbyname
+#    define getnetent		PerlSock_getnetent
+#    define getpeername		PerlSock_getpeername
+#    define getprotobyname	PerlSock_getprotobyname
+#    define getprotobynumber	PerlSock_getprotobynumber
+#    define getprotoent		PerlSock_getprotoent
+#    define getservbyname	PerlSock_getservbyname
+#    define getservbyport	PerlSock_getservbyport
+#    define getservent		PerlSock_getservent
+#    define getsockname		PerlSock_getsockname
+#    define getsockopt		PerlSock_getsockopt
+#    define inet_addr		PerlSock_inet_addr
+#    define inet_ntoa		PerlSock_inet_ntoa
+#    define listen		PerlSock_listen
+#    define recv		PerlSock_recv
+#    define recvfrom		PerlSock_recvfrom
+#    define select		PerlSock_select
+#    define send		PerlSock_send
+#    define sendto		PerlSock_sendto
+#    define sethostent		PerlSock_sethostent
+#    define setnetent		PerlSock_setnetent
+#    define setprotoent		PerlSock_setprotoent
+#    define setservent		PerlSock_setservent
+#    define setsockopt		PerlSock_setsockopt
+#    define shutdown		PerlSock_shutdown
+#    define socket		PerlSock_socket
+#    define socketpair		PerlSock_socketpair
+#  endif  /* NO_XSLOCKS */
+#endif  /* PERL_CAPI */
+
+#endif /* _INC_PERL_XSUB_H */		/* include guard */

contrib/perl5/av.c

@@ -1,6 +1,6 @@
 /*    av.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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,10 +13,11 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_AV_C
 #include "perl.h"
 
 void
-av_reify(AV *av)
+Perl_av_reify(pTHX_ AV *av)
 {
     I32 key;
     SV* sv;
@@ -24,8 +25,8 @@ av_reify(AV *av)
     if (AvREAL(av))
 	return;
 #ifdef DEBUGGING
-    if (SvTIED_mg((SV*)av, 'P'))
-	warn("av_reify called on tied array");
+    if (SvTIED_mg((SV*)av, 'P') && ckWARN_d(WARN_DEBUGGING))
+	Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array");
 #endif
     key = AvMAX(av) + 1;
     while (key > AvFILLp(av) + 1)
@@ -45,12 +46,21 @@ av_reify(AV *av)
     AvREAL_on(av);
 }
 
+/*
+=for apidoc av_extend
+
+Pre-extend an array.  The C<key> is the index to which the array should be
+extended.
+
+=cut
+*/
+
 void
-av_extend(AV *av, I32 key)
+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')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	ENTER;
 	SAVETMPS;
@@ -60,7 +70,7 @@ av_extend(AV *av, I32 key)
 	PUSHs(SvTIED_obj((SV*)av, mg));
 	PUSHs(sv_2mortal(newSViv(key+1)));
         PUTBACK;
-	perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
+	call_method("EXTEND", G_SCALAR|G_DISCARD);
 	POPSTACK;
 	FREETMPS;
 	LEAVE;
@@ -90,10 +100,11 @@ av_extend(AV *av, I32 key)
 	else {
 	    if (AvALLOC(av)) {
 #ifndef STRANGE_MALLOC
-		U32 bytes;
+		MEM_SIZE bytes;
+		IV itmp;
 #endif
 
-#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
+#if defined(MYMALLOC) && !defined(LEAKTEST)
 		newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
 
 		if (key <= newmax) 
@@ -106,13 +117,14 @@ av_extend(AV *av, I32 key)
 #else
 		bytes = (newmax + 1) * sizeof(SV*);
 #define MALLOC_OVERHEAD 16
-		tmp = MALLOC_OVERHEAD;
-		while (tmp - MALLOC_OVERHEAD < bytes)
-		    tmp += tmp;
-		tmp -= MALLOC_OVERHEAD;
-		tmp /= sizeof(SV*);
-		assert(tmp > newmax);
-		newmax = tmp - 1;
+		itmp = MALLOC_OVERHEAD;
+		while (itmp - MALLOC_OVERHEAD < bytes)
+		    itmp += itmp;
+		itmp -= MALLOC_OVERHEAD;
+		itmp /= sizeof(SV*);
+		assert(itmp > newmax);
+		newmax = itmp - 1;
+		assert(newmax >= AvMAX(av));
 		New(2,ary, newmax+1, SV*);
 		Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 		if (AvMAX(av) > 64)
@@ -148,8 +160,21 @@ av_extend(AV *av, I32 key)
     }
 }
 
+/*
+=for apidoc av_fetch
+
+Returns the SV at the specified index in the array.  The C<key> is the
+index.  If C<lval> is set then the fetch will be part of a store.  Check
+that the return value is non-null before 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 arrays. 
+
+=cut
+*/
+
 SV**
-av_fetch(register AV *av, I32 key, I32 lval)
+Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 {
     SV *sv;
 
@@ -163,7 +188,7 @@ av_fetch(register AV *av, I32 key, I32 lval)
     }
 
     if (SvRMAGICAL(av)) {
-	if (mg_find((SV*)av,'P')) {
+	if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
 	    dTHR;
 	    sv = sv_newmortal();
 	    mg_copy((SV*)av, sv, 0, key);
@@ -195,12 +220,27 @@ av_fetch(register AV *av, I32 key, I32 lval)
     return &AvARRAY(av)[key];
 }
 
+/*
+=for apidoc av_store
+
+Stores an SV in an array.  The array index is specified as C<key>.  The
+return value will be NULL if the operation failed or if the value did not
+need to be actually stored within the array (as in the case of tied
+arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
+that the caller is responsible for suitably incrementing the reference
+count of C<val> before 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 arrays.
+
+=cut
+*/
+
 SV**
-av_store(register AV *av, I32 key, SV *val)
+Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 {
     SV** ary;
-    U32  fill;
-
 
     if (!av)
 	return 0;
@@ -214,7 +254,7 @@ av_store(register AV *av, I32 key, SV *val)
     }
 
     if (SvREADONLY(av) && key >= AvFILL(av))
-	croak(no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
     if (SvRMAGICAL(av)) {
 	if (mg_find((SV*)av,'P')) {
@@ -254,8 +294,16 @@ av_store(register AV *av, I32 key, SV *val)
     return &ary[key];
 }
 
+/*
+=for apidoc newAV
+
+Creates a new AV.  The reference count is set to 1.
+
+=cut
+*/
+
 AV *
-newAV(void)
+Perl_newAV(pTHX)
 {
     register AV *av;
 
@@ -268,8 +316,18 @@ newAV(void)
     return av;
 }
 
+/*
+=for apidoc av_make
+
+Creates a new AV and populates it with a list of SVs.  The SVs are copied
+into the array, so they may be freed after the call to av_make.  The new AV
+will have a reference count of 1.
+
+=cut
+*/
+
 AV *
-av_make(register I32 size, register SV **strp)
+Perl_av_make(pTHX_ register I32 size, register SV **strp)
 {
     register AV *av;
     register I32 i;
@@ -295,7 +353,7 @@ av_make(register I32 size, register SV **strp)
 }
 
 AV *
-av_fake(register I32 size, register SV **strp)
+Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 {
     register AV *av;
     register SV** ary;
@@ -317,15 +375,24 @@ av_fake(register I32 size, register SV **strp)
     return av;
 }
 
+/*
+=for apidoc av_clear
+
+Clears an array, making it empty.  Does not free the memory used by the
+array itself.
+
+=cut
+*/
+
 void
-av_clear(register AV *av)
+Perl_av_clear(pTHX_ register AV *av)
 {
     register I32 key;
     SV** ary;
 
 #ifdef DEBUGGING
-    if (SvREFCNT(av) <= 0) {
-	warn("Attempt to clear deleted array");
+    if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
+	Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
     }
 #endif
     if (!av)
@@ -333,7 +400,7 @@ av_clear(register AV *av)
     /*SUPPRESS 560*/
 
     if (SvREADONLY(av))
-	croak(no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
     /* Give any tie a chance to cleanup first */
     if (SvRMAGICAL(av))
@@ -350,7 +417,7 @@ av_clear(register AV *av)
 	    ary[key] = &PL_sv_undef;
 	}
     }
-    if (key = AvARRAY(av) - AvALLOC(av)) {
+    if ((key = AvARRAY(av) - AvALLOC(av))) {
 	AvMAX(av) += key;
 	SvPVX(av) = (char*)AvALLOC(av);
     }
@@ -358,8 +425,16 @@ av_clear(register AV *av)
 
 }
 
+/*
+=for apidoc av_undef
+
+Undefines the array.  Frees the memory used by the array itself.
+
+=cut
+*/
+
 void
-av_undef(register AV *av)
+Perl_av_undef(pTHX_ register AV *av)
 {
     register I32 key;
 
@@ -386,16 +461,25 @@ av_undef(register AV *av)
     }
 }
 
+/*
+=for apidoc av_push
+
+Pushes an SV onto the end of the array.  The array will grow automatically
+to accommodate the addition.
+
+=cut
+*/
+
 void
-av_push(register AV *av, SV *val)
+Perl_av_push(pTHX_ register AV *av, SV *val)
 {             
     MAGIC *mg;
     if (!av)
 	return;
     if (SvREADONLY(av))
-	croak(no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
@@ -404,7 +488,7 @@ av_push(register AV *av, SV *val)
 	PUSHs(val);
 	PUTBACK;
 	ENTER;
-	perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+	call_method("PUSH", G_SCALAR|G_DISCARD);
 	LEAVE;
 	POPSTACK;
 	return;
@@ -412,8 +496,17 @@ av_push(register AV *av, SV *val)
     av_store(av,AvFILLp(av)+1,val);
 }
 
+/*
+=for apidoc av_pop
+
+Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
+is empty.
+
+=cut
+*/
+
 SV *
-av_pop(register AV *av)
+Perl_av_pop(pTHX_ register AV *av)
 {
     SV *retval;
     MAGIC* mg;
@@ -421,15 +514,15 @@ av_pop(register AV *av)
     if (!av || AvFILL(av) < 0)
 	return &PL_sv_undef;
     if (SvREADONLY(av))
-	croak(no_modify);
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+	Perl_croak(aTHX_ PL_no_modify);
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;    
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)av, mg));
 	PUTBACK;
 	ENTER;
-	if (perl_call_method("POP", G_SCALAR)) {
+	if (call_method("POP", G_SCALAR)) {
 	    retval = newSVsv(*PL_stack_sp--);    
 	} else {    
 	    retval = &PL_sv_undef;
@@ -445,8 +538,18 @@ av_pop(register AV *av)
     return retval;
 }
 
+/*
+=for apidoc av_unshift
+
+Unshift the given number of C<undef> values onto the beginning of the
+array.  The array will grow automatically to accommodate the addition.  You
+must then use C<av_store> to assign values to these new elements.
+
+=cut
+*/
+
 void
-av_unshift(register AV *av, register I32 num)
+Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 {
     register I32 i;
     register SV **ary;
@@ -455,9 +558,9 @@ av_unshift(register AV *av, register I32 num)
     if (!av || num <= 0)
 	return;
     if (SvREADONLY(av))
-	croak(no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
@@ -468,7 +571,7 @@ av_unshift(register AV *av, register I32 num)
 	}
 	PUTBACK;
 	ENTER;
-	perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+	call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 	LEAVE;
 	POPSTACK;
 	return;
@@ -498,8 +601,16 @@ av_unshift(register AV *av, register I32 num)
     }
 }
 
+/*
+=for apidoc av_shift
+
+Shifts an SV off the beginning of the array.
+
+=cut
+*/
+
 SV *
-av_shift(register AV *av)
+Perl_av_shift(pTHX_ register AV *av)
 {
     SV *retval;
     MAGIC* mg;
@@ -507,15 +618,15 @@ av_shift(register AV *av)
     if (!av || AvFILL(av) < 0)
 	return &PL_sv_undef;
     if (SvREADONLY(av))
-	croak(no_modify);
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+	Perl_croak(aTHX_ PL_no_modify);
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)av, mg));
 	PUTBACK;
 	ENTER;
-	if (perl_call_method("SHIFT", G_SCALAR)) {
+	if (call_method("SHIFT", G_SCALAR)) {
 	    retval = newSVsv(*PL_stack_sp--);            
 	} else {    
 	    retval = &PL_sv_undef;
@@ -535,21 +646,30 @@ av_shift(register AV *av)
     return retval;
 }
 
+/*
+=for apidoc av_len
+
+Returns the highest index in the array.  Returns -1 if the array is
+empty.
+
+=cut
+*/
+
 I32
-av_len(register AV *av)
+Perl_av_len(pTHX_ register AV *av)
 {
     return AvFILL(av);
 }
 
 void
-av_fill(register AV *av, I32 fill)
+Perl_av_fill(pTHX_ register AV *av, I32 fill)
 {
     MAGIC *mg;
     if (!av)
-	croak("panic: null array");
+	Perl_croak(aTHX_ "panic: null array");
     if (fill < 0)
 	fill = -1;
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;            
 	ENTER;
 	SAVETMPS;
@@ -559,7 +679,7 @@ av_fill(register AV *av, I32 fill)
 	PUSHs(SvTIED_obj((SV*)av, mg));
 	PUSHs(sv_2mortal(newSViv(fill+1)));
 	PUTBACK;
-	perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
+	call_method("STORESIZE", G_SCALAR|G_DISCARD);
 	POPSTACK;
 	FREETMPS;
 	LEAVE;
@@ -588,6 +708,86 @@ av_fill(register AV *av, I32 fill)
 	(void)av_store(av,fill,&PL_sv_undef);
 }
 
+SV *
+Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
+{
+    SV *sv;
+
+    if (!av)
+	return Nullsv;
+    if (SvREADONLY(av))
+	Perl_croak(aTHX_ PL_no_modify);
+    if (key < 0) {
+	key += AvFILL(av) + 1;
+	if (key < 0)
+	    return Nullsv;
+    }
+    if (SvRMAGICAL(av)) {
+	SV **svp;
+	if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D'))
+	    && (svp = av_fetch(av, key, TRUE)))
+	{
+	    sv = *svp;
+	    mg_clear(sv);
+	    if (mg_find(sv, 'p')) {
+		sv_unmagic(sv, 'p');		/* No longer an element */
+		return sv;
+	    }
+	    return Nullsv;			/* element cannot be deleted */
+	}
+    }
+    if (key > AvFILLp(av))
+	return Nullsv;
+    else {
+	sv = AvARRAY(av)[key];
+	if (key == AvFILLp(av)) {
+	    do {
+		AvFILLp(av)--;
+	    } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
+	}
+	else
+	    AvARRAY(av)[key] = &PL_sv_undef;
+	if (SvSMAGICAL(av))
+	    mg_set((SV*)av);
+    }
+    if (flags & G_DISCARD) {
+	SvREFCNT_dec(sv);
+	sv = Nullsv;
+    }
+    return sv;
+}
+
+/*
+ * This relies on the fact that uninitialized array elements
+ * are set to &PL_sv_undef.
+ */
+
+bool
+Perl_av_exists(pTHX_ AV *av, I32 key)
+{
+    if (!av)
+	return FALSE;
+    if (key < 0) {
+	key += AvFILL(av) + 1;
+	if (key < 0)
+	    return FALSE;
+    }
+    if (SvRMAGICAL(av)) {
+	if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
+	    SV *sv = sv_newmortal();
+	    mg_copy((SV*)av, sv, 0, key);
+	    magic_existspack(sv, mg_find(sv, 'p'));
+	    return SvTRUE(sv);
+	}
+    }
+    if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
+	&& AvARRAY(av)[key])
+    {
+	return TRUE;
+    }
+    else
+	return FALSE;
+}
 
 /* AVHV: Support for treating arrays as if they were hashes.  The
  * first element of the array should be a hash reference that maps
@@ -595,16 +795,30 @@ av_fill(register AV *av, I32 fill)
  */
 
 STATIC I32
-avhv_index_sv(SV* sv)
+S_avhv_index_sv(pTHX_ SV* sv)
 {
     I32 index = SvIV(sv);
     if (index < 1)
-	croak("Bad index while coercing array into hash");
+	Perl_croak(aTHX_ "Bad index while coercing array into hash");
     return index;    
 }
 
+STATIC I32
+S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+    HV *keys;
+    HE *he;
+    STRLEN n_a;
+
+    keys = avhv_keys(av);
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he)
+        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
+    return avhv_index_sv(HeVAL(he));
+}
+
 HV*
-avhv_keys(AV *av)
+Perl_avhv_keys(pTHX_ AV *av)
 {
     SV **keysp = av_fetch(av, 0, FALSE);
     if (keysp) {
@@ -617,39 +831,60 @@ avhv_keys(AV *av)
 		return (HV*)sv;
 	}
     }
-    croak("Can't coerce array into hash");
+    Perl_croak(aTHX_ "Can't coerce array into hash");
     return Nullhv;
 }
 
 SV**
-avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
+Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 {
-    SV **indsvp;
-    HV *keys = avhv_keys(av);
-    HE *he;
-    
-    he = hv_fetch_ent(keys, keysv, FALSE, hash);
-    if (!he)
-        croak("No such array field");
-    return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+    return av_store(av, avhv_index(av, keysv, hash), val);
 }
 
-bool
-avhv_exists_ent(AV *av, SV *keysv, U32 hash)
+SV**
+Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
+{
+    return av_fetch(av, avhv_index(av, keysv, hash), lval);
+}
+
+SV *
+Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 {
     HV *keys = avhv_keys(av);
-    return hv_exists_ent(keys, keysv, hash);
+    HE *he;
+	
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he || !SvOK(HeVAL(he)))
+	return Nullsv;
+
+    return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
+}
+
+/* Check for the existence of an element named by a given key.
+ *
+ */
+bool
+Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+    HV *keys = avhv_keys(av);
+    HE *he;
+	
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he || !SvOK(HeVAL(he)))
+	return FALSE;
+
+    return av_exists(av, avhv_index_sv(HeVAL(he)));
 }
 
 HE *
-avhv_iternext(AV *av)
+Perl_avhv_iternext(pTHX_ AV *av)
 {
     HV *keys = avhv_keys(av);
     return hv_iternext(keys);
 }
 
 SV *
-avhv_iterval(AV *av, register HE *entry)
+Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
 {
     SV *sv = hv_iterval(avhv_keys(av), entry);
     return *av_fetch(av, avhv_index_sv(sv), TRUE);

contrib/perl5/av.h

@@ -1,6 +1,6 @@
 /*    av.h
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -10,9 +10,9 @@
 struct xpvav {
     char*	xav_array;      /* pointer to first array element */
     SSize_t	xav_fill;       /* Index of last element present */
-    SSize_t	xav_max;        /* Number of elements for which array has space */
+    SSize_t	xav_max;        /* max index for which array has space */
     IV		xof_off;	/* ptr is incremented by offset */
-    double	xnv_nv;		/* numeric value, if any */
+    NV		xnv_nv;		/* numeric value, if any */
     MAGIC*	xmg_magic;	/* magic for scalar array */
     HV*		xmg_stash;	/* class package */
 
@@ -21,10 +21,40 @@ struct xpvav {
     U8		xav_flags;
 };
 
+
+/* AVf_REAL is set for all AVs whose xav_array contents are refcounted.
+ * Some things like "@_" and the scratchpad list do not set this, to
+ * indicate that they are cheating (for efficiency) by not refcounting
+ * the AV's contents.
+ * 
+ * AVf_REIFY is only meaningful on such "fake" AVs (i.e. where AVf_REAL
+ * is not set).  It indicates that the fake AV is capable of becoming
+ * real if the array needs to be modified in some way.  Functions that
+ * modify fake AVs check both flags to call av_reify() as appropriate.
+ *
+ * Note that the Perl stack has neither flag set. (Thus, items that go
+ * on the stack are never refcounted.)
+ *
+ * These internal details are subject to change any time.  AV
+ * manipulations external to perl should not care about any of this.
+ * GSAR 1999-09-10
+ */
 #define AVf_REAL 1	/* free old entries */
 #define AVf_REIFY 2	/* can become real */
+
+/* XXX this is not used anywhere */
 #define AVf_REUSED 4	/* got undeffed--don't turn old memory into SVs now */
 
+/*
+=for apidoc AmU||Nullav
+Null AV pointer.
+
+=for apidoc Am|int|AvFILL|AV* av
+Same as C<av_len()>.  Deprecated, use C<av_len()> instead.
+
+=cut
+*/
+
 #define Nullav Null(AV*)
 
 #define AvARRAY(av)	((SV**)((XPVAV*)  SvANY(av))->xav_array)

contrib/perl5/bytecode.pl

@@ -1,3 +1,6 @@
+BEGIN {
+  push @INC, './lib';
+}
 use strict;
 my %alias_to = (
     U32 => [qw(PADOFFSET STRLEN)],
@@ -6,7 +9,7 @@ my %alias_to = (
     U8 => [qw(char)],
 );
 
-my @optype= qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
 
 # Nullsv *must* come first in the following so that the condition
 # ($$sv == 0) can continue to be used to test (sv == Nullsv).
@@ -19,7 +22,7 @@ while (($from, $tos) = each %alias_to) {
 
 my $c_header = <<'EOT';
 /*
- *      Copyright (c) 1996-1998 Malcolm Beattie
+ *      Copyright (c) 1996-1999 Malcolm Beattie
  *
  *      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 +36,7 @@ EOT
 my $perl_header;
 ($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
 
-unlink "byterun.c", "byterun.h", "ext/B/B/Asmdata.pm";
+unlink "ext/ByteLoader/byterun.c", "ext/ByteLoader/byterun.h", "ext/B/B/Asmdata.pm";
 
 #
 # Start with boilerplate for Asmdata.pm
@@ -44,7 +47,7 @@ package B::Asmdata;
 use Exporter;
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
-use vars qw(%insn_data @insn_name @optype @specialsv_name);
+our(%insn_data, @insn_name, @optype, @specialsv_name);
 
 EOT
 print ASMDATA_PM <<"EOT";
@@ -59,34 +62,72 @@ EOT
 #
 # Boilerplate for byterun.c
 #
-open(BYTERUN_C, ">byterun.c") or die "byterun.c: $!";
+open(BYTERUN_C, ">ext/ByteLoader/byterun.c") or die "ext/ByteLoader/byterun.c: $!";
 print BYTERUN_C $c_header, <<'EOT';
 
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
+#define NO_XSLOCKS
+#include "XSUB.h"
+
+#ifdef PERL_OBJECT
+#undef CALL_FPTR
+#define CALL_FPTR(fptr) (pPerl->*fptr)
+#undef PL_ppaddr
+#define PL_ppaddr (*get_ppaddr())
+#endif
+
+#include "byterun.h"
+#include "bytecode.h"
+
+
+static int optype_size[] = {
+EOT
+my $i = 0;
+for ($i = 0; $i < @optype - 1; $i++) {
+    printf BYTERUN_C "    sizeof(%s),\n", $optype[$i], $i;
+}
+printf BYTERUN_C "    sizeof(%s)\n", $optype[$i], $i;
+print BYTERUN_C <<'EOT';
+};
+
+static SV *specialsv_list[4];
+
+static int bytecode_iv_overflows = 0;
+static SV *bytecode_sv;
+static XPV bytecode_pv;
+static void **bytecode_obj_list;
+static I32 bytecode_obj_list_fill = -1;
 
 void *
-bset_obj_store(void *obj, I32 ix)
+bset_obj_store(pTHXo_ void *obj, I32 ix)
 {
-    if (ix > PL_bytecode_obj_list_fill) {
-	if (PL_bytecode_obj_list_fill == -1)
-	    New(666, PL_bytecode_obj_list, ix + 1, void*);
+    if (ix > bytecode_obj_list_fill) {
+	if (bytecode_obj_list_fill == -1)
+	    New(666, bytecode_obj_list, ix + 1, void*);
 	else
-	    Renew(PL_bytecode_obj_list, ix + 1, void*);
-	PL_bytecode_obj_list_fill = ix;
+	    Renew(bytecode_obj_list, ix + 1, void*);
+	bytecode_obj_list_fill = ix;
     }
-    PL_bytecode_obj_list[ix] = obj;
+    bytecode_obj_list[ix] = obj;
     return obj;
 }
 
-#ifdef INDIRECT_BGET_MACROS
-void byterun(struct bytestream bs)
-#else
-void byterun(PerlIO *fp)
-#endif /* INDIRECT_BGET_MACROS */
+void
+byterun(pTHXo_ struct bytestream bs)
 {
     dTHR;
     int insn;
+
+EOT
+
+for (my $i = 0; $i < @specialsv; $i++) {
+    print BYTERUN_C "    specialsv_list[$i] = $specialsv[$i];\n";
+}
+
+print BYTERUN_C <<'EOT';
+
     while ((insn = BGET_FGETC()) != EOF) {
 	switch (insn) {
 EOT
@@ -121,7 +162,7 @@ while (<DATA>) {
     if ($flags =~ /x/) {
 	print BYTERUN_C "\t\tBSET_$insn($lvalue$optarg);\n";
     } elsif ($flags =~ /s/) {
-	# Store instructions store to PL_bytecode_obj_list[arg]. "lvalue" field is rvalue.
+	# Store instructions store to bytecode_obj_list[arg]. "lvalue" field is rvalue.
 	print BYTERUN_C "\t\tBSET_OBJ_STORE($lvalue$optarg);\n";
     }
     elsif ($optarg && $lvalue ne "none") {
@@ -145,7 +186,7 @@ EOT
 #
 print BYTERUN_C <<'EOT';
 	  default:
-	    croak("Illegal bytecode instruction %d\n", insn);
+	    Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
 	    /* NOTREACHED */
 	}
     }
@@ -155,23 +196,18 @@ EOT
 #
 # Write the instruction and optype enum constants into byterun.h
 #
-open(BYTERUN_H, ">byterun.h") or die "byterun.h: $!";
+open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!";
 print BYTERUN_H $c_header, <<'EOT';
-#ifdef INDIRECT_BGET_MACROS
 struct bytestream {
     void *data;
-    int (*fgetc)(void *);
-    int (*fread)(char *, size_t, size_t, void*);
-    void (*freadpv)(U32, void*);
+    int (*pfgetc)(void *);
+    int (*pfread)(char *, size_t, size_t, void *);
+    void (*pfreadpv)(U32, void *, XPV *);
 };
-#endif /* INDIRECT_BGET_MACROS */
-
-void *bset_obj_store _((void *, I32));
 
 enum {
 EOT
 
-my $i = 0;
 my $add_enum_value = 0;
 my $max_insn;
 for ($i = 0; $i < @insn_name; $i++) {
@@ -196,22 +232,10 @@ for ($i = 0; $i < @optype - 1; $i++) {
     printf BYTERUN_H "    OPt_%s,\t\t/* %d */\n", $optype[$i], $i;
 }
 printf BYTERUN_H "    OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
-print BYTERUN_H <<'EOT';
-EXT int optype_size[]
-#ifdef DOINIT
-= {
-EOT
-for ($i = 0; $i < @optype - 1; $i++) {
-    printf BYTERUN_H "    sizeof(%s),\n", $optype[$i], $i;
-}
-printf BYTERUN_H "    sizeof(%s)\n}\n", $optype[$i], $i;
-print BYTERUN_H <<'EOT';
-#endif /* DOINIT */
-;
-
-EOT
 
 print BYTERUN_H <<'EOT';
+extern void byterun(pTHXo_ struct bytestream bs);
+
 #define INIT_SPECIALSV_LIST STMT_START { \
 EOT
 for ($i = 0; $i < @specialsv; $i++) {
@@ -270,85 +294,85 @@ nop		none			none
 #opcode		lvalue					argtype		flags	
 #
 ret		none					none		x
-ldsv		PL_bytecode_sv				svindex
+ldsv		bytecode_sv				svindex
 ldop		PL_op					opindex
-stsv		PL_bytecode_sv				U32		s
+stsv		bytecode_sv				U32		s
 stop		PL_op					U32		s
-ldspecsv	PL_bytecode_sv				U8		x
-newsv		PL_bytecode_sv				U8		x
+ldspecsv	bytecode_sv				U8		x
+newsv		bytecode_sv				U8		x
 newop		PL_op					U8		x
 newopn		PL_op					U8		x
 newpv		none					PV
-pv_cur		PL_bytecode_pv.xpv_cur			STRLEN
-pv_free		PL_bytecode_pv				none		x
-sv_upgrade	PL_bytecode_sv				char		x
-sv_refcnt	SvREFCNT(PL_bytecode_sv)		U32
-sv_refcnt_add	SvREFCNT(PL_bytecode_sv)		I32		x
-sv_flags	SvFLAGS(PL_bytecode_sv)			U32
-xrv		SvRV(PL_bytecode_sv)			svindex
-xpv		PL_bytecode_sv				none		x
-xiv32		SvIVX(PL_bytecode_sv)			I32
-xiv64		SvIVX(PL_bytecode_sv)			IV64
-xnv		SvNVX(PL_bytecode_sv)			double
-xlv_targoff	LvTARGOFF(PL_bytecode_sv)		STRLEN
-xlv_targlen	LvTARGLEN(PL_bytecode_sv)		STRLEN
-xlv_targ	LvTARG(PL_bytecode_sv)			svindex
-xlv_type	LvTYPE(PL_bytecode_sv)			char
-xbm_useful	BmUSEFUL(PL_bytecode_sv)		I32
-xbm_previous	BmPREVIOUS(PL_bytecode_sv)		U16
-xbm_rare	BmRARE(PL_bytecode_sv)			U8
-xfm_lines	FmLINES(PL_bytecode_sv)			I32
-xio_lines	IoLINES(PL_bytecode_sv)			long
-xio_page	IoPAGE(PL_bytecode_sv)			long
-xio_page_len	IoPAGE_LEN(PL_bytecode_sv)		long
-xio_lines_left	IoLINES_LEFT(PL_bytecode_sv)		long
-xio_top_name	IoTOP_NAME(PL_bytecode_sv)		pvcontents
-xio_top_gv	*(SV**)&IoTOP_GV(PL_bytecode_sv)	svindex
-xio_fmt_name	IoFMT_NAME(PL_bytecode_sv)		pvcontents
-xio_fmt_gv	*(SV**)&IoFMT_GV(PL_bytecode_sv)	svindex
-xio_bottom_name	IoBOTTOM_NAME(PL_bytecode_sv)		pvcontents
-xio_bottom_gv	*(SV**)&IoBOTTOM_GV(PL_bytecode_sv)	svindex
-xio_subprocess	IoSUBPROCESS(PL_bytecode_sv)		short
-xio_type	IoTYPE(PL_bytecode_sv)			char
-xio_flags	IoFLAGS(PL_bytecode_sv)			char
-xcv_stash	*(SV**)&CvSTASH(PL_bytecode_sv)		svindex
-xcv_start	CvSTART(PL_bytecode_sv)			opindex
-xcv_root	CvROOT(PL_bytecode_sv)			opindex
-xcv_gv		*(SV**)&CvGV(PL_bytecode_sv)		svindex
-xcv_filegv	*(SV**)&CvFILEGV(PL_bytecode_sv)	svindex
-xcv_depth	CvDEPTH(PL_bytecode_sv)			long
-xcv_padlist	*(SV**)&CvPADLIST(PL_bytecode_sv)	svindex
-xcv_outside	*(SV**)&CvOUTSIDE(PL_bytecode_sv)	svindex
-xcv_flags	CvFLAGS(PL_bytecode_sv)			U8
-av_extend	PL_bytecode_sv				SSize_t		x
-av_push		PL_bytecode_sv				svindex		x
-xav_fill	AvFILLp(PL_bytecode_sv)			SSize_t
-xav_max		AvMAX(PL_bytecode_sv)			SSize_t
-xav_flags	AvFLAGS(PL_bytecode_sv)			U8
-xhv_riter	HvRITER(PL_bytecode_sv)			I32
-xhv_name	HvNAME(PL_bytecode_sv)			pvcontents
-hv_store	PL_bytecode_sv				svindex		x
-sv_magic	PL_bytecode_sv				char		x
-mg_obj		SvMAGIC(PL_bytecode_sv)->mg_obj		svindex
-mg_private	SvMAGIC(PL_bytecode_sv)->mg_private	U16
-mg_flags	SvMAGIC(PL_bytecode_sv)->mg_flags	U8
-mg_pv		SvMAGIC(PL_bytecode_sv)			pvcontents	x
-xmg_stash	*(SV**)&SvSTASH(PL_bytecode_sv)		svindex
-gv_fetchpv	PL_bytecode_sv				strconst	x
-gv_stashpv	PL_bytecode_sv				strconst	x
-gp_sv		GvSV(PL_bytecode_sv)			svindex
-gp_refcnt	GvREFCNT(PL_bytecode_sv)		U32
-gp_refcnt_add	GvREFCNT(PL_bytecode_sv)		I32		x
-gp_av		*(SV**)&GvAV(PL_bytecode_sv)		svindex
-gp_hv		*(SV**)&GvHV(PL_bytecode_sv)		svindex
-gp_cv		*(SV**)&GvCV(PL_bytecode_sv)		svindex
-gp_filegv	*(SV**)&GvFILEGV(PL_bytecode_sv)	svindex
-gp_io		*(SV**)&GvIOp(PL_bytecode_sv)		svindex
-gp_form		*(SV**)&GvFORM(PL_bytecode_sv)		svindex
-gp_cvgen	GvCVGEN(PL_bytecode_sv)			U32
-gp_line		GvLINE(PL_bytecode_sv)			line_t
-gp_share	PL_bytecode_sv				svindex		x
-xgv_flags	GvFLAGS(PL_bytecode_sv)			U8
+pv_cur		bytecode_pv.xpv_cur			STRLEN
+pv_free		bytecode_pv				none		x
+sv_upgrade	bytecode_sv				char		x
+sv_refcnt	SvREFCNT(bytecode_sv)			U32
+sv_refcnt_add	SvREFCNT(bytecode_sv)			I32		x
+sv_flags	SvFLAGS(bytecode_sv)			U32
+xrv		SvRV(bytecode_sv)			svindex
+xpv		bytecode_sv				none		x
+xiv32		SvIVX(bytecode_sv)			I32
+xiv64		SvIVX(bytecode_sv)			IV64
+xnv		SvNVX(bytecode_sv)			NV
+xlv_targoff	LvTARGOFF(bytecode_sv)			STRLEN
+xlv_targlen	LvTARGLEN(bytecode_sv)			STRLEN
+xlv_targ	LvTARG(bytecode_sv)			svindex
+xlv_type	LvTYPE(bytecode_sv)			char
+xbm_useful	BmUSEFUL(bytecode_sv)			I32
+xbm_previous	BmPREVIOUS(bytecode_sv)			U16
+xbm_rare	BmRARE(bytecode_sv)			U8
+xfm_lines	FmLINES(bytecode_sv)			I32
+xio_lines	IoLINES(bytecode_sv)			long
+xio_page	IoPAGE(bytecode_sv)			long
+xio_page_len	IoPAGE_LEN(bytecode_sv)			long
+xio_lines_left	IoLINES_LEFT(bytecode_sv)	       	long
+xio_top_name	IoTOP_NAME(bytecode_sv)			pvcontents
+xio_top_gv	*(SV**)&IoTOP_GV(bytecode_sv)		svindex
+xio_fmt_name	IoFMT_NAME(bytecode_sv)			pvcontents
+xio_fmt_gv	*(SV**)&IoFMT_GV(bytecode_sv)		svindex
+xio_bottom_name	IoBOTTOM_NAME(bytecode_sv)		pvcontents
+xio_bottom_gv	*(SV**)&IoBOTTOM_GV(bytecode_sv)	svindex
+xio_subprocess	IoSUBPROCESS(bytecode_sv)		short
+xio_type	IoTYPE(bytecode_sv)			char
+xio_flags	IoFLAGS(bytecode_sv)			char
+xcv_stash	*(SV**)&CvSTASH(bytecode_sv)		svindex
+xcv_start	CvSTART(bytecode_sv)			opindex
+xcv_root	CvROOT(bytecode_sv)			opindex
+xcv_gv		*(SV**)&CvGV(bytecode_sv)		svindex
+xcv_file	CvFILE(bytecode_sv)			pvcontents
+xcv_depth	CvDEPTH(bytecode_sv)			long
+xcv_padlist	*(SV**)&CvPADLIST(bytecode_sv)		svindex
+xcv_outside	*(SV**)&CvOUTSIDE(bytecode_sv)		svindex
+xcv_flags	CvFLAGS(bytecode_sv)			U16
+av_extend	bytecode_sv				SSize_t		x
+av_push		bytecode_sv				svindex		x
+xav_fill	AvFILLp(bytecode_sv)			SSize_t
+xav_max		AvMAX(bytecode_sv)			SSize_t
+xav_flags	AvFLAGS(bytecode_sv)			U8
+xhv_riter	HvRITER(bytecode_sv)			I32
+xhv_name	HvNAME(bytecode_sv)			pvcontents
+hv_store	bytecode_sv				svindex		x
+sv_magic	bytecode_sv				char		x
+mg_obj		SvMAGIC(bytecode_sv)->mg_obj		svindex
+mg_private	SvMAGIC(bytecode_sv)->mg_private	U16
+mg_flags	SvMAGIC(bytecode_sv)->mg_flags		U8
+mg_pv		SvMAGIC(bytecode_sv)			pvcontents	x
+xmg_stash	*(SV**)&SvSTASH(bytecode_sv)		svindex
+gv_fetchpv	bytecode_sv				strconst	x
+gv_stashpv	bytecode_sv				strconst	x
+gp_sv		GvSV(bytecode_sv)			svindex
+gp_refcnt	GvREFCNT(bytecode_sv)			U32
+gp_refcnt_add	GvREFCNT(bytecode_sv)			I32		x
+gp_av		*(SV**)&GvAV(bytecode_sv)		svindex
+gp_hv		*(SV**)&GvHV(bytecode_sv)		svindex
+gp_cv		*(SV**)&GvCV(bytecode_sv)		svindex
+gp_file		GvFILE(bytecode_sv)			pvcontents
+gp_io		*(SV**)&GvIOp(bytecode_sv)		svindex
+gp_form		*(SV**)&GvFORM(bytecode_sv)		svindex
+gp_cvgen	GvCVGEN(bytecode_sv)			U32
+gp_line		GvLINE(bytecode_sv)			line_t
+gp_share	bytecode_sv				svindex		x
+xgv_flags	GvFLAGS(bytecode_sv)			U8
 op_next		PL_op->op_next				opindex
 op_sibling	PL_op->op_sibling			opindex
 op_ppaddr	PL_op->op_ppaddr			strconst	x
@@ -360,8 +384,6 @@ op_private	PL_op->op_private			U8
 op_first	cUNOP->op_first				opindex
 op_last		cBINOP->op_last				opindex
 op_other	cLOGOP->op_other			opindex
-op_true		cCONDOP->op_true			opindex
-op_false	cCONDOP->op_false			opindex
 op_children	cLISTOP->op_children			U32
 op_pmreplroot	cPMOP->op_pmreplroot			opindex
 op_pmreplrootgv	*(SV**)&cPMOP->op_pmreplroot		svindex
@@ -371,18 +393,19 @@ pregcomp	PL_op					pvcontents	x
 op_pmflags	cPMOP->op_pmflags			U16
 op_pmpermflags	cPMOP->op_pmpermflags			U16
 op_sv		cSVOP->op_sv				svindex
-op_gv		*(SV**)&cGVOP->op_gv			svindex
+op_padix	cPADOP->op_padix			PADOFFSET
 op_pv		cPVOP->op_pv				pvcontents
 op_pv_tr	cPVOP->op_pv				op_tr_array
 op_redoop	cLOOP->op_redoop			opindex
 op_nextop	cLOOP->op_nextop			opindex
 op_lastop	cLOOP->op_lastop			opindex
 cop_label	cCOP->cop_label				pvcontents
-cop_stash	*(SV**)&cCOP->cop_stash			svindex
-cop_filegv	*(SV**)&cCOP->cop_filegv		svindex
+cop_stashpv	cCOP					pvcontents	x
+cop_file	cCOP					pvcontents	x
 cop_seq		cCOP->cop_seq				U32
 cop_arybase	cCOP->cop_arybase			I32
-cop_line	cCOP->cop_line				line_t
+cop_line	cCOP					line_t		x
+cop_warnings	cCOP->cop_warnings			svindex
 main_start	PL_main_start				opindex
 main_root	PL_main_root				opindex
 curpad		PL_curpad				svindex		x

contrib/perl5/cc_runtime.h

@@ -1,4 +1,5 @@
-#define DOOP(ppname) PUTBACK; PL_op = ppname(ARGS); SPAGAIN
+#define DOOP(ppname) PUTBACK; PL_op = ppname(aTHX); SPAGAIN
+#define CCPP(s)   OP * s(pTHX)
 
 #define PP_LIST(g) do {			\
 	dMARK;				\
@@ -43,7 +44,7 @@
 	JMPENV_PUSH(ret);			\
 	switch (ret) {				\
 	case 0:					\
-	    PL_op = ppaddr(ARGS);			\
+	    PL_op = ppaddr(aTHX);		\
 	    PL_retstack[PL_retstack_ix - 1] = Nullop;	\
 	    if (PL_op != nxt) CALLRUNOPS();		\
 	    JMPENV_POP;				\
@@ -52,20 +53,23 @@
 	case 2: JMPENV_POP; JMPENV_JUMP(2);	\
 	case 3:					\
 	    JMPENV_POP;				\
-	    if (PL_restartop != nxt)		\
+	    if (PL_restartop && PL_restartop != nxt)		\
 		JMPENV_JUMP(3);			\
 	}					\
 	PL_op = nxt;				\
 	SPAGAIN;				\
     } while (0)
 
-#define PP_ENTERTRY(jmpbuf,label) do {		\
-	dJMPENV;				\
-	int ret;				\
-	JMPENV_PUSH(ret);			\
-	switch (ret) {				\
-	case 1: JMPENV_POP; JMPENV_JUMP(1);	\
-	case 2: JMPENV_POP; JMPENV_JUMP(2);	\
-	case 3: JMPENV_POP; SPAGAIN; goto label;\
-	}					\
-    } while (0)
+
+#define PP_ENTERTRY(jmpbuf,label)  \
+	STMT_START {                    \
+		int ret;		\
+		JMPENV_PUSH_ENV(jmpbuf,ret);			\
+		switch (ret) {				\
+			case 1: JMPENV_POP_ENV(jmpbuf); JMPENV_JUMP(1);\
+			case 2: JMPENV_POP_ENV(jmpbuf); JMPENV_JUMP(2);\
+			case 3: JMPENV_POP_ENV(jmpbuf); SPAGAIN; goto label;\
+		}                                       \
+	} STMT_END
+#define PP_LEAVETRY \
+	STMT_START{ PL_top_env=PL_top_env->je_prev; }STMT_END

contrib/perl5/cflags.SH

@@ -28,7 +28,7 @@ $startsh
 
 : In the following dollars and backticks do not need the extra backslash.
 $spitshell >>cflags <<'!NO!SUBS!'
-case $CONFIG in
+case $CONFIGDOTSH in
 '')
 	if test -f config.sh; then TOP=.;
 	elif test -f ../config.sh; then TOP=..;
@@ -65,7 +65,7 @@ case $# in
 0) set *.c; echo "The current C flags are:" ;;
 esac
 
-set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g'`
+set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g' -e "s/\\$obj_ext / /g"`
 
 for file do
 
@@ -76,7 +76,10 @@ for file do
 
     : allow variables like toke_cflags to be evaluated
 
-    eval 'eval ${'"${file}_cflags"'-""}'
+    if echo $file | grep -v / >/dev/null
+    then
+      eval 'eval ${'"${file}_cflags"'-""}'
+    fi
 
     : or customize here
 
@@ -102,6 +105,7 @@ for file do
     miniperlmain) ;;
     op) ;;
     perl) ;;
+    perlapi) ;;
     perlmain) ;;
     perly) ;;
     pp) ;;

contrib/perl5/configpm

@@ -17,17 +17,33 @@ my $glossary = $ARGV[1] || 'Porting/Glossary';
 
 
 open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
-$myver = $];
+$myver = sprintf "v%vd", $^V;
 
-print CONFIG <<"ENDOFBEG";
+print CONFIG <<'ENDOFBEG_NOQ', <<"ENDOFBEG";
 package Config;
 use Exporter ();
-\@ISA = (Exporter);
-\@EXPORT = qw(%Config);
-\@EXPORT_OK = qw(myconfig config_sh config_vars);
+@EXPORT = qw(%Config);
+@EXPORT_OK = qw(myconfig config_sh config_vars);
 
-\$] == $myver
-  or die "Perl lib version ($myver) doesn't match executable version (\$])";
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+  my $pkg = shift;
+  @_ = @EXPORT unless @_;
+  my @func = grep {$_ ne '%Config'} @_;
+  local $Exporter::ExportLevel = 1;
+  Exporter::import('Config', @func) if @func;
+  return if @func == @_;
+  my $callpkg = caller(0);
+  *{"$callpkg\::Config"} = \%Config;
+}
+
+ENDOFBEG_NOQ
+die "Perl lib version ($myver) doesn't match executable version (\$])"
+    unless \$^V;
+
+\$^V eq $myver
+  or die "Perl lib version ($myver) doesn't match executable version (" .
+    (sprintf "v%vd",\$^V) . ")";
 
 # This file was created by configpm when Perl was built. Any changes
 # made to this file will be lost the next time perl is built.
@@ -44,8 +60,21 @@ $in_v = 0;
 
 while (<>) {
     next if m:^#!/bin/sh:;
-    # Catch CONFIG=true and PATCHLEVEL=n line from Configure.
+    # Catch CONFIGDOTSH=true and PERL_VERSION=n line from Configure.
     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
+    my ($k,$v) = ($1,$2);
+    # grandfather PATCHLEVEL and SUBVERSION and CONFIG
+    if ($k) {
+	if ($k eq 'PERL_VERSION') {
+	    push @v_others, "PATCHLEVEL='$v'\n";
+	}
+	elsif ($k eq 'PERL_SUBVERSION') {
+	    push @v_others, "SUBVERSION='$v'\n";
+	}
+	elsif ($k eq 'CONFIGDOTSH') {
+	    push @v_others, "CONFIG='$v'\n";
+	}
+    }
     # We can delimit things in config.sh with either ' or ". 
     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
 	push(@non_v, "#$_"); # not a name='value' line
@@ -68,11 +97,11 @@ print CONFIG "\n",
     join("", @v_fast, sort @v_others),
     "!END!\n\n";
 
-# copy config summary format from the myconfig script
+# copy config summary format from the myconfig.SH script
 
 print CONFIG "my \$summary = <<'!END!';\n";
 
-open(MYCONFIG,"<myconfig") || die "open myconfig failed: $!";
+open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
 do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
 close(MYCONFIG);
@@ -401,11 +430,11 @@ require $config_pm;
 import Config;
 
 die "$0: $config_pm not valid"
-	unless $Config{'CONFIG'} eq 'true';
+	unless $Config{'CONFIGDOTSH'} eq 'true';
 
 die "$0: error processing $config_pm"
 	if defined($Config{'an impossible name'})
-	or $Config{'CONFIG'} ne 'true' # test cache
+	or $Config{'CONFIGDOTSH'} ne 'true' # test cache
 	;
 
 die "$0: error processing $config_pm"

contrib/perl5/configure.gnu

@@ -111,6 +111,14 @@ case "$ccflags" in
 '') ;;
 *) opts="$opts -Dccflags='$ccflags'";;
 esac
+case "$LDFLAGS" in
+'') ;;
+*) ldflags="$ldflags $LDFLAGS";;
+esac
+case "$ldflags" in
+'') ;;
+*) opts="$opts -Dldflags='$ldflags'";;
+esac
 
 # Don't use -s if they want verbose mode
 case "$verbose" in

contrib/perl5/cop.h

@@ -1,6 +1,6 @@
 /*    cop.h
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -10,15 +10,59 @@
 struct cop {
     BASEOP
     char *	cop_label;	/* label for this construct */
+#ifdef USE_ITHREADS
+    char *	cop_stashpv;	/* package line was compiled in */
+    char *	cop_file;	/* file name the following line # is from */
+#else
     HV *	cop_stash;	/* package line was compiled in */
     GV *	cop_filegv;	/* file the following line # is from */
+#endif
     U32		cop_seq;	/* parse sequence number */
     I32		cop_arybase;	/* array base this line was compiled with */
     line_t      cop_line;       /* line # of this command */
+    SV *	cop_warnings;	/* lexical warnings bitmask */
 };
 
 #define Nullcop Null(COP*)
 
+#ifdef USE_ITHREADS
+#  define CopFILE(c)		((c)->cop_file)
+#  define CopFILEGV(c)		(CopFILE(c) \
+				 ? gv_fetchfile(CopFILE(c)) : Nullgv)
+#  define CopFILE_set(c,pv)	((c)->cop_file = savepv(pv))	/* XXX */
+#  define CopFILESV(c)		(CopFILE(c) \
+				 ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
+#  define CopFILEAV(c)		(CopFILE(c) \
+				 ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
+#  define CopSTASHPV(c)		((c)->cop_stashpv)
+#  define CopSTASHPV_set(c,pv)	((c)->cop_stashpv = savepv(pv))	/* XXX */
+#  define CopSTASH(c)		(CopSTASHPV(c) \
+				 ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
+#  define CopSTASH_set(c,hv)	CopSTASHPV_set(c, HvNAME(hv))
+#  define CopSTASH_eq(c,hv)	(hv 					\
+				 && (CopSTASHPV(c) == HvNAME(hv)	\
+				     || (CopSTASHPV(c) && HvNAME(hv)	\
+					 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
+#else
+#  define CopFILEGV(c)		((c)->cop_filegv)
+#  define CopFILEGV_set(c,gv)	((c)->cop_filegv = gv)
+#  define CopFILE_set(c,pv)	((c)->cop_filegv = gv_fetchfile(pv))
+#  define CopFILESV(c)		(CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
+#  define CopFILEAV(c)		(CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
+#  define CopFILE(c)		(CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
+#  define CopSTASH(c)		((c)->cop_stash)
+#  define CopSTASH_set(c,hv)	((c)->cop_stash = hv)
+#  define CopSTASHPV(c)		(CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
+#  define CopSTASHPV_set(c,pv)	CopSTASH_set(c, gv_stashpv(pv,GV_ADD))
+#  define CopSTASH_eq(c,hv)	(CopSTASH(c) == hv)
+#endif /* USE_ITHREADS */
+
+#define CopSTASH_ne(c,hv)	(!CopSTASH_eq(c,hv))
+#define CopLINE(c)		((c)->cop_line)
+#define CopLINE_inc(c)		(++CopLINE(c))
+#define CopLINE_dec(c)		(--CopLINE(c))
+#define CopLINE_set(c,l)	(CopLINE(c) = (l))
+
 /*
  * Here we have some enormously heavy (or at least ponderous) wizardry.
  */
@@ -34,12 +78,15 @@ struct block_sub {
     AV *	argarray;
     U16		olddepth;
     U8		hasargs;
+    U8		lval;		/* XXX merge lval and hasargs? */
 };
 
 #define PUSHSUB(cx)							\
 	cx->blk_sub.cv = cv;						\
 	cx->blk_sub.olddepth = CvDEPTH(cv);				\
-	cx->blk_sub.hasargs = hasargs;
+	cx->blk_sub.hasargs = hasargs;					\
+	cx->blk_sub.lval = PL_op->op_private &                          \
+	                      (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
 
 #define PUSHFORMAT(cx)							\
 	cx->blk_sub.cv = cv;						\
@@ -48,35 +95,51 @@ struct block_sub {
 	cx->blk_sub.dfoutgv = PL_defoutgv;				\
 	(void)SvREFCNT_inc(cx->blk_sub.dfoutgv)
 
-#define POPSUB(cx)							\
-	{ struct block_sub cxsub;					\
-	  POPSUB1(cx);							\
-	  POPSUB2(); }
-
-#define POPSUB1(cx)							\
-	cxsub = cx->blk_sub;	/* because DESTROY may clobber *cx */
-
 #ifdef USE_THREADS
-#define POPSAVEARRAY() NOOP
+#  define POP_SAVEARRAY() NOOP
 #else
-#define POPSAVEARRAY()							\
+#  define POP_SAVEARRAY()						\
     STMT_START {							\
 	SvREFCNT_dec(GvAV(PL_defgv));					\
-	GvAV(PL_defgv) = cxsub.savearray;					\
+	GvAV(PL_defgv) = cx->blk_sub.savearray;				\
     } STMT_END
 #endif /* USE_THREADS */
 
-#define POPSUB2()							\
-	if (cxsub.hasargs) {						\
-	    POPSAVEARRAY();						\
-	    /* destroy arg array */					\
-	    av_clear(cxsub.argarray);					\
-	    AvREAL_off(cxsub.argarray);					\
+#ifdef USE_ITHREADS
+   /* junk in @_ spells trouble when cloning CVs, so don't leave any */
+#  define CLEAR_ARGARRAY()	av_clear(cx->blk_sub.argarray)
+#else
+#  define CLEAR_ARGARRAY()	NOOP
+#endif /* USE_ITHREADS */
+
+
+#define POPSUB(cx,sv)							\
+    STMT_START {							\
+	if (cx->blk_sub.hasargs) {					\
+	    POP_SAVEARRAY();						\
+	    /* abandon @_ if it got reified */				\
+	    if (AvREAL(cx->blk_sub.argarray)) {				\
+		SSize_t fill = AvFILLp(cx->blk_sub.argarray);		\
+		SvREFCNT_dec(cx->blk_sub.argarray);			\
+		cx->blk_sub.argarray = newAV();				\
+		av_extend(cx->blk_sub.argarray, fill);			\
+		AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY;		\
+		PL_curpad[0] = (SV*)cx->blk_sub.argarray;		\
+	    }								\
+	    else {							\
+		CLEAR_ARGARRAY();					\
+	    }								\
 	}								\
-	if (cxsub.cv) {							\
-	    if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth))			\
-		SvREFCNT_dec(cxsub.cv);					\
-	}
+	sv = (SV*)cx->blk_sub.cv;					\
+	if (sv && (CvDEPTH((CV*)sv) = cx->blk_sub.olddepth))		\
+	    sv = Nullsv;						\
+    } STMT_END
+
+#define LEAVESUB(sv)							\
+    STMT_START {							\
+	if (sv)								\
+	    SvREFCNT_dec(sv);						\
+    } STMT_END
 
 #define POPFORMAT(cx)							\
 	setdefout(cx->blk_sub.dfoutgv);					\
@@ -86,22 +149,28 @@ struct block_sub {
 struct block_eval {
     I32		old_in_eval;
     I32		old_op_type;
-    char *	old_name;
+    SV *	old_namesv;
     OP *	old_eval_root;
     SV *	cur_text;
 };
 
 #define PUSHEVAL(cx,n,fgv)						\
+    STMT_START {							\
 	cx->blk_eval.old_in_eval = PL_in_eval;				\
-	cx->blk_eval.old_op_type = PL_op->op_type;				\
-	cx->blk_eval.old_name = n;					\
-	cx->blk_eval.old_eval_root = PL_eval_root;				\
-	cx->blk_eval.cur_text = PL_linestr;
+	cx->blk_eval.old_op_type = PL_op->op_type;			\
+	cx->blk_eval.old_namesv = (n ? newSVpv(n,0) : Nullsv);		\
+	cx->blk_eval.old_eval_root = PL_eval_root;			\
+	cx->blk_eval.cur_text = PL_linestr;				\
+    } STMT_END
 
 #define POPEVAL(cx)							\
+    STMT_START {							\
 	PL_in_eval = cx->blk_eval.old_in_eval;				\
 	optype = cx->blk_eval.old_op_type;				\
-	PL_eval_root = cx->blk_eval.old_eval_root;
+	PL_eval_root = cx->blk_eval.old_eval_root;			\
+	if (cx->blk_eval.old_namesv)					\
+	    sv_2mortal(cx->blk_eval.old_namesv);			\
+    } STMT_END
 
 /* loop context */
 struct block_loop {
@@ -110,7 +179,12 @@ struct block_loop {
     OP *	redo_op;
     OP *	next_op;
     OP *	last_op;
+#ifdef USE_ITHREADS
+    void *	iterdata;
+    SV **	oldcurpad;
+#else
     SV **	itervar;
+#endif
     SV *	itersave;
     SV *	iterlval;
     AV *	iterary;
@@ -118,35 +192,44 @@ struct block_loop {
     IV		itermax;
 };
 
-#define PUSHLOOP(cx, ivar, s)						\
-	cx->blk_loop.label = PL_curcop->cop_label;				\
-	cx->blk_loop.resetsp = s - PL_stack_base;				\
+#ifdef USE_ITHREADS
+#  define CxITERVAR(c)							\
+	((c)->blk_loop.iterdata						\
+	 ? (CxPADLOOP(cx) 						\
+	    ? &((c)->blk_loop.oldcurpad)[(PADOFFSET)(c)->blk_loop.iterdata]	\
+	    : &GvSV((GV*)(c)->blk_loop.iterdata))			\
+	 : (SV**)NULL)
+#  define CX_ITERDATA_SET(cx,idata)					\
+	cx->blk_loop.oldcurpad = PL_curpad;				\
+	if ((cx->blk_loop.iterdata = (idata)))				\
+	    cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));
+#else
+#  define CxITERVAR(c)		((c)->blk_loop.itervar)
+#  define CX_ITERDATA_SET(cx,ivar)					\
+	if ((cx->blk_loop.itervar = (SV**)(ivar)))			\
+	    cx->blk_loop.itersave = SvREFCNT_inc(*CxITERVAR(cx));
+#endif
+
+#define PUSHLOOP(cx, dat, s)						\
+	cx->blk_loop.label = PL_curcop->cop_label;			\
+	cx->blk_loop.resetsp = s - PL_stack_base;			\
 	cx->blk_loop.redo_op = cLOOP->op_redoop;			\
 	cx->blk_loop.next_op = cLOOP->op_nextop;			\
 	cx->blk_loop.last_op = cLOOP->op_lastop;			\
-	if (cx->blk_loop.itervar = (ivar))				\
-	    cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);\
 	cx->blk_loop.iterlval = Nullsv;					\
 	cx->blk_loop.iterary = Nullav;					\
-	cx->blk_loop.iterix = -1;
+	cx->blk_loop.iterix = -1;					\
+	CX_ITERDATA_SET(cx,dat);
 
 #define POPLOOP(cx)							\
-	{ struct block_loop cxloop;					\
-	  POPLOOP1(cx);							\
-	  POPLOOP2(); }
-
-#define POPLOOP1(cx)							\
-	cxloop = cx->blk_loop;	/* because DESTROY may clobber *cx */	\
-	newsp = PL_stack_base + cxloop.resetsp;
-
-#define POPLOOP2()							\
-	SvREFCNT_dec(cxloop.iterlval);					\
-	if (cxloop.itervar) {						\
-	    sv_2mortal(*cxloop.itervar);				\
-	    *cxloop.itervar = cxloop.itersave;				\
+	SvREFCNT_dec(cx->blk_loop.iterlval);				\
+	if (CxITERVAR(cx)) {						\
+	    SV **s_v_p = CxITERVAR(cx);					\
+	    sv_2mortal(*s_v_p);						\
+	    *s_v_p = cx->blk_loop.itersave;				\
 	}								\
-	if (cxloop.iterary && cxloop.iterary != PL_curstack)		\
-	    SvREFCNT_dec(cxloop.iterary);
+	if (cx->blk_loop.iterary && cx->blk_loop.iterary != PL_curstack)\
+	    SvREFCNT_dec(cx->blk_loop.iterary);
 
 /* context common to subroutines, evals and loops */
 struct block {
@@ -185,8 +268,8 @@ struct block {
 	cx->blk_oldretsp	= PL_retstack_ix,			\
 	cx->blk_oldpm		= PL_curpm,				\
 	cx->blk_gimme		= gimme;				\
-	DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n",	\
-		    (long)cxstack_ix, block_type[CxTYPE(cx)]); )
+	DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n",	\
+		    (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
 
 /* Exit a block (RETURN and LAST). */
 #define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--],			\
@@ -197,8 +280,8 @@ struct block {
 	PL_retstack_ix	 = cx->blk_oldretsp,				\
 	pm		 = cx->blk_oldpm,				\
 	gimme		 = cx->blk_gimme;				\
-	DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n",		\
-		    (long)cxstack_ix+1,block_type[CxTYPE(cx)]); )
+	DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",		\
+		    (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
 
 /* Continue a block elsewhere (NEXT and REDO). */
 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],			\
@@ -212,7 +295,7 @@ struct block {
 struct subst {
     I32		sbu_iters;
     I32		sbu_maxiters;
-    I32		sbu_safebase;
+    I32		sbu_rflags;
     I32		sbu_oldsave;
     bool	sbu_once;
     bool	sbu_rxtainted;
@@ -227,7 +310,7 @@ struct subst {
 };
 #define sb_iters	cx_u.cx_subst.sbu_iters
 #define sb_maxiters	cx_u.cx_subst.sbu_maxiters
-#define sb_safebase	cx_u.cx_subst.sbu_safebase
+#define sb_rflags	cx_u.cx_subst.sbu_rflags
 #define sb_oldsave	cx_u.cx_subst.sbu_oldsave
 #define sb_once		cx_u.cx_subst.sbu_once
 #define sb_rxtainted	cx_u.cx_subst.sbu_rxtainted
@@ -243,7 +326,7 @@ struct subst {
 #define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix],			\
 	cx->sb_iters		= iters,				\
 	cx->sb_maxiters		= maxiters,				\
-	cx->sb_safebase		= safebase,				\
+	cx->sb_rflags		= r_flags,				\
 	cx->sb_oldsave		= oldsave,				\
 	cx->sb_once		= once,					\
 	cx->sb_rxtainted	= rxtainted,				\
@@ -276,27 +359,77 @@ struct context {
 #define CXt_LOOP	3
 #define CXt_SUBST	4
 #define CXt_BLOCK	5
+#define CXt_FORMAT	6
 
 /* private flags for CXt_EVAL */
 #define CXp_REAL	0x00000100	/* truly eval'', not a lookalike */
+#define CXp_TRYBLOCK	0x00000200	/* eval{}, not eval'' or similar */
+
+#ifdef USE_ITHREADS
+/* private flags for CXt_LOOP */
+#  define CXp_PADVAR	0x00000100	/* itervar lives on pad, iterdata
+					   has pad offset; if not set,
+					   iterdata holds GV* */
+#  define CxPADLOOP(c)	(((c)->cx_type & (CXt_LOOP|CXp_PADVAR))		\
+			 == (CXt_LOOP|CXp_PADVAR))
+#endif
 
 #define CxTYPE(c)	((c)->cx_type & CXTYPEMASK)
-#define CxREALEVAL(c)	(((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL))
+#define CxREALEVAL(c)	(((c)->cx_type & (CXt_EVAL|CXp_REAL))		\
+			 == (CXt_EVAL|CXp_REAL))
+#define CxTRYBLOCK(c)	(((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK))	\
+			 == (CXt_EVAL|CXp_TRYBLOCK))
 
 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 
 /* "gimme" values */
+
+/*
+=for apidoc AmU||G_SCALAR
+Used to indicate scalar context.  See C<GIMME_V>, C<GIMME>, and
+L<perlcall>.
+
+=for apidoc AmU||G_ARRAY
+Used to indicate array context.  See C<GIMME_V>, C<GIMME> and
+L<perlcall>.
+
+=for apidoc AmU||G_VOID
+Used to indicate void context.  See C<GIMME_V> and L<perlcall>.
+
+=for apidoc AmU||G_DISCARD
+Indicates that arguments returned from a callback should be discarded.  See
+L<perlcall>.
+
+=for apidoc AmU||G_EVAL
+
+Used to force a Perl C<eval> wrapper around a callback.  See
+L<perlcall>.
+
+=for apidoc AmU||G_NOARGS
+
+Indicates that no arguments are being sent to a callback.  See
+L<perlcall>.
+
+=cut
+*/
+
 #define G_SCALAR	0
 #define G_ARRAY		1
 #define G_VOID		128	/* skip this bit when adding flags below */
 
-/* extra flags for perl_call_* routines */
+/* extra flags for Perl_call_* routines */
 #define G_DISCARD	2	/* Call FREETMPS. */
 #define G_EVAL		4	/* Assume eval {} around subroutine call. */
 #define G_NOARGS	8	/* Don't construct a @_ array. */
 #define G_KEEPERR      16	/* Append errors to $@, don't overwrite it */
 #define G_NODEBUG      32	/* Disable debugging at toplevel.  */
 
+/* flag bits for PL_in_eval */
+#define EVAL_NULL	0	/* not in an eval */
+#define EVAL_INEVAL	1	/* some enclosing scope is an eval */
+#define EVAL_WARNONLY	2	/* used by yywarn() when calling yyerror() */
+#define EVAL_KEEPERR	4	/* set by Perl_call_sv if G_KEEPERR */
+
 /* Support for switching (stack and block) contexts.
  * This ensures magic doesn't invalidate local stack and cx pointers.
  */
@@ -321,7 +454,7 @@ struct stackinfo {
     I32			si_type;	/* type of runlevel */
     struct stackinfo *	si_prev;
     struct stackinfo *	si_next;
-    I32 *		si_markbase;	/* where markstack begins for us.
+    I32			si_markoff;	/* offset where markstack begins for us.
 					 * currently used only with DEBUGGING,
 					 * but not #ifdef-ed for bincompat */
 };
@@ -333,9 +466,10 @@ typedef struct stackinfo PERL_SI;
 #define cxstack_max	(PL_curstackinfo->si_cxmax)
 
 #ifdef DEBUGGING
-#  define	SET_MARKBASE PL_curstackinfo->si_markbase = PL_markstack_ptr
+#  define	SET_MARK_OFFSET \
+    PL_curstackinfo->si_markoff = PL_markstack_ptr - PL_markstack
 #else
-#  define	SET_MARKBASE NOOP
+#  define	SET_MARK_OFFSET NOOP
 #endif
 
 #define PUSHSTACKi(type) \
@@ -351,16 +485,19 @@ typedef struct stackinfo PERL_SI;
 	AvFILLp(next->si_stack) = 0;					\
 	SWITCHSTACK(PL_curstack,next->si_stack);			\
 	PL_curstackinfo = next;						\
-	SET_MARKBASE;							\
+	SET_MARK_OFFSET;						\
     } STMT_END
 
 #define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
 
+/* POPSTACK works with PL_stack_sp, so it may need to be bracketed by
+ * PUTBACK/SPAGAIN to flush/refresh any local SP that may be active */
 #define POPSTACK \
     STMT_START {							\
+	djSP;								\
 	PERL_SI *prev = PL_curstackinfo->si_prev;			\
 	if (!prev) {							\
-	    PerlIO_printf(PerlIO_stderr(), "panic: POPSTACK\n");	\
+	    PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");		\
 	    my_exit(1);							\
 	}								\
 	SWITCHSTACK(PL_curstack,prev->si_stack);			\

contrib/perl5/cv.h

@@ -1,31 +1,32 @@
 /*    cv.h
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
  *
  */
 
-/* This structure much match the beginning of XPVFM */
+/* This structure much match XPVCV in B/C.pm and the beginning of XPVFM
+ * in sv.h  */
 
 struct xpvcv {
     char *	xpv_pv;		/* pointer to malloced string */
     STRLEN	xpv_cur;	/* length of xp_pv as a C string */
     STRLEN	xpv_len;	/* allocated size */
     IV		xof_off;	/* integer value */
-    double	xnv_nv;		/* numeric value, if any */
+    NV		xnv_nv;		/* numeric value, if any */
     MAGIC*	xmg_magic;	/* magic for scalar array */
     HV*		xmg_stash;	/* class package */
 
     HV *	xcv_stash;
     OP *	xcv_start;
     OP *	xcv_root;
-    void      (*xcv_xsub) _((CV* _CPERLproto));
+    void	(*xcv_xsub) (pTHXo_ CV*);
     ANY		xcv_xsubany;
     GV *	xcv_gv;
-    GV *	xcv_filegv;
-    long	xcv_depth;		/* >= 2 indicates recursive call */
+    char *	xcv_file;
+    long	xcv_depth;	/* >= 2 indicates recursive call */
     AV *	xcv_padlist;
     CV *	xcv_outside;
 #ifdef USE_THREADS
@@ -35,6 +36,16 @@ struct xpvcv {
     cv_flags_t	xcv_flags;
 };
 
+/*
+=for apidoc AmU||Nullcv
+Null CV pointer.
+
+=for apidoc Am|HV*|CvSTASH|CV* cv
+Returns the stash of the CV.
+
+=cut
+*/
+
 #define Nullcv Null(CV*)
 
 #define CvSTASH(sv)	((XPVCV*)SvANY(sv))->xcv_stash
@@ -43,7 +54,8 @@ struct xpvcv {
 #define CvXSUB(sv)	((XPVCV*)SvANY(sv))->xcv_xsub
 #define CvXSUBANY(sv)	((XPVCV*)SvANY(sv))->xcv_xsubany
 #define CvGV(sv)	((XPVCV*)SvANY(sv))->xcv_gv
-#define CvFILEGV(sv)	((XPVCV*)SvANY(sv))->xcv_filegv
+#define CvFILE(sv)	((XPVCV*)SvANY(sv))->xcv_file
+#define CvFILEGV(sv)	(gv_fetchfile(CvFILE(sv))
 #define CvDEPTH(sv)	((XPVCV*)SvANY(sv))->xcv_depth
 #define CvPADLIST(sv)	((XPVCV*)SvANY(sv))->xcv_padlist
 #define CvOUTSIDE(sv)	((XPVCV*)SvANY(sv))->xcv_outside
@@ -62,6 +74,7 @@ struct xpvcv {
 				   (esp. useful for special XSUBs) */
 #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 CvCLONE(cv)		(CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)		(CvFLAGS(cv) |= CVf_CLONE)
@@ -75,9 +88,11 @@ struct xpvcv {
 #define CvANON_on(cv)		(CvFLAGS(cv) |= CVf_ANON)
 #define CvANON_off(cv)		(CvFLAGS(cv) &= ~CVf_ANON)
 
+#ifdef PERL_XSUB_OLDSTYLE
 #define CvOLDSTYLE(cv)		(CvFLAGS(cv) & CVf_OLDSTYLE)
 #define CvOLDSTYLE_on(cv)	(CvFLAGS(cv) |= CVf_OLDSTYLE)
 #define CvOLDSTYLE_off(cv)	(CvFLAGS(cv) &= ~CVf_OLDSTYLE)
+#endif
 
 #define CvUNIQUE(cv)		(CvFLAGS(cv) & CVf_UNIQUE)
 #define CvUNIQUE_on(cv)		(CvFLAGS(cv) |= CVf_UNIQUE)
@@ -95,6 +110,10 @@ struct xpvcv {
 #define CvLOCKED_on(cv)		(CvFLAGS(cv) |= CVf_LOCKED)
 #define CvLOCKED_off(cv)	(CvFLAGS(cv) &= ~CVf_LOCKED)
 
+#define CvLVALUE(cv)		(CvFLAGS(cv) & CVf_LVALUE)
+#define CvLVALUE_on(cv)		(CvFLAGS(cv) |= CVf_LVALUE)
+#define CvLVALUE_off(cv)	(CvFLAGS(cv) &= ~CVf_LVALUE)
+
 #define CvEVAL(cv)		(CvUNIQUE(cv) && !SvFAKE(cv))
 #define CvEVAL_on(cv)		(CvUNIQUE_on(cv),SvFAKE_off(cv))
 #define CvEVAL_off(cv)		CvUNIQUE_off(cv)

contrib/perl5/deb.c

@@ -1,6 +1,6 @@
 /*    deb.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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,70 +13,81 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_DEB_C
 #include "perl.h"
 
+#if defined(PERL_IMPLICIT_CONTEXT)
 void
-deb(const char *pat, ...)
+Perl_deb_nocontext(const char *pat, ...)
 {
 #ifdef DEBUGGING
-    dTHR;
+    dTHX;
     va_list args;
-    register I32 i;
-    GV* gv = PL_curcop->cop_filegv;
-
-#ifdef USE_THREADS
-    PerlIO_printf(Perl_debug_log, "0x%lx (%s:%ld)\t",
-		  (unsigned long) thr,
-		  SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
-		  (long)PL_curcop->cop_line);
-#else
-    PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
-	SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
-	(long)PL_curcop->cop_line);
-#endif /* USE_THREADS */
-    for (i=0; i<PL_dlevel; i++)
-	PerlIO_printf(Perl_debug_log, "%c%c ",PL_debname[i],PL_debdelim[i]);
-
     va_start(args, pat);
-    (void) PerlIO_vprintf(Perl_debug_log,pat,args);
-    va_end( args );
+    vdeb(pat, &args);
+    va_end(args);
+#endif /* DEBUGGING */
+}
+#endif
+
+void
+Perl_deb(pTHX_ const char *pat, ...)
+{
+#ifdef DEBUGGING
+    va_list args;
+    va_start(args, pat);
+    vdeb(pat, &args);
+    va_end(args);
 #endif /* DEBUGGING */
 }
 
 void
-deb_growlevel(void)
+Perl_vdeb(pTHX_ const char *pat, va_list *args)
 {
 #ifdef DEBUGGING
-    PL_dlmax += 128;
-    Renew(PL_debname, PL_dlmax, char);
-    Renew(PL_debdelim, PL_dlmax, char);
+    dTHR;
+    char* file = CopFILE(PL_curcop);
+
+#ifdef USE_THREADS
+    PerlIO_printf(Perl_debug_log, "0x%"UVxf" (%s:%ld)\t",
+		  PTR2UV(thr),
+		  (file ? file : "<free>"),
+		  (long)CopLINE(PL_curcop));
+#else
+    PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
+		  (long)CopLINE(PL_curcop));
+#endif /* USE_THREADS */
+    (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
 #endif /* DEBUGGING */
 }
 
 I32
-debstackptrs(void)
+Perl_debstackptrs(pTHX)
 {
 #ifdef DEBUGGING
     dTHR;
-    PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
-	(unsigned long)PL_curstack, (unsigned long)PL_stack_base,
-	(long)*PL_markstack_ptr, (long)(PL_stack_sp-PL_stack_base),
-	(long)(PL_stack_max-PL_stack_base));
-    PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
-	(unsigned long)PL_mainstack, (unsigned long)AvARRAY(PL_curstack),
-	(long)PL_mainstack, (long)AvFILLp(PL_curstack), (long)AvMAX(PL_curstack));
+    PerlIO_printf(Perl_debug_log,
+		  "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
+		  PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
+		  (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
+		  (IV)(PL_stack_max-PL_stack_base));
+    PerlIO_printf(Perl_debug_log,
+		  "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
+		  PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
+		  PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
+		  PTR2UV(AvMAX(PL_curstack)));
 #endif /* DEBUGGING */
     return 0;
 }
 
 I32
-debstack(void)
+Perl_debstack(pTHX)
 {
 #ifdef DEBUGGING
     dTHR;
     I32 top = PL_stack_sp - PL_stack_base;
     register I32 i = top - 30;
-    I32 *markscan = PL_curstackinfo->si_markbase;
+    I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
 
     if (i < 0)
 	i = 0;
@@ -86,8 +97,9 @@ debstack(void)
 	    break;
 
 #ifdef USE_THREADS
-    PerlIO_printf(Perl_debug_log, i ? "0x%lx    =>  ...  " : "0x%lx    =>  ",
-		  (unsigned long) thr);
+    PerlIO_printf(Perl_debug_log,
+		  i ? "0x%"UVxf"    =>  ...  " : "0x%lx    =>  ",
+		  PTR2UV(thr));
 #else
     PerlIO_printf(Perl_debug_log, i ? "    =>  ...  " : "    =>  ");
 #endif /* USE_THREADS */

contrib/perl5/dosish.h

@@ -8,6 +8,7 @@
 #  define BIT_BUCKET "nul"
 #  define OP_BINARY O_BINARY
 #  define PERL_SYS_INIT(c,v) Perl_DJGPP_init(c,v)
+#  define init_os_extras Perl_init_os_extras
 #  include <signal.h>
 #  define HAS_UTIME
 #  define HAS_KILL
@@ -16,21 +17,9 @@
 #    define NO_LOCALECONV_MON_THOUSANDS_SEP
 #  endif
 #  ifdef USE_THREADS
-#    define NEED_PTHREAD_INIT
 #    define OLD_PTHREADS_API
-#    define YIELD pthread_yield(NULL)
-#    define DETACH(t)				\
-       STMT_START {				\
-         if (pthread_detach(&(t)->self)) {	\
-             MUTEX_UNLOCK(&(t)->mutex);		\
-             croak("panic: DETACH");		\
-         }					\
-       } STMT_END
-#    define pthread_mutexattr_default NULL
-#    define pthread_condattr_default NULL
-#    define pthread_addr_t any_t
-#    define PTHREAD_CREATE_JOINABLE (&err)
 #  endif
+#  define PERL_FS_VER_FMT	"%d_%d_%d"
 #else	/* DJGPP */
 #  ifdef WIN32
 #    define PERL_SYS_INIT(c,v)	Perl_win32_init(c,v)
@@ -41,9 +30,8 @@
 #  endif
 #endif	/* DJGPP */
 
-#define PERL_SYS_TERM() MALLOC_TERM
+#define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM
 #define dXSUB_SYS
-#define TMPPATH "plXXXXXX"
 
 /*
  * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were 
@@ -64,7 +52,7 @@
 
 /* USEMYBINMODE
  *	This symbol, if defined, indicates that the program should
- *	use the routine my_binmode(FILE *fp, char iotype) to insure
+ *	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.
  */
@@ -123,13 +111,4 @@
 #  define HAS_KILL
 #  define HAS_WAIT
 #  define HAS_CHOWN
-/*
- * This provides a layer of functions and macros to ensure extensions will
- * get to use the same RTL functions as the core.
- */
-#  ifndef HASATTRIBUTE
-#    ifndef PERL_OBJECT
-#      include <win32iop.h>
-#    endif
-#  endif
 #endif	/* WIN32 */

contrib/perl5/ebcdic.c

@@ -1,4 +1,5 @@
 #include "EXTERN.h"
+#define PERL_IN_EBCDIC_C
 #include "perl.h"
 
 /* in ASCII order, not that it matters */
@@ -14,7 +15,7 @@ ebcdic_control(int ch)
   	              ch = toupper(ch);
  
  	       if ((ctlp = strchr(controllablechars, ch)) == 0) {
-  	              die("unrecognised control character '%c'\n", ch);
+  	              Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
      	       }
  
         	if (ctlp == controllablechars)
@@ -24,9 +25,17 @@ ebcdic_control(int ch)
 	} else { /* Want uncontrol */
         	if (ch == '\177' || ch == -1)
                 	return('?');
+        	else if (ch == '\157')
+                	return('\177');
+        	else if (ch == '\174')
+                	return('\000');
+        	else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
+                	return('\036');
+        	else if (ch == '\155')
+                	return('\037');
         	else if (0 < ch && ch < (sizeof(controllablechars) - 1))
                 	return(controllablechars[ch+1]);
         	else
-                	die("invalid control request: '\\%03o'\n", ch & 0xFF);
+                	Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
 	}
 }

contrib/perl5/eg/cgi/dna_small_gif.uu

@@ -0,0 +1,63 @@
+begin 444 dna_small.gif
+M1TE&.#=A)0`J`.<``+9%&Y<R0M<F'ID\,!<07%<G1:P<0Q`A2Q`P;"L9/L$:
+M,"480N5"&RL7:4LD0T,G144[7BHL2B4?3\0I+"</)BQ.9KD0/S878\96$Z\@
+M(:\1*RL:3L0W&QL?2#4?9>@_&A$_5<I"&C`A3*,3-A`//9X<)\@Q(L`@.#\E
+M7K,R*R\T6)H++1L72T8=4207:T`G=JX..MD^&!$_;^)2$#T=7S`79AL7.A$3
+M1-=%#^,Q&QT_:C8=1!L86]\R#4M":4H76R,515HZ4"477G@T,J\;(X(@/$\7
+M."4A2N9;$"DZ6RL34-8I$34A73P86I84/\87%1`0/V,B2"0<0N!(%QPH91<6
+M2=!5$3(=73(E23`/,!L4.=$Z'-MH%>`Y#3$=2"=#59M((H88,GP\/]X^&+$R
+M$"(79"DF33(93"$86=%;&"T4/=Y"&\\A$Q4Z4!`62*T4-Q4B9+X1*BH96SP?
+M1<0D/3(F<-TM$!`=5:H.(!<64C$W?#8J3*`S(S<@3=8V%K$](QT.6Q`43AL4
+M1:$D,;<0,\X9&,8])\@=$A(U244S5U,D6Q<V;]\I&&<K/8!*.R044>=/#YH>
+M08$I1B,09S$35R(:4C0?<19$7<D^#Q`>5!()-;4702M`=;56)A`25,0K%"X<
+M83`N>K`H'HDS*1`40,M&%!<@7M,_$A<N2L)%%18E4^<M$A@=5=0Q$Q`E311*
+M2L8E&2D<7Q\A7P\80B48,%E/8[1-'J4/-"H<3"PA1$,T?Q<15R44,R,A4AL/
+M,^M4%2,07!L+,[\[&!P4520I:C(9.=54$[,2/M-)&RP?7M=(%1$J8<-,%2H@
+M4B,=51436^]2"!X<1A<44RD</>E+#%0>0S0/:4PJ9I,F-6DG420Y<"@09R,0
+M-V$R/R4M<:\H0!(H410Z:AT27&4Q9"L@;=1%(MA-$M5+#RL4+M8Z&AT<7[<:
+M(-QA&2,36R$++B(84!0:5ALO:K$A.]X?&!$84V@;/SX<6Q`;2$(B2QD21W4J
+M1=TW&@```````````````"P`````)0`J```(_@!]:(N'18\W%15T$1N'C)V?
+M0_HH,<$G9YBX!C6<3;+T@AZ-)K@\O*"!KP^$>"KVA`L3*8P3)^5ZA)@B:AH+
+M9];F7.$Q+!`!0=*<E3'5K(:EHS2N%"AP*Y(\&##H6(!A:!XU99B*H?%4IDF?
+M!8'<"-F%9I*TH8A83:*TXYD!J83D$0ICI-NE(:O8I6&FJ$64$M5$M%!3PU,F
+M2UJD"9I41E824WT2G?BV-!$(!`=,+<IF!P>.%",&P7J"9XB82L5,48F5K,:"
+M'94FU='6;!*R3T->E"%&95DR"`/6P,I0PDF)0SG8($$RJN0R`FI(H7$A2]VD
+M*^^L_6(T3U*V%XH"_AB:HDS8H$AO5@R:P,8.I%^.:*AC(>Z!'":6RC`1L@W-
+M%1Q/,%(.'5+1`<D^74R@P2#?T*'/$"%@\(L5Y?RAB!SO3#*,-6CL44\4]C1#
+MR0Q3C&&"!AH08@(#:Y2C@`&1---,.#)\T84=R##`0",H++8#)34,@X80R:"`
+M0A<]?'#.!";`TDH.8QBB0354A!,*)WI0\<D\YJRQ3PE[V",(.D#48$T9GO22
+MA0.BC,)'*]3TP,`^\_#QA0P@>`/"*]=<HX\3"C!BAQV%5",$+Z0,0X,UL3SB
+M#B[NN$'/,A&,$L,Y[-BASR(@<**("E^,0(<&;[QA0@^,3%",#2S8H,01_LX0
+M`(0:W%`@13#TN+'#&LK@0$T0VER##50*Q/%-%%&H$`0#K7"`!B^X/`),()F0
+M0PNT[K#BRBS1-!("`^=,$8`D="B`QRW?1**+-I?(X$@(L(R2AQ8+Y,*#-*YX
+MH(00'1Q!CSI,U'!%)^_%4(X&FUB@01$.@*!#$I?4D48I&1BA!2*HD%))(.+T
+MYTEOT3B#PB/U4(,$%QD0(<\QX^CRBC=)@%`!&+:<<TH&M*C1"RJX'-'.'`YX
+M<H0@<)#"0CX+I%`*-%:4L@XFS`#[11M?U-))"&RP84LWZL!A1A^YH.*)!)3<
+MHXX6L]P3"!I`H/!`*>90`PD.F'3SR@-AG)`&_A=3'"**#[J(P<<I@YCA2@32
+M!,*+Q9H`(XT2'O2RS"CGS.U9!K>0^C0&S/#1""(ZI)'&*6,,$842N%Q!@3NK
+M"R'%%4KP0D(Q?"`S!3)<I#!!".68$T(IMHP#>BVE(/$+)#-80<PTLBRP^@$>
+M<+,`-[QH$LP+0_P!1C>=S("!,N>8XP<8H6131!B;3`#&#)"DTH(L5#P0S#W+
+MQ)*`$K1HHD4^;E!2QP%:B``&4H$,/Y2C$Y*(1%0(00A)@```77B"*$0@#3>P
+MP&PU4`,^H!","P!!$')0P^H6((I5L"$'.;``';[Q!@-\PP"<B$<]EG"(#*C"
+M%-(@0":\L0U?D&`#_L50@33.(`4M4``=&4@'+-9!!P9JP`#9T$4H=*$+!#1B
+M'3A(`SYH`81'B.,(XJ@"":0(CDRPH@/<"$88V+"%$N#A&)MPX0N2H`L]C&,<
+MEW"$%6:0BCV@XPIH>$0?)M$`<92!%OG8Q3#@(`U2C*)%9-!`&`K`!!EP0@80
+M2,0M;I$.:"C#"D.@P#UJ``]GT"*,K%B&*0+!@TFH8VV*0$(:_/`)?7@#'.'0
+M@R[H8``\:&`,=NC"*"B@!2TTHP5]N((TEH&`<)B"!PU`0RQ(P8MNS``9K6@%
+M'W31AG%$(BZ2&((PA-&#'I"A&`F8!DD\\`H6-,.,X'B'%,+R#FX4`PS&_L!$
+M.4R0#7W<0@%O2,07$($#9@C3"%C8P!5H88\]J$,"-E!;(.X@C5T<`!65V,40
+M,'&(0C!"`1JP@"3TH`T9=&,5JRC$-]+1`U%TP@@[^,$>Z$&*0%1A%XFK`BFD
+MX0L6Y"(#A_A$#[JPC@%\@1@02`(SJ#&&.`A@'\&$!AALX(4Y="`/TA"",UA!
+M@%W<8!*\$`$@C%""+G1A"9AP!"<>9@ME*)$0F\C!$I8`B3\TP@%'@$(QH$`"
+M)8@#'(B0ACB`P`,@%&,'9"##)S`1!&)\`0)^&,,^+$`("QC"#D\X!":HX0!<
+ML(`&-O!%,&H@BS#F0AI'`!LO^"`,/OS!%KJ0_H0HEA`E27Q#%T%X0"%"@`1E
+M2,`!:F!%+Q#A!G)40A!HP`4OFK`#-13#`?I(QCW38(Q/9&``%0#!);01BE>$
+M@!TZNL81$G`!-]2!&&5@A1N&T0Q<,$$$%*!``BR1A5$PPPH<74$%]*`#$.RA
+M`(VP@#`X$(`7``(%T=@`.5Q`C@:0`P[)D$4'$H`."MB#"908Q=X@,01B9$(7
+MG'A%`#8!"QSL@PUAL,0==M"")CQCP4)0QQUDP806H&,!T]A!`EH@AC2P`P,^
+MT`,*NN%-&&T!&L@X!!Y^<(4.D(,%E>A`,T20C#IXL`6-:,`5F+"#!W"@'%OH
+MA`IJ$5(#;`(;AV/'FA103(EV+(,>GHB&&ZJ`!D'<X0[-N$(N@)$+4$C@`<(`
+M$(&/<8Q;7$,1UT"``+>P!57`X1F9D`4<W$`"4MP@$ZYX\B-"004Y2$`.HT@%
+M)@IAB#><0!]FB(<I.(&`(7P"%GPPQ3)F`0YB0"$0@8"")L!Q!RH`8A&AL,8L
+BR!$$,@@#&5OX!1V.\85XA.,.,A##!T2!AP@LXP#;"`@`.P``
+end

contrib/perl5/eg/cgi/file_upload.cgi

@@ -1,5 +1,6 @@
 #!/usr/local/bin/perl -w
 
+use strict 'refs';
 use lib '..';
 use CGI qw(:standard);
 use CGI::Carp qw/fatalsToBrowser/;
@@ -11,14 +12,14 @@ print strong("Version "),$CGI::VERSION,p;
 print h1("File Upload Example"),
     'This example demonstrates how to prompt the remote user to
     select a remote file for uploading. ',
-    strong("This feature only works with Netscape 2.0 browsers."),
+    strong("This feature only works with Netscape 2.0 or greater, or IE 4.0 or greater."),
     p,
     'Select the ',cite('browser'),' button to choose a text file
     to upload.  When you press the submit button, this script
     will count the number of lines, words, and characters in
     the file.';
 
-@types = ('count lines','count words','count characters');
+my @types = ('count lines','count words','count characters');
 
 # Start a multipart form.
 print start_multipart_form(),
@@ -31,9 +32,10 @@ print start_multipart_form(),
     endform;
 
 # Process the form if there is a file name entered
-if ($file = param('filename')) {
-    $tmpfile=tmpFileName($file);
-    $mimetype = uploadInfo($file)->{'Content-Type'} || '';
+if (my $file = param('filename')) {
+    my %stats;
+    my $tmpfile=tmpFileName($file);
+    my $mimetype = uploadInfo($file)->{'Content-Type'} || '';
     print hr(),
           h2($file),
           h3($tmpfile),

contrib/perl5/eg/cgi/index.html

@@ -54,7 +54,8 @@
   <li><a href="crash.txt">Look at its source code</a>
 </ul>
 
-<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM>
+<EM>The Following Scripts Work with Netscape Navigator 2.0 and higher,
+or Internet Explorer 3.0 and higher</EM>
 
 <H2> Prompt for a file to upload and process it</H2>
 <UL>
@@ -107,12 +108,12 @@
 <HR>
 <MENU>
   <LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A>
-  <LI> <A HREF="../../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
+  <LI> <A HREF="../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
 </MENU>
 <HR>
 <ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br>
 <a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS>
 <!-- hhmts start -->
-Last modified: Tue May 19 22:16:43 EDT 1998
+Last modified: Wed Jun 23 15:31:47 EDT 1999
 <!-- hhmts end -->
 </BODY> </HTML>

contrib/perl5/eg/cgi/wilogo_gif.uu

@@ -0,0 +1,13 @@
+begin 444 wilogo.gif
+M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO
+M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B
+M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3(
+M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G
+M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J)
+M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X"
+M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#*
+M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ
+MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7
+M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+
+(KPA.EJ```#L`
+end

contrib/perl5/ext/B/B.pm

@@ -6,15 +6,15 @@
 #      License or the Artistic License, as specified in the README file.
 #
 package B;
-require DynaLoader;
+use XSLoader ();
 require Exporter;
-@ISA = qw(Exporter DynaLoader);
-@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(minus_c ppname
 		class peekop cast_I32 cstring cchar hash threadsv_names
-		main_root main_start main_cv svref_2object
+		main_root main_start main_cv svref_2object opnumber amagic_generation
 		walkoptree walkoptree_slow walkoptree_exec walksymtable
 		parents comppadlist sv_undef compile_stats timing_info init_av);
-
+sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';
 @B::NULL::ISA = 'B::SV';
@@ -38,10 +38,9 @@ use strict;
 @B::UNOP::ISA = 'B::OP';
 @B::BINOP::ISA = 'B::UNOP';
 @B::LOGOP::ISA = 'B::UNOP';
-@B::CONDOP::ISA = 'B::UNOP';
 @B::LISTOP::ISA = 'B::BINOP';
 @B::SVOP::ISA = 'B::OP';
-@B::GVOP::ISA = 'B::OP';
+@B::PADOP::ISA = 'B::OP';
 @B::PVOP::ISA = 'B::OP';
 @B::CVOP::ISA = 'B::OP';
 @B::LOOP::ISA = 'B::LISTOP';
@@ -65,10 +64,6 @@ sub debug {
     walkoptree_debug($value);
 }
 
-# sub OPf_KIDS;
-# add to .xs for perl5.002
-sub OPf_KIDS () { 4 }
-
 sub class {
     my $obj = shift;
     my $name = ref $obj;
@@ -81,7 +76,7 @@ sub parents { \@parents }
 # For debugging
 sub peekop {
     my $op = shift;
-    return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+    return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
 }
 
 sub walkoptree_slow {
@@ -112,6 +107,11 @@ sub timing_info {
 }
 
 my %symtable;
+
+sub clearsym {
+    %symtable = ();
+}
+
 sub savesym {
     my ($obj, $value) = @_;
 #    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
@@ -135,37 +135,26 @@ sub walkoptree_exec {
 	}
 	savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
 	$op->$method($level);
-	$ppname = $op->ppaddr;
-	if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+	$ppname = $op->name;
+	if ($ppname =~
+	    /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/)
+	{
 	    print $prefix, uc($1), " => {\n";
 	    walkoptree_exec($op->other, $method, $level + 1);
 	    print $prefix, "}\n";
-	} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+	} elsif ($ppname eq "match" || $ppname eq "subst") {
 	    my $pmreplstart = $op->pmreplstart;
 	    if ($$pmreplstart) {
 		print $prefix, "PMREPLSTART => {\n";
 		walkoptree_exec($pmreplstart, $method, $level + 1);
 		print $prefix, "}\n";
 	    }
-	} elsif ($ppname eq "pp_substcont") {
+	} elsif ($ppname eq "substcont") {
 	    print $prefix, "SUBSTCONT => {\n";
 	    walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
 	    print $prefix, "}\n";
 	    $op = $op->other;
-	} elsif ($ppname eq "pp_cond_expr") {
-	    # pp_cond_expr never returns op_next
-	    print $prefix, "TRUE => {\n";
-	    walkoptree_exec($op->true, $method, $level + 1);
-	    print $prefix, "}\n";
-	    $op = $op->false;
-	    redo;
-	} elsif ($ppname eq "pp_range") {
-	    print $prefix, "TRUE => {\n";
-	    walkoptree_exec($op->true, $method, $level + 1);
-	    print $prefix, "}\n", $prefix, "FALSE => {\n";
-	    walkoptree_exec($op->false, $method, $level + 1);
-	    print $prefix, "}\n";
-	} elsif ($ppname eq "pp_enterloop") {
+	} elsif ($ppname eq "enterloop") {
 	    print $prefix, "REDO => {\n";
 	    walkoptree_exec($op->redoop, $method, $level + 1);
 	    print $prefix, "}\n", $prefix, "NEXT => {\n";
@@ -173,7 +162,7 @@ sub walkoptree_exec {
 	    print $prefix, "}\n", $prefix, "LAST => {\n";
 	    walkoptree_exec($op->lastop,  $method, $level + 1);
 	    print $prefix, "}\n";
-	} elsif ($ppname eq "pp_subst") {
+	} elsif ($ppname eq "subst") {
 	    my $replstart = $op->pmreplstart;
 	    if ($$replstart) {
 		print $prefix, "SUBST => {\n";
@@ -187,9 +176,12 @@ sub walkoptree_exec {
 sub walksymtable {
     my ($symref, $method, $recurse, $prefix) = @_;
     my $sym;
+    my $ref;
     no strict 'vars';
     local(*glob);
-    while (($sym, *glob) = each %$symref) {
+    $prefix = '' unless defined $prefix;
+    while (($sym, $ref) = each %$symref) {
+	*glob = "*main::".$prefix.$sym;
 	if ($sym =~ /::$/) {
 	    $sym = $prefix . $sym;
 	    if ($sym ne "main::" && &$recurse($sym)) {
@@ -267,7 +259,7 @@ sub walksymtable {
     }
 }
 
-bootstrap B;
+XSLoader::load 'B';
 
 1;
 
@@ -428,6 +420,10 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =over 4
 
+=item is_empty
+
+This method returns TRUE if the GP field of the GV is NULL.
+
 =item NAME
 
 =item STASH
@@ -450,6 +446,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =item LINE
 
+=item FILE
+
 =item FILEGV
 
 =item GvREFCNT
@@ -518,7 +516,7 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =item GV
 
-=item FILEGV
+=item FILE
 
 =item DEPTH
 
@@ -556,8 +554,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
 
 =head2 OP-RELATED CLASSES
 
-B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
-B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
+B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
+B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 These classes correspond in
 the obvious way to the underlying C structures of similar names. The
 inheritance hierarchy mimics the underlying C "inheritance". Access
@@ -572,9 +570,14 @@ leading "class indication" prefix removed (op_).
 
 =item sibling
 
+=item name
+
+This returns the op name as a string (e.g. "add", "rv2av").
+
 =item ppaddr
 
-This returns the function name as a string (e.g. pp_add, pp_rv2av).
+This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
+"PL_ppaddr[OP_RV2AV]").
 
 =item desc
 
@@ -617,16 +620,6 @@ This returns the op description from the global C PL_op_desc array
 
 =back
 
-=head2 B::CONDOP METHODS
-
-=over 4
-
-=item true
-
-=item false
-
-=back
-
 =head2 B::LISTOP METHOD
 
 =over 4
@@ -661,13 +654,15 @@ This returns the op description from the global C PL_op_desc array
 
 =item sv
 
+=item gv
+
 =back
 
-=head2 B::GVOP METHOD
+=head2 B::PADOP METHOD
 
 =over 4
 
-=item gv
+=item padix
 
 =back
 
@@ -699,7 +694,7 @@ This returns the op description from the global C PL_op_desc array
 
 =item stash
 
-=item filegv
+=item file
 
 =item cop_seq
 
@@ -751,6 +746,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>.
 
 Returns the SV object corresponding to the C variable C<sv_no>.
 
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
 =item walkoptree(OP, METHOD)
 
 Does a tree-walk of the syntax tree based at OP and calls METHOD on
@@ -817,11 +816,6 @@ preceding the first "::". This is used to turn "B::UNOP" into
 In a perl compiled for threads, this returns a list of the special
 per-thread threadsv variables.
 
-=item byteload_fh(FILEHANDLE)
-
-Load the contents of FILEHANDLE as bytecode. See documentation for
-the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
-
 =back
 
 =head1 AUTHOR

contrib/perl5/ext/B/B.xs

@@ -7,18 +7,18 @@
  *
  */
 
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
-#include "INTERN.h"
 
 #ifdef PERL_OBJECT
-#undef op_name
-#undef opargs 
-#undef op_desc
-#define op_name (pPerl->Perl_get_op_names())
-#define opargs (pPerl->Perl_get_opargs())
-#define op_desc (pPerl->Perl_get_op_descs())
+#undef PL_op_name
+#undef PL_opargs 
+#undef PL_op_desc
+#define PL_op_name (get_op_names())
+#define PL_opargs (get_opargs())
+#define PL_op_desc (get_op_descs())
 #endif
 
 #ifdef PerlIO
@@ -53,15 +53,14 @@ typedef enum {
     OPc_UNOP,	/* 2 */
     OPc_BINOP,	/* 3 */
     OPc_LOGOP,	/* 4 */
-    OPc_CONDOP,	/* 5 */
-    OPc_LISTOP,	/* 6 */
-    OPc_PMOP,	/* 7 */
-    OPc_SVOP,	/* 8 */
-    OPc_GVOP,	/* 9 */
-    OPc_PVOP,	/* 10 */
-    OPc_CVOP,	/* 11 */
-    OPc_LOOP,	/* 12 */
-    OPc_COP	/* 13 */
+    OPc_LISTOP,	/* 5 */
+    OPc_PMOP,	/* 6 */
+    OPc_SVOP,	/* 7 */
+    OPc_PADOP,	/* 8 */
+    OPc_PVOP,	/* 9 */
+    OPc_CVOP,	/* 10 */
+    OPc_LOOP,	/* 11 */
+    OPc_COP	/* 12 */
 } opclass;
 
 static char *opclassnames[] = {
@@ -70,11 +69,10 @@ static char *opclassnames[] = {
     "B::UNOP",
     "B::BINOP",
     "B::LOGOP",
-    "B::CONDOP",
     "B::LISTOP",
     "B::PMOP",
     "B::SVOP",
-    "B::GVOP",
+    "B::PADOP",
     "B::PVOP",
     "B::CVOP",
     "B::LOOP",
@@ -83,8 +81,10 @@ static char *opclassnames[] = {
 
 static int walkoptree_debug = 0;	/* Flag for walkoptree debug hook */
 
+static SV *specialsv_list[4];
+
 static opclass
-cc_opclass(OP *o)
+cc_opclass(pTHX_ OP *o)
 {
     if (!o)
 	return OPc_NULL;
@@ -95,7 +95,12 @@ cc_opclass(OP *o)
     if (o->op_type == OP_SASSIGN)
 	return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 
-    switch (opargs[o->op_type] & OA_CLASS_MASK) {
+#ifdef USE_ITHREADS
+    if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+	return OPc_PADOP;
+#endif
+
+    switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
     case OA_BASEOP:
 	return OPc_BASEOP;
 
@@ -108,9 +113,6 @@ cc_opclass(OP *o)
     case OA_LOGOP:
 	return OPc_LOGOP;
 
-    case OA_CONDOP:
-	return OPc_CONDOP;
-
     case OA_LISTOP:
 	return OPc_LISTOP;
 
@@ -120,11 +122,19 @@ cc_opclass(OP *o)
     case OA_SVOP:
 	return OPc_SVOP;
 
-    case OA_GVOP:
-	return OPc_GVOP;
+    case OA_PADOP:
+	return OPc_PADOP;
 
-    case OA_PVOP:
-	return OPc_PVOP;
+    case OA_PVOP_OR_SVOP:
+        /*
+         * Character translations (tr///) are usually a PVOP, keeping a 
+         * pointer to a table of shorts used to look up translations.
+         * Under utf8, however, a simple table isn't practical; instead,
+         * the OP is an SVOP, and the SV is a reference to a swash
+         * (i.e., an RV pointing to an HV).
+         */
+	return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+		? OPc_SVOP : OPc_PVOP;
 
     case OA_LOOP:
 	return OPc_LOOP;
@@ -150,11 +160,14 @@ cc_opclass(OP *o)
 	 * return OPc_UNOP so that walkoptree can find our children. If
 	 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 	 * (no argument to the operator) it's an OP; with OPf_REF set it's
-	 * a GVOP (and op_gv is the GV for the filehandle argument).
+	 * an SVOP (and op_sv is the GV for the filehandle argument).
 	 */
 	return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
-		(o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
-
+#ifdef USE_ITHREADS
+		(o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+#else
+		(o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+#endif
     case OA_LOOPEXOP:
 	/*
 	 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
@@ -173,47 +186,47 @@ cc_opclass(OP *o)
 	    return OPc_PVOP;
     }
     warn("can't determine class of operator %s, assuming BASEOP\n",
-	 op_name[o->op_type]);
+	 PL_op_name[o->op_type]);
     return OPc_BASEOP;
 }
 
 static char *
-cc_opclassname(OP *o)
+cc_opclassname(pTHX_ OP *o)
 {
-    return opclassnames[cc_opclass(o)];
+    return opclassnames[cc_opclass(aTHX_ o)];
 }
 
 static SV *
-make_sv_object(SV *arg, SV *sv)
+make_sv_object(pTHX_ SV *arg, SV *sv)
 {
     char *type = 0;
     IV iv;
     
-    for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) {
-	if (sv == PL_specialsv_list[iv]) {
+    for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+	if (sv == specialsv_list[iv]) {
 	    type = "B::SPECIAL";
 	    break;
 	}
     }
     if (!type) {
 	type = svclassnames[SvTYPE(sv)];
-	iv = (IV)sv;
+	iv = PTR2IV(sv);
     }
     sv_setiv(newSVrv(arg, type), iv);
     return arg;
 }
 
 static SV *
-make_mg_object(SV *arg, MAGIC *mg)
+make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 {
-    sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+    sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
     return arg;
 }
 
 static SV *
-cstring(SV *sv)
+cstring(pTHX_ SV *sv)
 {
-    SV *sstr = newSVpv("", 0);
+    SV *sstr = newSVpvn("", 0);
     STRLEN len;
     char *s;
 
@@ -264,9 +277,9 @@ cstring(SV *sv)
 }
 
 static SV *
-cchar(SV *sv)
+cchar(pTHX_ SV *sv)
 {
-    SV *sstr = newSVpv("'", 0);
+    SV *sstr = newSVpvn("'", 1);
     STRLEN n_a;
     char *s = SvPV(sv, n_a);
 
@@ -303,76 +316,8 @@ cchar(SV *sv)
     return sstr;
 }
 
-#ifdef INDIRECT_BGET_MACROS
-void freadpv(U32 len, void *data)
-{
-    New(666, pv.xpv_pv, len, char);
-    fread(pv.xpv_pv, 1, len, (FILE*)data);
-    pv.xpv_len = len;
-    pv.xpv_cur = len - 1;
-}
-
-void byteload_fh(InputStream fp)
-{
-    struct bytestream bs;
-    bs.data = fp;
-    bs.fgetc = (int(*) _((void*)))fgetc;
-    bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
-    bs.freadpv = freadpv;
-    byterun(bs);
-}
-
-static int fgetc_fromstring(void *data)
-{
-    char **strp = (char **)data;
-    return *(*strp)++;
-}
-
-static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
-			    void *data)
-{
-    char **strp = (char **)data;
-    size_t len = elemsize * nelem;
-    
-    memcpy(argp, *strp, len);
-    *strp += len;
-    return (int)len;
-}
-
-static void freadpv_fromstring(U32 len, void *data)
-{
-    char **strp = (char **)data;
-    
-    New(666, pv.xpv_pv, len, char);
-    memcpy(pv.xpv_pv, *strp, len);
-    pv.xpv_len = len;
-    pv.xpv_cur = len - 1;
-    *strp += len;
-}    
-
-void byteload_string(char *str)
-{
-    struct bytestream bs;
-    bs.data = &str;
-    bs.fgetc = fgetc_fromstring;
-    bs.fread = fread_fromstring;
-    bs.freadpv = freadpv_fromstring;
-    byterun(bs);
-}
-#else
-void byteload_fh(InputStream fp)
-{
-    byterun(fp);
-}
-
-void byteload_string(char *str)
-{
-    croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
-}    
-#endif /* INDIRECT_BGET_MACROS */
-
 void
-walkoptree(SV *opsv, char *method)
+walkoptree(pTHX_ SV *opsv, char *method)
 {
     dSP;
     OP *o;
@@ -380,7 +325,7 @@ walkoptree(SV *opsv, char *method)
     if (!SvROK(opsv))
 	croak("opsv is not a reference");
     opsv = sv_mortalcopy(opsv);
-    o = (OP*)SvIV((SV*)SvRV(opsv));
+    o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
     if (walkoptree_debug) {
 	PUSHMARK(sp);
 	XPUSHs(opsv);
@@ -395,8 +340,8 @@ walkoptree(SV *opsv, char *method)
 	OP *kid;
 	for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 	    /* Use the same opsv. Rely on methods not to mess it up. */
-	    sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
-	    walkoptree(opsv, method);
+	    sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
+	    walkoptree(aTHX_ opsv, method);
 	}
     }
 }
@@ -405,11 +350,10 @@ typedef OP	*B__OP;
 typedef UNOP	*B__UNOP;
 typedef BINOP	*B__BINOP;
 typedef LOGOP	*B__LOGOP;
-typedef CONDOP	*B__CONDOP;
 typedef LISTOP	*B__LISTOP;
 typedef PMOP	*B__PMOP;
 typedef SVOP	*B__SVOP;
-typedef GVOP	*B__GVOP;
+typedef PADOP	*B__PADOP;
 typedef PVOP	*B__PVOP;
 typedef LOOP	*B__LOOP;
 typedef COP	*B__COP;
@@ -435,12 +379,21 @@ MODULE = B	PACKAGE = B	PREFIX = B_
 PROTOTYPES: DISABLE
 
 BOOT:
-    INIT_SPECIALSV_LIST;
+{
+    HV *stash = gv_stashpvn("B", 1, TRUE);
+    AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+    specialsv_list[0] = Nullsv;
+    specialsv_list[1] = &PL_sv_undef;
+    specialsv_list[2] = &PL_sv_yes;
+    specialsv_list[3] = &PL_sv_no;
+#include "defsubs.h"
+}
 
 #define B_main_cv()	PL_main_cv
 #define B_init_av()	PL_initav
 #define B_main_root()	PL_main_root
 #define B_main_start()	PL_main_start
+#define B_amagic_generation()	PL_amagic_generation
 #define B_comppadlist()	(PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 #define B_sv_undef()	&PL_sv_undef
 #define B_sv_yes()	&PL_sv_yes
@@ -458,6 +411,9 @@ B_main_root()
 B::OP
 B_main_start()
 
+long 
+B_amagic_generation()
+
 B::AV
 B_comppadlist()
 
@@ -477,6 +433,8 @@ void
 walkoptree(opsv, method)
 	SV *	opsv
 	char *	method
+    CODE:
+	walkoptree(aTHX_ opsv, method);
 
 int
 walkoptree_debug(...)
@@ -487,20 +445,7 @@ walkoptree_debug(...)
     OUTPUT:
 	RETVAL
 
-int
-byteload_fh(fp)
-	InputStream    fp
-    CODE:
-	byteload_fh(fp);
-	RETVAL = 1;
-    OUTPUT:
-	RETVAL
-
-void
-byteload_string(str)
-	char *	str
-
-#define address(sv) (IV)sv
+#define address(sv) PTR2IV(sv)
 
 IV
 address(sv)
@@ -514,7 +459,28 @@ svref_2object(sv)
 	    croak("argument is not a reference");
 	RETVAL = (SV*)SvRV(sv);
     OUTPUT:
-	RETVAL
+	RETVAL              
+
+void
+opnumber(name)
+char *	name
+CODE:
+{
+ int i; 
+ IV  result = -1;
+ ST(0) = sv_newmortal();
+ if (strncmp(name,"pp_",3) == 0)
+   name += 3;
+ for (i = 0; i < PL_maxo; i++)
+  {
+   if (strcmp(name, PL_op_name[i]) == 0)
+    {
+     result = i;
+     break;
+    }
+  }
+ sv_setiv(ST(0),result);
+}
 
 void
 ppname(opnum)
@@ -523,7 +489,7 @@ ppname(opnum)
 	ST(0) = sv_newmortal();
 	if (opnum >= 0 && opnum < PL_maxo) {
 	    sv_setpvn(ST(0), "pp_", 3);
-	    sv_catpv(ST(0), op_name[opnum]);
+	    sv_catpv(ST(0), PL_op_name[opnum]);
 	}
 
 void
@@ -533,11 +499,10 @@ hash(sv)
 	char *s;
 	STRLEN len;
 	U32 hash = 0;
-	char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */
+	char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 	s = SvPV(sv, len);
-	while (len--)
-	    hash = hash * 33 + *s++;
-	sprintf(hexhash, "0x%x", hash);
+	PERL_HASH(hash, s, len);
+	sprintf(hexhash, "0x%"UVxf, (UV)hash);
 	ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 
 #define cast_I32(foo) (I32)foo
@@ -553,10 +518,18 @@ minus_c()
 SV *
 cstring(sv)
 	SV *	sv
+    CODE:
+	RETVAL = cstring(aTHX_ sv);
+    OUTPUT:
+	RETVAL
 
 SV *
 cchar(sv)
 	SV *	sv
+    CODE:
+	RETVAL = cchar(aTHX_ sv);
+    OUTPUT:
+	RETVAL
 
 void
 threadsv_names()
@@ -567,13 +540,13 @@ threadsv_names()
 
 	EXTEND(sp, len);
 	for (i = 0; i < len; i++)
-	    PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1)));
+	    PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 #endif
 
 
 #define OP_next(o)	o->op_next
 #define OP_sibling(o)	o->op_sibling
-#define OP_desc(o)	op_desc[o->op_type]
+#define OP_desc(o)	PL_op_desc[o->op_type]
 #define OP_targ(o)	o->op_targ
 #define OP_type(o)	o->op_type
 #define OP_seq(o)	o->op_seq
@@ -591,18 +564,32 @@ OP_sibling(o)
 	B::OP		o
 
 char *
-OP_ppaddr(o)
+OP_name(o)
 	B::OP		o
     CODE:
 	ST(0) = sv_newmortal();
-	sv_setpvn(ST(0), "pp_", 3);
-	sv_catpv(ST(0), op_name[o->op_type]);
+	sv_setpv(ST(0), PL_op_name[o->op_type]);
+
+
+char *
+OP_ppaddr(o)
+	B::OP		o
+    PREINIT:
+	int i;
+	SV *sv = sv_newmortal();
+    CODE:
+	sv_setpvn(sv, "PL_ppaddr[OP_", 13);
+	sv_catpv(sv, PL_op_name[o->op_type]);
+	for (i=13; i<SvCUR(sv); ++i)
+	    SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
+	sv_catpv(sv, "]");
+	ST(0) = sv;
 
 char *
 OP_desc(o)
 	B::OP		o
 
-U16
+PADOFFSET
 OP_targ(o)
 	B::OP		o
 
@@ -646,19 +633,6 @@ B::OP
 LOGOP_other(o)
 	B::LOGOP	o
 
-#define CONDOP_true(o)	o->op_true
-#define CONDOP_false(o)	o->op_false
-
-MODULE = B	PACKAGE = B::CONDOP		PREFIX = CONDOP_
-
-B::OP
-CONDOP_true(o)
-	B::CONDOP	o
-
-B::OP
-CONDOP_false(o)
-	B::CONDOP	o
-
 #define LISTOP_children(o)	o->op_children
 
 MODULE = B	PACKAGE = B::LISTOP		PREFIX = LISTOP_
@@ -687,10 +661,10 @@ PMOP_pmreplroot(o)
 	if (o->op_type == OP_PUSHRE) {
 	    sv_setiv(newSVrv(ST(0), root ?
 			     svclassnames[SvTYPE((SV*)root)] : "B::SV"),
-		     (IV)root);
+		     PTR2IV(root));
 	}
 	else {
-	    sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+	    sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
 	}
 
 B::OP
@@ -719,23 +693,38 @@ PMOP_precomp(o)
 	if (rx)
 	    sv_setpvn(ST(0), rx->precomp, rx->prelen);
 
-#define SVOP_sv(o)	o->op_sv
+#define SVOP_sv(o)	cSVOPo->op_sv
+#define SVOP_gv(o)	((GV*)cSVOPo->op_sv)
 
 MODULE = B	PACKAGE = B::SVOP		PREFIX = SVOP_
 
-
 B::SV
 SVOP_sv(o)
 	B::SVOP	o
 
-#define GVOP_gv(o)	o->op_gv
+B::GV
+SVOP_gv(o)
+	B::SVOP	o
 
-MODULE = B	PACKAGE = B::GVOP		PREFIX = GVOP_
+#define PADOP_padix(o)	o->op_padix
+#define PADOP_sv(o)	(o->op_padix ? PL_curpad[o->op_padix] : Nullsv)
+#define PADOP_gv(o)	((o->op_padix \
+			  && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \
+			 ? (GV*)PL_curpad[o->op_padix] : Nullgv)
 
+MODULE = B	PACKAGE = B::PADOP		PREFIX = PADOP_
+
+PADOFFSET
+PADOP_padix(o)
+	B::PADOP o
+
+B::SV
+PADOP_sv(o)
+	B::PADOP o
 
 B::GV
-GVOP_gv(o)
-	B::GVOP	o
+PADOP_gv(o)
+	B::PADOP o
 
 MODULE = B	PACKAGE = B::PVOP		PREFIX = PVOP_
 
@@ -770,11 +759,13 @@ LOOP_lastop(o)
 	B::LOOP	o
 
 #define COP_label(o)	o->cop_label
-#define COP_stash(o)	o->cop_stash
-#define COP_filegv(o)	o->cop_filegv
+#define COP_stashpv(o)	CopSTASHPV(o)
+#define COP_stash(o)	CopSTASH(o)
+#define COP_file(o)	CopFILE(o)
 #define COP_cop_seq(o)	o->cop_seq
 #define COP_arybase(o)	o->cop_arybase
-#define COP_line(o)	o->cop_line
+#define COP_line(o)	CopLINE(o)
+#define COP_warnings(o)	o->cop_warnings
 
 MODULE = B	PACKAGE = B::COP		PREFIX = COP_
 
@@ -782,12 +773,16 @@ char *
 COP_label(o)
 	B::COP	o
 
+char *
+COP_stashpv(o)
+	B::COP	o
+
 B::HV
 COP_stash(o)
 	B::COP	o
 
-B::GV
-COP_filegv(o)
+char *
+COP_file(o)
 	B::COP	o
 
 U32
@@ -802,6 +797,10 @@ U16
 COP_line(o)
 	B::COP	o
 
+B::SV
+COP_warnings(o)
+	B::COP	o
+
 MODULE = B	PACKAGE = B::SV		PREFIX = Sv
 
 U32
@@ -822,6 +821,11 @@ IV
 SvIVX(sv)
 	B::IV	sv
 
+UV 
+SvUVX(sv) 
+	B::IV   sv
+                      
+
 MODULE = B	PACKAGE = B::IV
 
 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
@@ -844,12 +848,16 @@ packiv(sv)
 	     * reach this code anyway (unless sizeof(IV) > 8 but then
 	     * everything else breaks too so I'm not fussed at the moment).
 	     */
-	    wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+#ifdef UV_IS_QUAD
+	    wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
+#else
+	    wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
+#endif
 	    wp[1] = htonl(iv & 0xffffffff);
-	    ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+	    ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
 	} else {
 	    U32 w = htonl((U32)SvIVX(sv));
-	    ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+	    ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
 	}
 
 MODULE = B	PACKAGE = B::NV		PREFIX = Sv
@@ -877,6 +885,14 @@ SvPV(sv)
 	ST(0) = sv_newmortal();
 	sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
 
+STRLEN
+SvLEN(sv)
+	B::PV	sv
+
+STRLEN
+SvCUR(sv)
+	B::PV	sv
+
 MODULE = B	PACKAGE = B::PVMG	PREFIX = Sv
 
 void
@@ -885,7 +901,7 @@ SvMAGIC(sv)
 	MAGIC *	mg = NO_INIT
     PPCODE:
 	for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
-	    XPUSHs(make_mg_object(sv_newmortal(), mg));
+	    XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
 
 MODULE = B	PACKAGE = B::PVMG
 
@@ -898,6 +914,7 @@ SvSTASH(sv)
 #define MgTYPE(mg) mg->mg_type
 #define MgFLAGS(mg) mg->mg_flags
 #define MgOBJ(mg) mg->mg_obj
+#define MgLENGTH(mg) mg->mg_len
 
 MODULE = B	PACKAGE = B::MAGIC	PREFIX = Mg	
 
@@ -921,13 +938,23 @@ B::SV
 MgOBJ(mg)
 	B::MAGIC	mg
 
+I32 
+MgLENGTH(mg)
+	B::MAGIC	mg
+ 
 void
 MgPTR(mg)
 	B::MAGIC	mg
     CODE:
 	ST(0) = sv_newmortal();
-	if (mg->mg_ptr)
-	    sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ 	if (mg->mg_ptr){
+		if (mg->mg_len >= 0){
+	    		sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+		} else {
+			if (mg->mg_len == HEf_SVKEY)	
+				sv_setsv(ST(0),newRV((SV*)mg->mg_ptr));
+		}
+	}
 
 MODULE = B	PACKAGE = B::PVLV	PREFIX = Lv
 
@@ -969,7 +996,7 @@ BmTABLE(sv)
     CODE:
 	str = SvPV(sv, len);
 	/* Boyer-Moore table is just after string and its safety-margin \0 */
-	ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+	ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
 
 MODULE = B	PACKAGE = B::GV		PREFIX = Gv
 
@@ -977,7 +1004,15 @@ void
 GvNAME(gv)
 	B::GV	gv
     CODE:
-	ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+	ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
+
+bool
+is_empty(gv)
+        B::GV   gv
+    CODE:
+        RETVAL = GvGP(gv) == Null(GP*);
+    OUTPUT:
+        RETVAL
 
 B::HV
 GvSTASH(gv)
@@ -1019,6 +1054,10 @@ U16
 GvLINE(gv)
 	B::GV	gv
 
+char *
+GvFILE(gv)
+	B::GV	gv
+
 B::GV
 GvFILEGV(gv)
 	B::GV	gv
@@ -1113,7 +1152,7 @@ AvARRAY(av)
 	    SV **svp = AvARRAY(av);
 	    I32 i;
 	    for (i = 0; i <= AvFILL(av); i++)
-		XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+		XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
 	}
 
 MODULE = B	PACKAGE = B::AV
@@ -1140,8 +1179,8 @@ B::GV
 CvGV(cv)
 	B::CV	cv
 
-B::GV
-CvFILEGV(cv)
+char *
+CvFILE(cv)
 	B::CV	cv
 
 long
@@ -1160,7 +1199,7 @@ void
 CvXSUB(cv)
 	B::CV	cv
     CODE:
-	ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+	ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
 
 
 void
@@ -1213,7 +1252,7 @@ HvARRAY(hv)
 	    (void)hv_iterinit(hv);
 	    EXTEND(sp, HvKEYS(hv) * 2);
 	    while (sv = hv_iternextsv(hv, &key, &len)) {
-		PUSHs(newSVpv(key, len));
-		PUSHs(make_sv_object(sv_newmortal(), sv));
+		PUSHs(newSVpvn(key, len));
+		PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
 	    }
 	}

contrib/perl5/ext/B/B/Asmdata.pm

@@ -1,5 +1,5 @@
 #
-#      Copyright (c) 1996-1998 Malcolm Beattie
+#      Copyright (c) 1996-1999 Malcolm Beattie
 #
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
@@ -12,9 +12,9 @@ package B::Asmdata;
 use Exporter;
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
-use vars qw(%insn_data @insn_name @optype @specialsv_name);
+our(%insn_data, @insn_name, @optype, @specialsv_name);
 
-@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
 @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
 
 # XXX insn_data is initialised this way because with a large
@@ -42,7 +42,7 @@ $insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"];
 $insn_data{xpv} = [18, \&PUT_none, "GET_none"];
 $insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"];
 $insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"];
-$insn_data{xnv} = [21, \&PUT_double, "GET_double"];
+$insn_data{xnv} = [21, \&PUT_NV, "GET_NV"];
 $insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"];
 $insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"];
 $insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"];
@@ -68,11 +68,11 @@ $insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"];
 $insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"];
 $insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"];
 $insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_filegv} = [48, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_file} = [48, \&PUT_pvcontents, "GET_pvcontents"];
 $insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"];
 $insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"];
 $insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"];
-$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_flags} = [52, \&PUT_U16, "GET_U16"];
 $insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"];
 $insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"];
 $insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"];
@@ -95,7 +95,7 @@ $insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"];
 $insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"];
 $insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"];
 $insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"];
-$insn_data{gp_filegv} = [75, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_file} = [75, \&PUT_pvcontents, "GET_pvcontents"];
 $insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"];
 $insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"];
 $insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"];
@@ -113,32 +113,31 @@ $insn_data{op_private} = [89, \&PUT_U8, "GET_U8"];
 $insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"];
 $insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"];
 $insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"];
-$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"];
-$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"];
-$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"];
-$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"];
-$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"];
-$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"];
-$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"];
-$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"];
-$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"];
-$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"];
-$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"];
-$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"];
-$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"];
-$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"];
-$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_children} = [93, \&PUT_U32, "GET_U32"];
+$insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmnext} = [97, \&PUT_opindex, "GET_opindex"];
+$insn_data{pregcomp} = [98, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pmflags} = [99, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmpermflags} = [100, \&PUT_U16, "GET_U16"];
+$insn_data{op_sv} = [101, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_padix} = [102, \&PUT_U32, "GET_U32"];
+$insn_data{op_pv} = [103, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"];
+$insn_data{cop_label} = [108, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_stashpv} = [109, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_file} = [110, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"];
+$insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"];
+$insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"];
+$insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"];
+$insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"];
+$insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"];
 
 my ($insn_name, $insn_data);
 while (($insn_name, $insn_data) = each %insn_data) {

contrib/perl5/ext/B/B/Assembler.pm

@@ -52,6 +52,7 @@ sub B::Asmdata::PUT_U8 {
 sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
 sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
 sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_NV  { sprintf("%lf\0", $_[0]) }
 sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
 sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
 sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }

contrib/perl5/ext/B/B/Bblock.pm

@@ -4,7 +4,9 @@ use Exporter ();
 @EXPORT_OK = qw(find_leaders);
 
 use B qw(peekop walkoptree walkoptree_exec
-	 main_root main_start svref_2object);
+	 main_root main_start svref_2object
+         OPf_SPECIAL OPf_STACKED );
+
 use B::Terse;
 use strict;
 
@@ -18,11 +20,18 @@ sub mark_leader {
     }
 }
 
+sub remove_sortblock{
+    foreach (keys %$bblock){
+        my $leader=$$bblock{$_};	
+	delete $$bblock{$_} if( $leader == 0);   
+    }
+}
 sub find_leaders {
     my ($root, $start) = @_;
     $bblock = {};
-    mark_leader($start);
-    walkoptree($root, "mark_if_leader");
+    mark_leader($start) if ( ref $start ne "B::NULL" );
+    walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
+    remove_sortblock();
     return $bblock;
 }
 
@@ -81,25 +90,32 @@ sub B::LOOP::mark_if_leader {
 
 sub B::LOGOP::mark_if_leader {
     my $op = shift;
-    my $ppaddr = $op->ppaddr;
+    my $opname = $op->name;
     mark_leader($op->next);
-    if ($ppaddr eq "pp_entertry") {
+    if ($opname eq "entertry") {
 	mark_leader($op->other->next);
     } else {
 	mark_leader($op->other);
     }
 }
 
-sub B::CONDOP::mark_if_leader {
+sub B::LISTOP::mark_if_leader {
     my $op = shift;
+    my $first=$op->first;
+    $first=$first->next while ($first->name eq "null");
+    mark_leader($op->first) unless (exists( $bblock->{$$first}));
     mark_leader($op->next);
-    mark_leader($op->true);
-    mark_leader($op->false);
+    if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
+	and $op->flags & OPf_STACKED){
+        my $root=$op->first->sibling->first;
+        my $leader=$root->first;
+        $bblock->{$$leader} = 0;
+    }
 }
 
 sub B::PMOP::mark_if_leader {
     my $op = shift;
-    if ($op->ppaddr ne "pp_pushre") {
+    if ($op->name ne "pushre") {
 	my $replroot = $op->pmreplroot;
 	if ($$replroot) {
 	    mark_leader($replroot);
@@ -113,6 +129,7 @@ sub B::PMOP::mark_if_leader {
 
 sub compile {
     my @options = @_;
+    B::clearsym();
     if (@options) {
 	return sub {
 	    my $objname;
@@ -134,7 +151,6 @@ sub compile {
 #     The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
 #     The ops pointed at by op_next and op_other of a LOGOP, except
 #     for pp_entertry which has op_next and op_other->op_next
-#     The ops pointed at by op_true and op_false of a CONDOP
 #     The op pointed at by op_pmreplstart of a PMOP
 #     The op pointed at by op_other->op_pmreplstart of pp_substcont?
 #     [The op after a pp_return] Omit
@@ -153,7 +169,9 @@ B::Bblock - Walk basic blocks
 
 =head1 DESCRIPTION
 
-See F<ext/B/README>.
+This module is used by the B::CC back end.  It walks "basic blocks".
+A basic block is a series of operations which is known to execute from
+start to finish, with no possiblity of branching or halting.
 
 =head1 AUTHOR
 

contrib/perl5/ext/B/B/Bytecode.pm

@@ -11,7 +11,9 @@ use Carp;
 use IO::File;
 
 use B qw(minus_c main_cv main_root main_start comppadlist
-	 class peekop walkoptree svref_2object cstring walksymtable);
+	 class peekop walkoptree svref_2object cstring walksymtable
+	 SVf_POK SVp_POK SVf_IOK SVp_IOK
+	);
 use B::Asmdata qw(@optype @specialsv_name);
 use B::Assembler qw(assemble_fh);
 
@@ -23,11 +25,11 @@ for ($i = 0; $i < @optype; $i++) {
 
 # Following is SVf_POK|SVp_POK
 # XXX Shouldn't be hardwired
-sub POK () { 0x04040000 }
+sub POK () { SVf_POK|SVp_POK }
 
-# Following is SVf_IOK|SVp_OK
+# Following is SVf_IOK|SVp_IOK
 # XXX Shouldn't be hardwired
-sub IOK () { 0x01010000 }
+sub IOK () { SVf_IOK|SVp_IOK }
 
 my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
 my $assembler_pid;
@@ -191,7 +193,7 @@ sub B::OP::bytecode {
     ldop($ix);
     print "op_next $nextix\n";
     print "op_sibling $sibix\n" unless $strip_syntree;
-    printf "op_type %s\t# %d\n", $op->ppaddr, $type;
+    printf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
     printf("op_seq %d\n", $op->seq) unless $omit_seq;
     if ($type || !$compress_nullops) {
 	printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
@@ -224,13 +226,11 @@ sub B::SVOP::bytecode {
     $sv->bytecode;
 }
 
-sub B::GVOP::bytecode {
+sub B::PADOP::bytecode {
     my $op = shift;
-    my $gv = $op->gv;
-    my $gvix = $gv->objix;
+    my $padix = $op->padix;
     $op->B::OP::bytecode;
-    print "op_gv $gvix\n";
-    $gv->bytecode;
+    print "op_padix $padix\n";
 }
 
 sub B::PVOP::bytecode {
@@ -241,7 +241,7 @@ sub B::PVOP::bytecode {
     # This would be easy except that OP_TRANS uses a PVOP to store an
     # endian-dependent array of 256 shorts instead of a plain string.
     #
-    if ($op->ppaddr eq "pp_trans") {
+    if ($op->name eq "trans") {
 	my @shorts = unpack("s256", $pv); # assembler handles endianness
 	print "op_pv_tr ", join(",", @shorts), "\n";
     } else {
@@ -258,14 +258,6 @@ sub B::BINOP::bytecode {
     }
 }
 
-sub B::CONDOP::bytecode {
-    my $op = shift;
-    my $trueix = $op->true->objix;
-    my $falseix = $op->false->objix;
-    $op->B::UNOP::bytecode;
-    print "op_true $trueix\nop_false $falseix\n";
-}
-
 sub B::LISTOP::bytecode {
     my $op = shift;
     my $children = $op->children;
@@ -286,26 +278,27 @@ sub B::LOOP::bytecode {
 
 sub B::COP::bytecode {
     my $op = shift;
-    my $stash = $op->stash;
-    my $stashix = $stash->objix;
-    my $filegv = $op->filegv;
-    my $filegvix = $filegv->objix;
+    my $stashpv = $op->stashpv;
+    my $file = $op->file;
     my $line = $op->line;
+    my $warnings = $op->warnings;
+    my $warningsix = $warnings->objix;
     if ($debug_bc) {
-	printf "# line %s:%d\n", $filegv->SV->PV, $line;
+	printf "# line %s:%d\n", $file, $line;
     }
     $op->B::OP::bytecode;
-    printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
+    printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase;
 newpv %s
 cop_label
-cop_stash $stashix
+newpv %s
+cop_stashpv
 cop_seq %d
-cop_filegv $filegvix
+newpv %s
+cop_file
 cop_arybase %d
 cop_line $line
+cop_warnings $warningsix
 EOT
-    $filegv->bytecode;
-    $stash->bytecode;
 }
 
 sub B::PMOP::bytecode {
@@ -313,7 +306,7 @@ sub B::PMOP::bytecode {
     my $replroot = $op->pmreplroot;
     my $replrootix = $replroot->objix;
     my $replstartix = $op->pmreplstart->objix;
-    my $ppaddr = $op->ppaddr;
+    my $opname = $op->name;
     # pmnext is corrupt in some PMOPs (see misc.t for example)
     #my $pmnextix = $op->pmnext->objix;
 
@@ -321,14 +314,14 @@ sub B::PMOP::bytecode {
 	# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 	# argument to a split) stores a GV in op_pmreplroot instead
 	# of a substitution syntax tree. We don't want to walk that...
-	if ($ppaddr eq "pp_pushre") {
+	if ($opname eq "pushre") {
 	    $replroot->bytecode;
 	} else {
 	    walkoptree($replroot, "bytecode");
 	}
     }
     $op->B::LISTOP::bytecode;
-    if ($ppaddr eq "pp_pushre") {
+    if ($opname eq "pushre") {
 	printf "op_pmreplrootgv $replrootix\n";
     } else {
 	print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
@@ -395,7 +388,8 @@ sub B::PVIV::bytecode {
 }
 
 sub B::PVNV::bytecode {
-    my ($sv, $flag) = @_;
+    my $sv = shift;
+    my $flag = shift || 0;
     # The $flag argument is passed through PVMG::bytecode by BM::bytecode
     # and AV::bytecode and indicates special handling. $flag = 1 is used by
     # BM::bytecode and means that we should ensure we save the whole B-M
@@ -469,18 +463,23 @@ sub B::GV::bytecode {
     return if saved($gv);
     my $ix = $gv->objix;
     mark_saved($gv);
+    ldsv($ix);
+    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
+sv_flags 0x%x
+xgv_flags 0x%x
+EOT
+    my $refcnt = $gv->REFCNT;
+    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
+    return if $gv->is_empty;
+    printf <<"EOT", $gv->LINE, pvstring($gv->FILE);
+gp_line %d
+newpv %s
+gp_file
+EOT
     my $gvname = $gv->NAME;
     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
     my $egv = $gv->EGV;
     my $egvix = $egv->objix;
-    ldsv($ix);
-    printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
-sv_flags 0x%x
-xgv_flags 0x%x
-gp_line %d
-EOT
-    my $refcnt = $gv->REFCNT;
-    printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
     my $gvrefcnt = $gv->GvREFCNT;
     printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
     if ($gvrefcnt > 1 &&  $ix != $egvix) {
@@ -488,7 +487,7 @@ EOT
     } else {
 	if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 	    my $i;
-	    my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
+	    my @subfield_names = qw(SV AV HV CV FORM IO);
 	    my @subfields = map($gv->$_(), @subfield_names);
 	    my @ixes = map($_->objix, @subfields);
 	    # Reset sv register for $gv
@@ -571,7 +570,7 @@ sub B::CV::bytecode {
     my $ix = $cv->objix;
     $cv->B::PVMG::bytecode;
     my $i;
-    my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
+    my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
     my @subfields = map($cv->$_(), @subfield_names);
     my @ixes = map($_->objix, @subfields);
     # Save OP tree from CvROOT (first element of @subfields)
@@ -584,7 +583,8 @@ sub B::CV::bytecode {
     for ($i = 0; $i < @ixes; $i++) {
 	printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
     }
-    printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
+    printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
+    printf "newpv %s\nxcv_file\n", pvstring($cv->FILE);
     # Now save all the subfields (except for CvROOT which was handled
     # above) and CvSTART (now the initial element of @subfields).
     shift @subfields; # bye-bye CvSTART
@@ -653,7 +653,7 @@ sub bytecompile_main {
     walkoptree(main_root, "bytecode");
     warn "done main program, now walking symbol table\n" if $debug_bc;
     my ($pack, %exclude);
-    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
+    foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars
 		      FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
 		      SelectSaver blib Cwd))
     {
@@ -707,6 +707,10 @@ sub compile {
 	    $arg ||= shift @options;
 	    open(OUT, ">$arg") or return "$arg: $!\n";
 	    binmode OUT;
+	} elsif ($opt eq "a") {
+	    $arg ||= shift @options;
+	    open(OUT, ">>$arg") or return "$arg: $!\n";
+	    binmode OUT;
 	} elsif ($opt eq "D") {
 	    $arg ||= shift @options;
 	    foreach $arg (split(//, $arg)) {
@@ -816,6 +820,10 @@ extra arguments, it saves the main program.
 
 Output to filename instead of STDOUT.
 
+=item B<-afilename>
+
+Append output to filename.
+
 =item B<-->
 
 Force end of options.
@@ -889,13 +897,16 @@ C<main_root> and C<curpad> are omitted.
 
 =head1 EXAMPLES
 
-        perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+    perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
 
-        perl -MO=Bytecode,-S foo.pl > foo.S
-        assemble foo.S > foo.plc
-        byteperl foo.plc
+    perl -MO=Bytecode,-S foo.pl > foo.S
+    assemble foo.S > foo.plc
 
-        perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+Note that C<assemble> lives in the C<B> subdirectory of your perl
+library directory. The utility called perlcc may also be used to 
+help make use of this compiler.
+
+    perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
 
 =head1 BUGS
 

contrib/perl5/ext/B/B/CC.pm

@@ -6,36 +6,22 @@
 #      License or the Artistic License, as specified in the README file.
 #
 package B::CC;
+use Config;
 use strict;
 use B qw(main_start main_root class comppadlist peekop svref_2object
-	timing_info);
-use B::C qw(save_unused_subs objsym init_sections
+	timing_info init_av sv_undef amagic_generation 
+	OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
+	OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
+	OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR    
+	CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
+	);
+use B::C qw(save_unused_subs objsym init_sections mark_unused
 	    output_all output_boilerplate output_main);
 use B::Bblock qw(find_leaders);
 use B::Stackobj qw(:types :flags);
 
 # These should probably be elsewhere
 # Flags for $op->flags
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_MOD () { 32 }
-sub OPf_STACKED () { 64 }
-sub OPf_SPECIAL () { 128 }
-# op-specific flags for $op->private 
-sub OPpASSIGN_BACKWARDS () { 64 }
-sub OPpLVAL_INTRO () { 128 }
-sub OPpDEREF_AV () { 32 }
-sub OPpDEREF_HV () { 64 }
-sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
-sub OPpFLIP_LINENUM () { 64 }
-sub G_ARRAY () { 1 }
-# cop.h
-sub CXt_NULL () { 0 }
-sub CXt_SUB () { 1 }
-sub CXt_EVAL () { 2 }
-sub CXt_LOOP () { 3 }
-sub CXt_SUBST () { 4 }
-sub CXt_BLOCK () { 5 }
 
 my $module;		# module name (when compiled with -m)
 my %done;		# hash keyed by $$op of leaders of basic blocks
@@ -66,6 +52,9 @@ my %skip_stack;		# Hash of PP names which don't need write_back_stack
 my %skip_lexicals;	# Hash of PP names which don't need write_back_lexicals
 my %skip_invalidate;	# Hash of PP names which don't need invalidate_lexicals
 my %ignore_op;		# Hash of ops which do nothing except returning op_next
+my %need_curcop;	# Hash of ops which need PL_curcop
+
+my %lexstate;		#state of padsvs at the start of a bblock
 
 BEGIN {
     foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
@@ -73,11 +62,6 @@ BEGIN {
     }
 }
 
-my @unused_sub_packages; # list of packages (given by -u options) to search
-			 # explicitly and save every sub we find there, even
-			 # if apparently unused (could be only referenced from
-			 # an eval "" or from a $SIG{FOO} = "bar").
-
 my ($module_name);
 my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
     $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
@@ -111,12 +95,17 @@ sub init_hash { map { $_ => 1 } @_ }
 #
 %skip_lexicals = init_hash qw(pp_enter pp_enterloop);
 %skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+%need_curcop = init_hash qw(pp_rv2gv  pp_bless pp_repeat pp_sort pp_caller
+			pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
+			pp_entertry pp_enterloop pp_enteriter pp_entersub
+			pp_enter pp_method);
 
 sub debug {
     if ($debug_runtime) {
 	warn(@_);
     } else {
-	runtime(map { chomp; "/* $_ */"} @_);
+	my @tmp=@_;
+	runtime(map { chomp; "/* $_ */"} @tmp);
     }
 }
 
@@ -139,7 +128,7 @@ sub output_runtime {
     print qq(#include "cc_runtime.h"\n);
     foreach $ppdata (@pp_list) {
 	my ($name, $runtime, $declare) = @$ppdata;
-	print "\nstatic\nPP($name)\n{\n";
+	print "\nstatic\nCCPP($name)\n{\n";
 	my ($type, $varlist, $line);
 	while (($type, $varlist) = each %$declare) {
 	    print "\t$type ", join(", ", @$varlist), ";\n";
@@ -167,7 +156,7 @@ sub init_pp {
     declare("SV", "**svp");
     map { declare("SV", "*$_") } qw(sv src dst left right);
     declare("MAGIC", "*mg");
-    $decl->add("static OP * $ppname _((ARGSproto));");
+    $decl->add("static OP * $ppname (pTHX);");
     debug "init_pp: $ppname\n" if $debug_queue;
 }
 
@@ -200,7 +189,7 @@ sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
 sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
 sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
 sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
 
 sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
 sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
@@ -208,7 +197,7 @@ sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
 sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
 sub pop_bool {
     if (@stack) {
-	return ((pop @stack)->as_numeric);
+	return ((pop @stack)->as_bool);
     } else {
 	# Careful: POPs has an auto-decrement and SvTRUE evaluates
 	# its argument more than once.
@@ -228,6 +217,32 @@ sub write_back_lexicals {
     }
 }
 
+sub save_or_restore_lexical_state {
+    my $bblock=shift;
+    unless( exists $lexstate{$bblock}){
+    	foreach my $lex (@pad) {
+		next unless ref($lex);
+		${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
+	}
+    }
+    else {
+    	foreach my $lex (@pad) {
+	    next unless ref($lex);
+	    my $old_flags=${$lexstate{$bblock}}{$lex->{iv}}  ;
+	    next if ( $old_flags eq $lex->{flags});
+	    if  (($old_flags & VALID_SV)  && !($lex->{flags} & VALID_SV)){
+		$lex->write_back;
+	    }
+	    if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
+                $lex->load_double;
+            }
+            if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
+                $lex->load_int;
+            }
+        }
+    }
+}
+
 sub write_back_stack {
     my $obj;
     return unless @stack;
@@ -350,8 +365,9 @@ sub dopoptoloop {
 sub dopoptolabel {
     my $label = shift;
     my $cxix = $#cxstack;
-    while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
-	   && $cxstack[$cxix]->{label} ne $label) {
+    while ($cxix >= 0 &&
+	   ($cxstack[$cxix]->{type} != CXt_LOOP ||
+	    $cxstack[$cxix]->{label} ne $label)) {
 	$cxix--;
     }
     debug "dopoptolabel: returning $cxix" if $debug_cxstack;
@@ -360,7 +376,7 @@ sub dopoptolabel {
 
 sub error {
     my $format = shift;
-    my $file = $curcop->[0]->filegv->SV->PV;
+    my $file = $curcop->[0]->file;
     my $line = $curcop->[0]->line;
     $errors++;
     if (@_) {
@@ -416,12 +432,22 @@ sub load_pad {
 	}
 	$pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
 					    "i_$name", "d_$name");
-	declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
-	declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
+
 	debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
     }
 }
 
+sub declare_pad {
+    my $ix;
+    for ($ix = 1; $ix <= $#pad; $ix++) {
+	my $type = $pad[$ix]->{type};
+	declare("IV", $type == T_INT ? 
+		sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
+	declare("double", $type == T_DOUBLE ?
+		 sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
+
+    }
+}
 #
 # Debugging stuff
 #
@@ -461,7 +487,7 @@ sub doop {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+    return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
 }
 
 #
@@ -476,10 +502,12 @@ sub pp_null {
 sub pp_stub {
     my $op = shift;
     my $gimme = gimme($op);
-    if ($gimme != 1) {
+    if ($gimme != G_ARRAY) {
+	my $obj= new B::Stackobj::Const(sv_undef);
+    	push(@stack, $obj);
 	# XXX Change to push a constant sv_undef Stackobj onto @stack
-	write_back_stack();
-	runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
+	#write_back_stack();
+	#runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
     }
     return $op->next;
 }
@@ -499,8 +527,10 @@ sub pp_and {
     if (@stack >= 1) {
 	my $bool = pop_bool();
 	write_back_stack();
-	runtime(sprintf("if (!$bool) goto %s;", label($next)));
+        save_or_restore_lexical_state($$next);
+	runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
     } else {
+        save_or_restore_lexical_state($$next);
 	runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
 		"*sp--;");
     }
@@ -513,11 +543,13 @@ sub pp_or {
     reload_lexicals();
     unshift(@bblock_todo, $next);
     if (@stack >= 1) {
-	my $obj = pop @stack;
+	my $bool = pop_bool @stack;
 	write_back_stack();
-	runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
-			$obj->as_numeric, $obj->as_sv, label($next)));
+        save_or_restore_lexical_state($$next);
+	runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
+			$bool, label($next)));
     } else {
+        save_or_restore_lexical_state($$next);
 	runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
 		"*sp--;");
     }
@@ -526,13 +558,14 @@ sub pp_or {
 	    
 sub pp_cond_expr {
     my $op = shift;
-    my $false = $op->false;
+    my $false = $op->next;
     unshift(@bblock_todo, $false);
     reload_lexicals();
     my $bool = pop_bool();
     write_back_stack();
+    save_or_restore_lexical_state($$false);
     runtime(sprintf("if (!$bool) goto %s;", label($false)));
-    return $op->true;
+    return $op->other;
 }
 
 sub pp_padsv {
@@ -555,9 +588,16 @@ sub pp_padsv {
 sub pp_const {
     my $op = shift;
     my $sv = $op->sv;
-    my $obj = $constobj{$$sv};
-    if (!defined($obj)) {
-	$obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+    my $obj;
+    # constant could be in the pad (under useithreads)
+    if ($$sv) {
+	$obj = $constobj{$$sv};
+	if (!defined($obj)) {
+	    $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+	}
+    }
+    else {
+	$obj = $pad[$op->targ];
     }
     push(@stack, $obj);
     return $op->next;
@@ -567,7 +607,7 @@ sub pp_nextstate {
     my $op = shift;
     $curcop->load($op);
     @stack = ();
-    debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
+    debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
     runtime("TAINT_NOT;") unless $omit_taint;
     runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
     if ($freetmps_each_bblock || $freetmps_each_loop) {
@@ -584,18 +624,58 @@ sub pp_dbstate {
     return default_pp($op);
 }
 
-sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
-sub pp_bless { $curcop->write_back; default_pp(@_) }
-sub pp_repeat { $curcop->write_back; default_pp(@_) }
+#default_pp will handle this:
+#sub pp_bless { $curcop->write_back; default_pp(@_) }
+#sub pp_repeat { $curcop->write_back; default_pp(@_) }
 # The following subs need $curcop->write_back if we decide to support arybase:
 # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
-sub pp_sort { $curcop->write_back; default_pp(@_) }
-sub pp_caller { $curcop->write_back; default_pp(@_) }
-sub pp_reset { $curcop->write_back; default_pp(@_) }
+#sub pp_caller { $curcop->write_back; default_pp(@_) }
+#sub pp_reset { $curcop->write_back; default_pp(@_) }
+
+sub pp_rv2gv{
+    my $op =shift;
+    $curcop->write_back;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    if ($op->private & OPpDEREF) {
+        $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));	
+        $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", 
+		$op->first->type));	
+    }
+    return $op->next;
+}
+sub pp_sort {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    if ( $op->flags & OPf_SPECIAL && $op->flags  & OPf_STACKED){   
+        #this indicates the sort BLOCK Array case
+        #ugly surgery required.
+        my $root=$op->first->sibling->first;
+        my $start=$root->first;
+	$op->first->save;
+	$op->first->sibling->save;
+	$root->save;
+	my $sym=$start->save;
+        my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
+	$init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
+    }
+    $curcop->write_back;
+    write_back_lexicals();
+    write_back_stack();
+    doop($op);
+    return $op->next;
+}
 
 sub pp_gv {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     write_back_stack();
     runtime("XPUSHs((SV*)$gvsym);");
     return $op->next;
@@ -603,7 +683,13 @@ sub pp_gv {
 
 sub pp_gvsv {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     write_back_stack();
     if ($op->private & OPpLVAL_INTRO) {
 	runtime("XPUSHs(save_scalar($gvsym));");
@@ -615,7 +701,13 @@ sub pp_gvsv {
 
 sub pp_aelemfast {
     my $op = shift;
-    my $gvsym = $op->gv->save;
+    my $gvsym;
+    if ($Config{useithreads}) {
+	$gvsym = $pad[$op->padix]->as_sv;
+    }
+    else {
+	$gvsym = $op->gv->save;
+    }
     my $ix = $op->private;
     my $flag = $op->flags & OPf_MOD;
     write_back_stack();
@@ -666,11 +758,15 @@ sub numeric_binop {
 	    }
 	} else {
 	    if ($force_int) {
+	        my $rightruntime = new B::Pseudoreg ("IV", "riv");
+	    	runtime(sprintf("$$rightruntime = %s;",$right));
 		runtime(sprintf("sv_setiv(TOPs, %s);",
-				&$operator("TOPi", $right)));
+				&$operator("TOPi", $$rightruntime)));
 	    } else {
+	    	my $rightruntime = new B::Pseudoreg ("double", "rnv");
+	    	runtime(sprintf("$$rightruntime = %s;",$right));
 		runtime(sprintf("sv_setnv(TOPs, %s);",
-				&$operator("TOPn", $right)));
+				&$operator("TOPn",$$rightruntime)));
 	    }
 	}
     } else {
@@ -694,6 +790,60 @@ sub numeric_binop {
     return $op->next;
 }
 
+sub pp_ncmp {
+    my ($op) = @_;
+    if ($op->flags & OPf_STACKED) {
+	my $right = pop_numeric();
+	if (@stack >= 1) {
+	    my $left = top_numeric();
+	    runtime sprintf("if (%s > %s){",$left,$right);
+		$stack[-1]->set_int(1);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else if (%s < %s ) {",$left,$right);
+		$stack[-1]->set_int(-1);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else if (%s == %s) {",$left,$right);
+		$stack[-1]->set_int(0);
+	    $stack[-1]->write_back();
+	    runtime sprintf("}else {"); 
+		$stack[-1]->set_sv("&PL_sv_undef");
+	    runtime "}";
+	} else {
+	    my $rightruntime = new B::Pseudoreg ("double", "rnv");
+	    runtime(sprintf("$$rightruntime = %s;",$right));
+	    runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,1);");
+	    runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,-1);");
+	    runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
+	    runtime sprintf("sv_setiv(TOPs,0);");
+	    runtime sprintf(qq/}else {/); 
+	    runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
+	    runtime "}";
+	}
+    } else {
+       	my $targ = $pad[$op->targ];
+	 my $right = new B::Pseudoreg ("double", "rnv");
+	 my $left = new B::Pseudoreg ("double", "lnv");
+	 runtime(sprintf("$$right = %s; $$left = %s;",
+			    pop_numeric(), pop_numeric));
+	runtime sprintf("if (%s > %s){",$$left,$$right);
+		$targ->set_int(1);
+		$targ->write_back();
+	runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
+		$targ->set_int(-1);
+		$targ->write_back();
+	runtime sprintf("}else if (%s == %s) {",$$left,$$right);
+		$targ->set_int(0);
+		$targ->write_back();
+	runtime sprintf("}else {"); 
+		$targ->set_sv("&PL_sv_undef");
+	runtime "}";
+	push(@stack, $targ);
+    }
+    return $op->next;
+}
+
 sub sv_binop {
     my ($op, $operator, $flags) = @_;
     if ($op->flags & OPf_STACKED) {
@@ -789,7 +939,6 @@ BEGIN {
     my $modulo_op = infix_op("%");
     my $lshift_op = infix_op("<<");
     my $rshift_op = infix_op(">>");
-    my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
     my $scmp_op = prefix_op("sv_cmp");
     my $seq_op = prefix_op("sv_eq");
     my $sne_op = prefix_op("!sv_eq");
@@ -808,12 +957,11 @@ BEGIN {
     # XXX The standard perl PP code has extra handling for
     # some special case arguments of these operators.
     #
-    sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
-    sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
-    sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
+    sub pp_add { numeric_binop($_[0], $plus_op) }
+    sub pp_subtract { numeric_binop($_[0], $minus_op) }
+    sub pp_multiply { numeric_binop($_[0], $multiply_op) }
     sub pp_divide { numeric_binop($_[0], $divide_op) }
     sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
-    sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
 
     sub pp_left_shift { int_binop($_[0], $lshift_op) }
     sub pp_right_shift { int_binop($_[0], $rshift_op) }
@@ -857,7 +1005,7 @@ sub pp_sassign {
 	($src, $dst) = ($dst, $src) if $backwards;
 	my $type = $src->{type};
 	if ($type == T_INT) {
-	    $dst->set_int($src->as_int);
+	    $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
 	} elsif ($type == T_DOUBLE) {
 	    $dst->set_numeric($src->as_numeric);
 	} else {
@@ -870,7 +1018,11 @@ sub pp_sassign {
 	    my $type = $src->{type};
 	    runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
 	    if ($type == T_INT) {
-		runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+                if ($src->{flags} & VALID_UNSIGNED){ 
+                     runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
+                }else{
+                    runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+                }
 	    } elsif ($type == T_DOUBLE) {
 		runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
 	    } else {
@@ -887,7 +1039,7 @@ sub pp_sassign {
 	    } elsif ($type == T_DOUBLE) {
 		$dst->set_double("SvNV(sv)");
 	    } else {
-		runtime("SvSetSV($dst->{sv}, sv);");
+		runtime("SvSetMagicSV($dst->{sv}, sv);");
 		$dst->invalidate;
 	    }
 	}
@@ -922,6 +1074,7 @@ sub pp_preinc {
     return $op->next;
 }
 
+
 sub pp_pushmark {
     my $op = shift;
     write_back_stack();
@@ -933,7 +1086,7 @@ sub pp_list {
     my $op = shift;
     write_back_stack();
     my $gimme = gimme($op);
-    if ($gimme == 1) { # sic
+    if ($gimme == G_ARRAY) { # sic
 	runtime("POPMARK;"); # need this even though not a "full" pp_list
     } else {
 	runtime("PP_LIST($gimme);");
@@ -943,16 +1096,31 @@ sub pp_list {
 
 sub pp_entersub {
     my $op = shift;
+    $curcop->write_back;
     write_back_lexicals(REGISTER|TEMPORARY);
     write_back_stack();
     my $sym = doop($op);
     runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
-    runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
+    runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
     runtime("SPAGAIN;}");
     $know_op = 0;
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
+sub pp_formline {
+    my $op = shift;
+    my $ppname = $op->ppaddr;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    my $sym=doop($op);
+    # See comment in pp_grepwhile to see why!
+    $init->add("((LISTOP*)$sym)->op_first = $sym;");    
+    runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
+    save_or_restore_lexical_state(${$op->first});
+    runtime( sprintf("goto %s;",label($op->first)));
+    runtime("}");
+    return $op->next;
+}
 
 sub pp_goto{
 
@@ -969,7 +1137,16 @@ sub pp_enterwrite {
     my $op = shift;
     pp_entersub($op);
 }
-
+sub pp_leavesub{
+    my $op = shift;
+    write_back_lexicals() unless $skip_lexicals{$ppname};
+    write_back_stack() unless $skip_stack{$ppname};
+    runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");   
+    runtime("\tPUTBACK;return 0;");
+    runtime("}");
+    doop($op);
+    return $op->next;
+}
 sub pp_leavewrite {
     my $op = shift;
     write_back_lexicals(REGISTER|TEMPORARY);
@@ -977,7 +1154,7 @@ sub pp_leavewrite {
     my $sym = doop($op);
     # XXX Is this the right way to distinguish between it returning
     # CvSTART(cv) (via doform) and pop_return()?
-    runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
+    #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
     runtime("SPAGAIN;");
     $know_op = 0;
     invalidate_lexicals(REGISTER|TEMPORARY);
@@ -991,6 +1168,7 @@ sub doeval {
     write_back_stack();
     my $sym = loadop($op);
     my $ppaddr = $op->ppaddr;
+    #runtime(qq/printf("$ppaddr type eval\n");/);
     runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
     $know_op = 1;
     invalidate_lexicals(REGISTER|TEMPORARY);
@@ -998,9 +1176,24 @@ sub doeval {
 }
 
 sub pp_entereval { doeval(@_) }
-sub pp_require { doeval(@_) }
 sub pp_dofile { doeval(@_) }
 
+#pp_require is protected by pp_entertry, so no protection for it.
+sub pp_require {
+    my $op = shift;
+    $curcop->write_back;
+    write_back_lexicals(REGISTER|TEMPORARY);
+    write_back_stack();
+    my $sym = doop($op);
+    runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+    runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
+    runtime("SPAGAIN;}");
+    $know_op = 1;
+    invalidate_lexicals(REGISTER|TEMPORARY);
+    return $op->next;
+}
+
+
 sub pp_entertry {
     my $op = shift;
     $curcop->write_back;
@@ -1008,12 +1201,19 @@ sub pp_entertry {
     write_back_stack();
     my $sym = doop($op);
     my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
-    declare("Sigjmp_buf", $jmpbuf);
+    declare("JMPENV", $jmpbuf);
     runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
     invalidate_lexicals(REGISTER|TEMPORARY);
     return $op->next;
 }
 
+sub pp_leavetry{
+	my $op=shift;
+	default_pp($op);
+	runtime("PP_LEAVETRY;");
+    	return $op->next;
+}
+
 sub pp_grepstart {
     my $op = shift;
     if ($need_freetmps && $freetmps_each_loop) {
@@ -1021,7 +1221,14 @@ sub pp_grepstart {
 	$need_freetmps = 0;
     }
     write_back_stack();
-    doop($op);
+    my $sym= doop($op);
+    my $next=$op->next;
+    $next->save;
+    my $nexttonext=$next->next;
+    $nexttonext->save;
+    save_or_restore_lexical_state($$nexttonext);
+    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+		    label($nexttonext)));
     return $op->next->other;
 }
 
@@ -1032,7 +1239,16 @@ sub pp_mapstart {
 	$need_freetmps = 0;
     }
     write_back_stack();
-    doop($op);
+    # pp_mapstart can return either op_next->op_next or op_next->op_other and
+    # we need to be able to distinguish the two at runtime. 
+    my $sym= doop($op);
+    my $next=$op->next;
+    $next->save;
+    my $nexttonext=$next->next;
+    $nexttonext->save;
+    save_or_restore_lexical_state($$nexttonext);
+    runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
+		    label($nexttonext)));
     return $op->next->other;
 }
 
@@ -1049,6 +1265,7 @@ sub pp_grepwhile {
     # around that, we hack op_next to be our own op (purely because we
     # know it's a non-NULL pointer and can't be the same as op_other).
     $init->add("((LOGOP*)$sym)->op_next = $sym;");
+    save_or_restore_lexical_state($$next);
     runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
     $know_op = 0;
     return $op->other;
@@ -1063,7 +1280,7 @@ sub pp_return {
     write_back_lexicals(REGISTER|TEMPORARY);
     write_back_stack();
     doop($op);
-    runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;");
+    runtime("PUTBACK;", "return PL_op;");
     $know_op = 0;
     return $op->next;
 }
@@ -1077,30 +1294,31 @@ sub nyi {
 sub pp_range {
     my $op = shift;
     my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
+    if (!($flags & OPf_WANT)) {
 	error("context of range unknown at compile-time");
     }
     write_back_lexicals();
     write_back_stack();
-    if (!($flags & OPf_LIST)) {
+    unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
 	# We need to save our UNOP structure since pp_flop uses
 	# it to find and adjust out targ. We don't need it ourselves.
 	$op->save;
+        save_or_restore_lexical_state(${$op->other});
 	runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
-			$op->targ, label($op->false));
-	unshift(@bblock_todo, $op->false);
+			$op->targ, label($op->other));
+	unshift(@bblock_todo, $op->other);
     }
-    return $op->true;
+    return $op->next;
 }
 
 sub pp_flip {
     my $op = shift;
     my $flags = $op->flags;
-    if (!($flags & OPf_KNOW)) {
+    if (!($flags & OPf_WANT)) {
 	error("context of flip unknown at compile-time");
     }
-    if ($flags & OPf_LIST) {
-	return $op->first->false;
+    if (($flags & OPf_WANT)==OPf_WANT_LIST) {
+	return $op->first->other;
     }
     write_back_lexicals();
     write_back_stack();
@@ -1116,9 +1334,10 @@ sub pp_flip {
     if ($op->flags & OPf_SPECIAL) {
 	runtime("sv_setiv(PL_curpad[$ix], 1);");
     } else {
+    	save_or_restore_lexical_state(${$op->first->other});
 	runtime("\tsv_setiv(PL_curpad[$ix], 0);",
 		"\tsp--;",
-		sprintf("\tgoto %s;", label($op->first->false)));
+		sprintf("\tgoto %s;", label($op->first->other)));
     }
     runtime("}",
 	  qq{sv_setpv(PL_curpad[$ix], "");},
@@ -1187,6 +1406,7 @@ sub pp_next {
     default_pp($op);
     my $nextop = $cxstack[$cxix]->{nextop};
     push(@bblock_todo, $nextop);
+    save_or_restore_lexical_state($$nextop);
     runtime(sprintf("goto %s;", label($nextop)));
     return $op->next;
 }
@@ -1210,6 +1430,7 @@ sub pp_redo {
     default_pp($op);
     my $redoop = $cxstack[$cxix]->{redoop};
     push(@bblock_todo, $redoop);
+    save_or_restore_lexical_state($$redoop);
     runtime(sprintf("goto %s;", label($redoop)));
     return $op->next;
 }
@@ -1238,6 +1459,7 @@ sub pp_last {
     default_pp($op);
     my $lastop = $cxstack[$cxix]->{lastop}->next;
     push(@bblock_todo, $lastop);
+    save_or_restore_lexical_state($$lastop);
     runtime(sprintf("goto %s;", label($lastop)));
     return $op->next;
 }
@@ -1249,6 +1471,7 @@ sub pp_subst {
     my $sym = doop($op);
     my $replroot = $op->pmreplroot;
     if ($$replroot) {
+        save_or_restore_lexical_state($$replroot);
 	runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
 			$sym, label($replroot));
 	$op->pmreplstart->save;
@@ -1264,11 +1487,12 @@ sub pp_substcont {
     write_back_stack();
     doop($op);
     my $pmop = $op->other;
-    warn sprintf("substcont: op = %s, pmop = %s\n",
-		 peekop($op), peekop($pmop));#debug
-#    my $pmopsym = objsym($pmop);
+    # warn sprintf("substcont: op = %s, pmop = %s\n",
+    # 		 peekop($op), peekop($pmop));#debug
+#   my $pmopsym = objsym($pmop);
     my $pmopsym = $pmop->save; # XXX can this recurse?
-    warn "pmopsym = $pmopsym\n";#debug
+#   warn "pmopsym = $pmopsym\n";#debug
+    save_or_restore_lexical_state(${$pmop->pmreplstart});
     runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
 		    $pmopsym, label($pmop->pmreplstart));
     invalidate_lexicals();
@@ -1277,7 +1501,10 @@ sub pp_substcont {
 
 sub default_pp {
     my $op = shift;
-    my $ppname = $op->ppaddr;
+    my $ppname = "pp_" . $op->name;
+    if ($curcop and $need_curcop{$ppname}){
+	$curcop->write_back;
+    }
     write_back_lexicals() unless $skip_lexicals{$ppname};
     write_back_stack() unless $skip_stack{$ppname};
     doop($op);
@@ -1291,7 +1518,7 @@ sub default_pp {
 
 sub compile_op {
     my $op = shift;
-    my $ppname = $op->ppaddr;
+    my $ppname = "pp_" . $op->name;
     if (exists $ignore_op{$ppname}) {
 	return $op->next;
     }
@@ -1313,6 +1540,7 @@ sub compile_op {
 sub compile_bblock {
     my $op = shift;
     #warn "compile_bblock: ", peekop($op), "\n"; # debug
+    save_or_restore_lexical_state($$op);
     write_label($op);
     $know_op = 0;
     do {
@@ -1326,15 +1554,26 @@ sub compile_bblock {
 sub cc {
     my ($name, $root, $start, @padlist) = @_;
     my $op;
+    if($done{$$start}){ 
+    	#warn "repeat=>".ref($start)."$name,\n";#debug
+	$decl->add(sprintf("#define $name  %s",$done{$$start}));
+	return;
+    }
     init_pp($name);
     load_pad(@padlist);
+    %lexstate=();
     B::Pseudoreg->new_scope;
     @cxstack = ();
     if ($debug_timings) {
 	warn sprintf("Basic block analysis at %s\n", timing_info);
     }
     $leaders = find_leaders($root, $start);
-    @bblock_todo = ($start, values %$leaders);
+    my @leaders= keys %$leaders; 
+    if ($#leaders > -1) { 
+    	@bblock_todo = ($start, values %$leaders) ;
+    } else{
+	runtime("return PL_op?PL_op->op_next:0;");
+    }
     if ($debug_timings) {
 	warn sprintf("Compilation at %s\n", timing_info);
     }
@@ -1344,7 +1583,7 @@ sub cc {
 	next if !defined($op) || !$$op || $done{$$op};
 	#warn "...compiling it\n"; # debug
 	do {
-	    $done{$$op} = 1;
+	    $done{$$op} = $name;
 	    $op = compile_bblock($op);
 	    if ($need_freetmps && $freetmps_each_bblock) {
 		runtime("FREETMPS;");
@@ -1356,14 +1595,16 @@ sub cc {
 	    $need_freetmps = 0;
 	}
 	if (!$$op) {
-	    runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;");
+	    runtime("PUTBACK;","return PL_op;");
 	} elsif ($done{$$op}) {
+    	    save_or_restore_lexical_state($$op);
 	    runtime(sprintf("goto %s;", label($op)));
 	}
     }
     if ($debug_timings) {
 	warn sprintf("Saving runtime at %s\n", timing_info);
     }
+    declare_pad(@padlist) ;
     save_runtime();
 }
 
@@ -1387,20 +1628,32 @@ sub cc_obj {
 
 sub cc_main {
     my @comppadlist = comppadlist->ARRAY;
-    my $curpad_nam = $comppadlist[0]->save;
-    my $curpad_sym = $comppadlist[1]->save;
+    my $curpad_nam  = $comppadlist[0]->save;
+    my $curpad_sym  = $comppadlist[1]->save;
+    my $init_av     = init_av->save; 
     my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
-    save_unused_subs(@unused_sub_packages);
+    # Do save_unused_subs before saving inc_hv
+    save_unused_subs();
     cc_recurse();
 
+    my $inc_hv      = svref_2object(\%INC)->save;
+    my $inc_av      = svref_2object(\@INC)->save;
+    my $amagic_generate= amagic_generation;
     return if $errors;
     if (!defined($module)) {
 	$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
 		   "PL_main_start = $start;",
 		   "PL_curpad = AvARRAY($curpad_sym);",
+		   "PL_initav = (AV *) $init_av;",
+		   "GvHV(PL_incgv) = $inc_hv;",
+		   "GvAV(PL_incgv) = $inc_av;",
 		   "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
-		   "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
+		   "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+		   "PL_amagic_generation= $amagic_generate;",
+		     );
+                 
     }
+    seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
     output_boilerplate();
     print "\n";
     output_all("perl_init");
@@ -1419,11 +1672,11 @@ XS(boot_$cmodule)
     perl_init();
     ENTER;
     SAVETMPS;
-    SAVESPTR(PL_curpad);
-    SAVESPTR(PL_op);
+    SAVEVPTR(PL_curpad);
+    SAVEVPTR(PL_op);
     PL_curpad = AvARRAY($curpad_sym);
     PL_op = $start;
-    pp_main(ARGS);
+    pp_main(aTHX);
     FREETMPS;
     LEAVE;
     ST(0) = &PL_sv_yes;
@@ -1459,7 +1712,7 @@ sub compile {
 	    $module_name = $arg;
 	} elsif ($opt eq "u") {
 	    $arg ||= shift @options;
-	    push(@unused_sub_packages, $arg);
+	    mark_unused($arg,undef);
 	} elsif ($opt eq "f") {
 	    $arg ||= shift @options;
 	    my $value = $arg !~ s/^no-//;
@@ -1485,7 +1738,7 @@ sub compile {
 	} elsif ($opt eq "m") {
 	    $arg ||= shift @options;
 	    $module = $arg;
-	    push(@unused_sub_packages, $arg);
+	    mark_unused($arg,undef);
 	} elsif ($opt eq "p") {
 	    $arg ||= shift @options;
 	    $patchlevel = $arg;

contrib/perl5/ext/B/B/Debug.pm

@@ -39,13 +39,6 @@ sub B::LOGOP::debug {
     printf "\top_other\t0x%x\n", ${$op->other};
 }
 
-sub B::CONDOP::debug {
-    my ($op) = @_;
-    $op->B::UNOP::debug();
-    printf "\top_true\t0x%x\n", ${$op->true};
-    printf "\top_false\t0x%x\n", ${$op->false};
-}
-
 sub B::LISTOP::debug {
     my ($op) = @_;
     $op->B::BINOP::debug();
@@ -67,16 +60,15 @@ sub B::PMOP::debug {
 sub B::COP::debug {
     my ($op) = @_;
     $op->B::OP::debug();
-    my ($filegv) = $op->filegv;
-    printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
+    printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings};
 	cop_label	%s
-	cop_stash	0x%x
-	cop_filegv	0x%x
+	cop_stashpv	%s
+	cop_file	%s
 	cop_seq		%d
 	cop_arybase	%d
 	cop_line	%d
+	cop_warnings	0x%x
 EOT
-    $filegv->debug;
 }
 
 sub B::SVOP::debug {
@@ -92,11 +84,10 @@ sub B::PVOP::debug {
     printf "\top_pv\t\t0x%x\n", $op->pv;
 }
 
-sub B::GVOP::debug {
+sub B::PADOP::debug {
     my ($op) = @_;
     $op->B::OP::debug();
-    printf "\top_gv\t\t0x%x\n", ${$op->gv};
-    $op->gv->debug;
+    printf "\top_padix\t\t%ld\n", $op->padix;
 }
 
 sub B::CVOP::debug {
@@ -184,14 +175,14 @@ sub B::CV::debug {
     my ($start) = $sv->START;
     my ($root) = $sv->ROOT;
     my ($padlist) = $sv->PADLIST;
+    my ($file) = $sv->FILE;
     my ($gv) = $sv->GV;
-    my ($filegv) = $sv->FILEGV;
-    printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
+    printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
 	STASH		0x%x
 	START		0x%x
 	ROOT		0x%x
 	GV		0x%x
-	FILEGV		0x%x
+	FILE		%s
 	DEPTH		%d
 	PADLIST		0x%x			       
 	OUTSIDE		0x%x
@@ -199,7 +190,6 @@ EOT
     $start->debug if $start;
     $root->debug if $root;
     $gv->debug if $gv;
-    $filegv->debug if $filegv;
     $padlist->debug if $padlist;
 }
 
@@ -226,7 +216,7 @@ sub B::GV::debug {
     my ($av) = $gv->AV;
     my ($cv) = $gv->CV;
     $gv->B::SV::debug;
-    printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
+    printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
 	NAME		%s
 	STASH		%s (0x%x)
 	SV		0x%x
@@ -238,7 +228,7 @@ sub B::GV::debug {
 	CV		0x%x
 	CVGEN		%d
 	LINE		%d
-	FILEGV		0x%x
+	FILE		%s
 	GvFLAGS		0x%x
 EOT
     $sv->debug if $sv;
@@ -253,6 +243,7 @@ sub B::SPECIAL::debug {
 
 sub compile {
     my $order = shift;
+    B::clearsym();
     if ($order eq "exec") {
         return sub { walkoptree_exec(main_start, "debug") }
     } else {

contrib/perl5/ext/B/B/Disassembler.pm

@@ -52,6 +52,20 @@ sub GET_objindex {
     return unpack("N", $str);
 }
 
+sub GET_opindex { 
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading opindex" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
+sub GET_svindex { 
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading svindex" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
 sub GET_strconst {
     my $fh = shift;
     my ($str, $c);

contrib/perl5/ext/B/B/Lint.pm

@@ -116,13 +116,9 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
-
-# Constants (should probably be elsewhere)
-sub G_ARRAY () { 1 }
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_STACKED () { 64 }
+use B qw(walkoptree_slow main_root walksymtable svref_2object parents
+         OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
+        );
 
 my $file = "unknown";		# shadows current filename
 my $line = 0;			# shadows current line number
@@ -133,8 +129,8 @@ my %check;
 my %implies_ok_context;
 BEGIN {
     map($implies_ok_context{$_}++,
-	qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
-	   pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+	qw(scalar av2arylen aelem aslice helem hslice
+	   keys values hslice defined undef delete));
 }
 
 # Lint checks turned on by default
@@ -165,8 +161,8 @@ sub warning {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    if ($flags & OPf_KNOW) {
-	return(($flags & OPf_LIST) ? 1 : 0);
+    if ($flags & OPf_WANT) {
+	return(($flags & OPf_WANT_LIST) ? 1 : 0);
     }
     return undef;
 }
@@ -175,8 +171,8 @@ sub B::OP::lint {}
 
 sub B::COP::lint {
     my $op = shift;
-    if ($op->ppaddr eq "pp_nextstate") {
-	$file = $op->filegv->SV->PV;
+    if ($op->name eq "nextstate") {
+	$file = $op->file;
 	$line = $op->line;
 	$curstash = $op->stash->NAME;
     }
@@ -184,24 +180,24 @@ sub B::COP::lint {
 
 sub B::UNOP::lint {
     my $op = shift;
-    my $ppaddr = $op->ppaddr;
-    if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+    my $opname = $op->name;
+    if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
 	my $parent = parents->[0];
-	my $pname = $parent->ppaddr;
+	my $pname = $parent->name;
 	return if gimme($op) || $implies_ok_context{$pname};
 	# Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
 	# null out the parent so we have to check for a parent of pp_null and
 	# a grandparent of pp_enteriter or pp_delete
-	if ($pname eq "pp_null") {
-	    my $gpname = parents->[1]->ppaddr;
-	    return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
+	if ($pname eq "null") {
+	    my $gpname = parents->[1]->name;
+	    return if $gpname eq "enteriter" || $gpname eq "delete";
 	}
 	warning("Implicit scalar context for %s in %s",
-		$ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+		$opname eq "rv2av" ? "array" : "hash", $parent->desc);
     }
-    if ($check{private_names} && $ppaddr eq "pp_method") {
+    if ($check{private_names} && $opname eq "method") {
 	my $methop = $op->first;
-	if ($methop->ppaddr eq "pp_const") {
+	if ($methop->name eq "const") {
 	    my $method = $methop->sv->PV;
 	    if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
 		warning("Illegal reference to private method name $method");
@@ -213,14 +209,12 @@ sub B::UNOP::lint {
 sub B::PMOP::lint {
     my $op = shift;
     if ($check{implicit_read}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+	if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
 	    warning('Implicit match on $_');
 	}
     }
     if ($check{implicit_write}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+	if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
 	    warning('Implicit substitution on $_');
 	}
     }
@@ -229,34 +223,35 @@ sub B::PMOP::lint {
 sub B::LOOP::lint {
     my $op = shift;
     if ($check{implicit_read} || $check{implicit_write}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_enteriter") {
+	if ($op->name eq "enteriter") {
 	    my $last = $op->last;
-	    if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
+	    if ($last->name eq "gv" && $last->gv->NAME eq "_") {
 		warning('Implicit use of $_ in foreach');
 	    }
 	}
     }
 }
 
-sub B::GVOP::lint {
+sub B::SVOP::lint {
     my $op = shift;
-    if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
+    if ($check{dollar_underscore} && $op->name eq "gvsv"
 	&& $op->gv->NAME eq "_")
     {
 	warning('Use of $_');
     }
     if ($check{private_names}) {
-	my $ppaddr = $op->ppaddr;
-	my $gv = $op->gv;
-	if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
-	    && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
-	{
-	    warning('Illegal reference to private name %s', $gv->NAME);
+	my $opname = $op->name;
+	if ($opname eq "gv" || $opname eq "gvsv") {
+	    my $gv = $op->gv;
+	    if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
+		warning('Illegal reference to private name %s', $gv->NAME);
+	    }
 	}
     }
     if ($check{undefined_subs}) {
-	if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
+	if ($op->name eq "gv"
+	    && $op->next->name eq "entersub")
+	{
 	    my $gv = $op->gv;
 	    my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 	    no strict 'refs';
@@ -266,7 +261,7 @@ sub B::GVOP::lint {
 	    }
 	}
     }
-    if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
+    if ($check{regexp_variables} && $op->name eq "gvsv") {
 	my $name = $op->gv->NAME;
 	if ($name =~ /^[&'`]$/) {
 	    warning('Use of regexp variable $%s', $name);

contrib/perl5/ext/B/B/Stackobj.pm

@@ -5,34 +5,35 @@
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
 #
-package B::Stackobj;
+package B::Stackobj;  
 use Exporter ();
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
 		VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
 %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
 		flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
-			     REGISTER TEMPORARY)]);
+			     VALID_UNSIGNED REGISTER TEMPORARY)]);
 
 use Carp qw(confess);
 use strict;
-use B qw(class);
-
-# Perl internal constants that I should probably define elsewhere.
-sub SVf_IOK () { 0x10000 }
-sub SVf_NOK () { 0x20000 }
+use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
 
 # Types
 sub T_UNKNOWN () { 0 }
 sub T_DOUBLE ()  { 1 }
 sub T_INT ()     { 2 }
+sub T_SPECIAL () { 3 }
 
 # Flags
 sub VALID_INT ()	{ 0x01 }
-sub VALID_DOUBLE ()	{ 0x02 }
-sub VALID_SV ()		{ 0x04 }
-sub REGISTER ()		{ 0x08 } # no implicit write-back when calling subs
-sub TEMPORARY ()	{ 0x10 } # no implicit write-back needed at all
+sub VALID_UNSIGNED ()	{ 0x02 }
+sub VALID_DOUBLE ()	{ 0x04 }
+sub VALID_SV ()		{ 0x08 }
+sub REGISTER ()		{ 0x10 } # no implicit write-back when calling subs
+sub TEMPORARY ()	{ 0x20 } # no implicit write-back needed at all
+sub SAVE_INT () 	{ 0x40 } #if int part needs to be saved at all
+sub SAVE_DOUBLE () 	{ 0x80 } #if double part needs to be saved at all
+
 
 #
 # Callback for runtime code generation
@@ -47,7 +48,7 @@ sub runtime { &$runtime_callback(@_) }
 
 sub write_back { confess "stack object does not implement write_back" }
 
-sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
+sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
 
 sub as_sv {
     my $obj = shift;
@@ -62,7 +63,7 @@ sub as_int {
     my $obj = shift;
     if (!($obj->{flags} & VALID_INT)) {
 	$obj->load_int;
-	$obj->{flags} |= VALID_INT;
+	$obj->{flags} |= VALID_INT|SAVE_INT;
     }
     return $obj->{iv};
 }
@@ -71,7 +72,7 @@ sub as_double {
     my $obj = shift;
     if (!($obj->{flags} & VALID_DOUBLE)) {
 	$obj->load_double;
-	$obj->{flags} |= VALID_DOUBLE;
+	$obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
     }
     return $obj->{nv};
 }
@@ -81,6 +82,17 @@ sub as_numeric {
     return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
 }
 
+sub as_bool {
+	my $obj=shift;
+	if ($obj->{flags} & VALID_INT ){
+		return $obj->{iv}; 
+	}
+	if ($obj->{flags} & VALID_DOUBLE ){
+		return $obj->{nv}; 
+	}
+	return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
+}
+
 #
 # Debugging methods
 #
@@ -126,17 +138,18 @@ sub minipeek {
 # set_numeric and set_sv are only invoked on legal lvalues.
 #
 sub set_int {
-    my ($obj, $expr) = @_;
+    my ($obj, $expr,$unsigned) = @_;
     runtime("$obj->{iv} = $expr;");
     $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
-    $obj->{flags} |= VALID_INT;
+    $obj->{flags} |= VALID_INT|SAVE_INT;
+    $obj->{flags} |= VALID_UNSIGNED if $unsigned; 
 }
 
 sub set_double {
     my ($obj, $expr) = @_;
     runtime("$obj->{nv} = $expr;");
     $obj->{flags} &= ~(VALID_SV | VALID_INT);
-    $obj->{flags} |= VALID_DOUBLE;
+    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
 }
 
 sub set_numeric {
@@ -162,6 +175,8 @@ sub set_sv {
 @B::Stackobj::Padsv::ISA = 'B::Stackobj';
 sub B::Stackobj::Padsv::new {
     my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+    $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
+    $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
     bless {
 	type => $type,
 	flags => VALID_SV | $extra_flags,
@@ -178,14 +193,23 @@ sub B::Stackobj::Padsv::load_int {
     } else {
 	runtime("$obj->{iv} = SvIV($obj->{sv});");
     }
-    $obj->{flags} |= VALID_INT;
+    $obj->{flags} |= VALID_INT|SAVE_INT;
 }
 
 sub B::Stackobj::Padsv::load_double {
     my $obj = shift;
     $obj->write_back;
     runtime("$obj->{nv} = SvNV($obj->{sv});");
-    $obj->{flags} |= VALID_DOUBLE;
+    $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+sub B::Stackobj::Padsv::save_int {
+    my $obj = shift;
+    return $obj->{flags} & SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::save_double {
+    my $obj = shift;
+    return $obj->{flags} & SAVE_DOUBLE;
 }
 
 sub B::Stackobj::Padsv::write_back {
@@ -193,7 +217,11 @@ sub B::Stackobj::Padsv::write_back {
     my $flags = $obj->{flags};
     return if $flags & VALID_SV;
     if ($flags & VALID_INT) {
-	runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+        if ($flags & VALID_UNSIGNED ){
+            runtime("sv_setuv($obj->{sv}, $obj->{iv});");
+        }else{
+            runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+        }     
     } elsif ($flags & VALID_DOUBLE) {
 	runtime("sv_setnv($obj->{sv}, $obj->{nv});");
     } else {
@@ -213,17 +241,26 @@ sub B::Stackobj::Const::new {
 	flags => 0,
 	sv => $sv    # holds the SV object until write_back happens
     }, $class;
-    my $svflags = $sv->FLAGS;
-    if ($svflags & SVf_IOK) {
-	$obj->{flags} = VALID_INT|VALID_DOUBLE;
-	$obj->{type} = T_INT;
-	$obj->{nv} = $obj->{iv} = $sv->IV;
-    } elsif ($svflags & SVf_NOK) {
-	$obj->{flags} = VALID_INT|VALID_DOUBLE;
-	$obj->{type} = T_DOUBLE;
-	$obj->{iv} = $obj->{nv} = $sv->NV;
-    } else {
-	$obj->{type} = T_UNKNOWN;
+    if ( ref($sv) eq  "B::SPECIAL" ){
+	$obj->{type}= T_SPECIAL;	
+    }else{
+    	my $svflags = $sv->FLAGS;
+    	if ($svflags & SVf_IOK) {
+		$obj->{flags} = VALID_INT|VALID_DOUBLE;
+		$obj->{type} = T_INT;
+                if ($svflags & SVf_IVisUV){
+                    $obj->{flags} |= VALID_UNSIGNED;
+                    $obj->{nv} = $obj->{iv} = $sv->UVX;
+                }else{
+                    $obj->{nv} = $obj->{iv} = $sv->IV;
+                }
+    	} elsif ($svflags & SVf_NOK) {
+		$obj->{flags} = VALID_INT|VALID_DOUBLE;
+		$obj->{type} = T_DOUBLE;
+		$obj->{iv} = $obj->{nv} = $sv->NV;
+    	} else {
+		$obj->{type} = T_UNKNOWN;
+    	}
     }
     return $obj;
 }
@@ -238,13 +275,21 @@ sub B::Stackobj::Const::write_back {
 
 sub B::Stackobj::Const::load_int {
     my $obj = shift;
-    $obj->{iv} = int($obj->{sv}->PV);
+    if (ref($obj->{sv}) eq "B::RV"){
+       $obj->{iv} = int($obj->{sv}->RV->PV);
+    }else{
+       $obj->{iv} = int($obj->{sv}->PV);
+    }
     $obj->{flags} |= VALID_INT;
 }
 
 sub B::Stackobj::Const::load_double {
     my $obj = shift;
-    $obj->{nv} = $obj->{sv}->PV + 0.0;
+    if (ref($obj->{sv}) eq "B::RV"){
+        $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
+    }else{
+        $obj->{nv} = $obj->{sv}->PV + 0.0;
+    }
     $obj->{flags} |= VALID_DOUBLE;
 }
 

contrib/perl5/ext/B/B/Stash.pm

@@ -0,0 +1,42 @@
+# Stash.pm -- show what stashes are loaded
+# vishalb@hotmail.com 
+package B::Stash;
+
+BEGIN { %Seen = %INC }
+
+CHECK {
+	my @arr=scan($main::{"main::"});
+	@arr=map{s/\:\:$//;$_;}  @arr;
+	print "-umain,-u", join (",-u",@arr) ,"\n";
+}
+sub scan{
+	my $start=shift;
+	my $prefix=shift;
+	$prefix = '' unless defined $prefix;
+	my @return;
+	foreach my $key ( keys %{$start}){
+#		print $prefix,$key,"\n";
+		if ($key =~ /::$/){
+			unless ($start  eq ${$start}{$key} or $key eq "B::" ){
+		 		push @return, $key unless omit($prefix.$key);
+				foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
+		 			push @return, "$key".$subscan; 	
+				}
+			}
+		}
+	}
+	return @return;
+}
+sub omit{
+	my $module = shift;
+	my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 ,
+		"CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
+	return 1 if $omit{$module};
+	if ($module eq "IO::" or $module eq "IO::Handle::"){
+		$module =~ s/::/\//g;	
+		return 1 unless  $INC{$module};
+	}
+
+	return 0;
+}
+1;

contrib/perl5/ext/B/B/Terse.pm

@@ -17,6 +17,7 @@ sub terse {
 sub compile {
     my $order = shift;
     my @options = @_;
+    B::clearsym();
     if (@options) {
 	return sub {
 	    my $objname;
@@ -53,10 +54,9 @@ sub B::SVOP::terse {
     $op->sv->terse(0);
 }
 
-sub B::GVOP::terse {
+sub B::PADOP::terse {
     my ($op, $level) = @_;
-    print indent($level), peekop($op), "  ";
-    $op->gv->terse(0);
+    print indent($level), peekop($op), "  ", $op->padix, "\n";
 }
 
 sub B::PMOP::terse {
@@ -78,7 +78,7 @@ sub B::COP::terse {
     if ($label) {
 	$label = " label ".cstring($label);
     }
-    print indent($level), peekop($op), $label, "\n";
+    print indent($level), peekop($op), $label || "", "\n";
 }
 
 sub B::PV::terse {

contrib/perl5/ext/B/B/Xref.pm

@@ -85,11 +85,10 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(peekop class comppadlist main_start svref_2object walksymtable);
-
-# Constants (should probably be elsewhere)
-sub OPpLVAL_INTRO () { 128 }
-sub SVf_POK () { 0x40000 }
+use Config;
+use B qw(peekop class comppadlist main_start svref_2object walksymtable
+         OPpLVAL_INTRO SVf_POK
+        );
 
 sub UNKNOWN { ["?", "?", "?"] }
 
@@ -135,17 +134,28 @@ sub process {
 
 sub load_pad {
     my $padlist = shift;
-    my ($namelistav, @namelist, $ix);
+    my ($namelistav, $vallistav, @namelist, $ix);
     @pad = ();
     return if class($padlist) eq "SPECIAL";
-    ($namelistav) = $padlist->ARRAY;
+    ($namelistav,$vallistav) = $padlist->ARRAY;
     @namelist = $namelistav->ARRAY;
     for ($ix = 1; $ix < @namelist; $ix++) {
 	my $namesv = $namelist[$ix];
 	next if class($namesv) eq "SPECIAL";
-	my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
+	my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
 	$pad[$ix] = ["(lexical)", $type, $name];
     }
+    if ($Config{useithreads}) {
+	my (@vallist);
+	@vallist = $vallistav->ARRAY;
+	for ($ix = 1; $ix < @vallist; $ix++) {
+	    my $valsv = $vallist[$ix];
+	    next unless class($valsv) eq "GV";
+	    # these pad GVs don't have corresponding names, so same @pad
+	    # array can be used without collisions
+	    $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
+	}
+    }
 }
 
 sub xref {
@@ -155,28 +165,24 @@ sub xref {
 	last if $done{$$op}++;
 	warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
 	warn peekop($op), "\n" if $debug_op;
-	my $ppname = $op->ppaddr;
-	if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) {
+	my $opname = $op->name;
+	if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
 	    xref($op->other);
-	} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+	} elsif ($opname eq "match" || $opname eq "subst") {
 	    xref($op->pmreplstart);
-	} elsif ($ppname eq "pp_substcont") {
+	} elsif ($opname eq "substcont") {
 	    xref($op->other->pmreplstart);
 	    $op = $op->other;
 	    redo;
-	} elsif ($ppname eq "pp_cond_expr") {
-	    # pp_cond_expr never returns op_next
-	    xref($op->true);
-	    $op = $op->false;
-	    redo;
-	} elsif ($ppname eq "pp_enterloop") {
+	} elsif ($opname eq "enterloop") {
 	    xref($op->redoop);
 	    xref($op->nextop);
 	    xref($op->lastop);
-	} elsif ($ppname eq "pp_subst") {
+	} elsif ($opname eq "subst") {
 	    xref($op->pmreplstart);
 	} else {
 	    no strict 'refs';
+	    my $ppname = "pp_$opname";
 	    &$ppname($op) if defined(&$ppname);
 	}
     }
@@ -207,7 +213,7 @@ sub xref_main {
 
 sub pp_nextstate {
     my $op = shift;
-    $file = $op->filegv->SV->PV;
+    $file = $op->file;
     $line = $op->line;
     $top = UNKNOWN;
 }
@@ -235,23 +241,45 @@ sub pp_rv2gv { deref($top, "*"); }
 
 sub pp_gvsv {
     my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, '$', $gv->NAME];
+    my $gv;
+    if ($Config{useithreads}) {
+	$top = $pad[$op->padix];
+	$top = UNKNOWN unless $top;
+	$top->[1] = '$';
+    }
+    else {
+	$gv = $op->gv;
+	$top = [$gv->STASH->NAME, '$', $gv->NAME];
+    }
     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 }
 
 sub pp_gv {
     my $op = shift;
-    my $gv = $op->gv;
-    $top = [$gv->STASH->NAME, "*", $gv->NAME];
+    my $gv;
+    if ($Config{useithreads}) {
+	$top = $pad[$op->padix];
+	$top = UNKNOWN unless $top;
+	$top->[1] = '*';
+    }
+    else {
+	$gv = $op->gv;
+	$top = [$gv->STASH->NAME, "*", $gv->NAME];
+    }
     process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
 }
 
 sub pp_const {
     my $op = shift;
     my $sv = $op->sv;
-    $top = ["?", "",
-	    (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+    # constant could be in the pad (under useithreads)
+    if ($$sv) {
+	$top = ["?", "",
+		(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+    }
+    else {
+	$top = $pad[$op->targ];
+    }
 }
 
 sub pp_method {
@@ -278,7 +306,7 @@ sub B::GV::xref {
     my $cv = $gv->CV;
     if ($$cv) {
 	#return if $done{$$cv}++;
-	$file = $gv->FILEGV->SV->PV;
+	$file = $gv->FILE;
 	$line = $gv->LINE;
 	process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
 	push(@todo, $cv);
@@ -286,7 +314,7 @@ sub B::GV::xref {
     my $form = $gv->FORM;
     if ($$form) {
 	return if $done{$$form}++;
-	$file = $gv->FILEGV->SV->PV;
+	$file = $gv->FILE;
 	$line = $gv->LINE;
 	process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
     }
@@ -296,7 +324,7 @@ sub xref_definitions {
     my ($pack, %exclude);
     return if $nodefs;
     $subname = "(definitions)";
-    foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
+    foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
 		      strict vars FileHandle Exporter Carp)) {
         $exclude{$pack."::"} = 1;
     }

contrib/perl5/ext/B/Makefile.PL

@@ -16,31 +16,21 @@ if ($^O eq 'MSWin32') {
 WriteMakefile(
     NAME	=> "B",
     VERSION	=> "a5",
-    MAN3PODS => {},
+    PL_FILES	=> { 'defsubs_h.PL' => 'defsubs.h' },
+    MAN3PODS	=> {},
     clean	=> {
-	FILES		=> "perl$e byteperl$e *$o B.c *~"
+	FILES		=> "perl$e *$o B.c defsubs.h *~"
     }
-);
+);   
 
-sub MY::post_constants {
-    "\nLIBS = $Config{libs}\n"
+package MY;
+
+sub post_constants {
+    "\nLIBS = $Config::Config{libs}\n"
+}    
+
+sub postamble {
+'
+B$(OBJ_EXT) : defsubs.h 
+'
 }
-
-# Leave out doing byteperl for now. Probably should be built in the
-# core directory or somewhere else rather than here
-#sub MY::top_targets {
-#    my $self = shift;
-#    my $targets = $self->MM::top_targets();
-#    $targets =~ s/^(all ::.*)$/$1 byteperl$e/m;
-#    return <<"EOT" . $targets;
-
-#
-# byteperl is *not* a standard perl+XSUB executable. It's a special
-# program for running standalone bytecode executables. It isn't an XSUB
-# at the moment because a standlone Perl program needs to set up curpad
-# which is overwritten on exit from an XSUB.
-#
-#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o
-#	\$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS)
-#EOT
-#}

contrib/perl5/ext/B/NOTES

@@ -161,8 +161,8 @@ O module
 	it should return a sub ref (usually a closure) to perform the
 	actual compilation. When O regains control, it ensures that the
 	"-c" option is forced (so that the program being compiled doesn't
-	end up running) and registers an END block to call back the sub ref
+	end up running) and registers a CHECK block to call back the sub ref
 	returned from the backend's compile(). Perl then continues by
 	parsing prog.pl (just as it would with "perl -c prog.pl") and after
-	doing so, assuming there are no parse-time errors, the END block
+	doing so, assuming there are no parse-time errors, the CHECK block
 	of O gets called and the actual backend compilation happens. Phew.

contrib/perl5/ext/B/O.pm

@@ -11,7 +11,7 @@ sub import {
     my $compilesub = &{"B::${backend}::compile"}(@options);
     if (ref($compilesub) eq "CODE") {
 	minus_c;
-	eval 'END { &$compilesub() }';
+	eval 'CHECK { &$compilesub() }';
     } else {
 	die $compilesub;
     }
@@ -59,7 +59,7 @@ C<B::Backend> module and calls the C<compile> function in that
 package, passing it OPTIONS. That function is expected to return
 a sub reference which we'll call CALLBACK. Next, the "compile-only"
 flag is switched on (equivalent to the command-line option C<-c>)
-and an END block is registered which calls CALLBACK. Thus the main
+and a CHECK block is registered which calls CALLBACK. Thus the main
 Perl program mentioned on the command-line is read in, parsed and
 compiled into internal syntax tree form. Since the C<-c> flag is
 set, the program does not start running (excepting BEGIN blocks of

contrib/perl5/ext/B/defsubs_h.PL

@@ -0,0 +1,35 @@
+# Do not remove the following line; MakeMaker relies on it to identify
+# this file as a template for defsubs.h
+# Extracting defsubs.h (with variable substitutions)
+#!perl
+my ($out) = __FILE__ =~ /(^.*)\.PL/i;
+$out =~ s/_h$/.h/;
+open(OUT,">$out") || die "Cannot open $file:$!";
+print "Extracting $out...\n";
+foreach my $const (qw(AVf_REAL 
+		      HEf_SVKEY
+                      SVf_IOK SVf_IVisUV SVf_NOK SVf_POK 
+		      SVf_ROK SVp_IOK SVp_POK ))
+ {
+  doconst($const);
+ }
+foreach my $file (qw(op.h cop.h))
+ {
+  open(OPH,"../../$file") || die "Cannot open ../../$file:$!";
+  while (<OPH>)
+   {  
+    doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/);
+   }  
+  close(OPH);
+ }
+close(OUT);
+               
+sub doconst
+{
+ my $sym = shift;
+ my $l = length($sym);
+ print OUT <<"END";
+ newCONSTSUB(stash,"$sym",newSViv($sym)); 
+ av_push(export_ok,newSVpvn("$sym",$l));
+END
+}

contrib/perl5/ext/B/ramblings/flip-flop

@@ -1,21 +1,24 @@
 PP(pp_range)
 {
     if (GIMME == G_ARRAY)
-        return cCONDOP->op_true;
-    return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+        return NORMAL;
+    if (SvTRUEx(PAD_SV(PL_op->op_targ)))
+	return cLOGOP->op_other;
+    else
+	return NORMAL;
 }
 
-pp_range is a CONDOP.
-In array context, it just returns op_true.
+pp_range is a LOGOP.
+In array context, it just returns op_next.
 In scalar context it checks the truth of targ and returns
-op_false if true, op_true if false.
+op_other if true, op_next if false.
 
 flip is an UNOP.
-It "looks after" its child which is always a pp_range CONDOP.
-In array context, it just returns the child's op_false.
+It "looks after" its child which is always a pp_range LOGOP.
+In array context, it just returns the child's op_other.
 In scalar context, there are three possible outcomes:
   (1) set child's targ to 1, our targ to 1 and return op_next.
-  (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false.
+  (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other.
   (3) Blank targ and  TOPs and return op_next.
 Case 1 happens for a "..." with a matching lineno... or true TOPs.
 Case 2 happens for a ".." with a matching lineno... or true TOPs.
@@ -37,14 +40,14 @@ Case 3 happens for a non-matching lineno or false TOPs.
 
 /* range */
 if (SvTRUE(curpad[op->op_targ]))
-    goto label(op_false);
-/* op_true */
+    goto label(op_other);
+/* op_next */
 ...
 /* flip */
-/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */
 /* end of basic block */
 goto out;
-label(range op_false):
+label(range op_other):
 ...
 /* flop */
 out:

contrib/perl5/ext/B/ramblings/runtime.porting

@@ -33,8 +33,10 @@ glob		5	2	do_readline
 readline	8	2	do_readline	
 rcatline	8	2
 regcmaybe	8	1
+regcreset	8	1
 regcomp		8	9	pregcomp
 match		8	10
+qr		8	1
 subst		8	10
 substcont	8	7
 trans		7	4	do_trans
@@ -170,6 +172,7 @@ orassign	7	3	modifies flow of control
 method		8	5
 entersub	10	7
 leavesub	10	5
+leavesublv
 caller		2	8
 warn		9	3
 die		9	3
@@ -212,6 +215,7 @@ leavewrite	4	5
 prtf		4	4	do_sprintf
 print		8	6
 sysopen		8	2
+sysseek		8	2
 sysread		8	4
 syswrite	8	4	pp_send
 send		8	4
@@ -347,4 +351,7 @@ sgrent
 egrent
 getlogin
 syscall
-	
+lock		6	1
+threadsv	6	2	unused if not USE_THREADS
+setstate	1	1	currently unused anywhere
+method_named	10	2

contrib/perl5/ext/B/typemap

@@ -4,11 +4,10 @@ B::OP		T_OP_OBJ
 B::UNOP		T_OP_OBJ
 B::BINOP	T_OP_OBJ
 B::LOGOP	T_OP_OBJ
-B::CONDOP	T_OP_OBJ
 B::LISTOP	T_OP_OBJ
 B::PMOP		T_OP_OBJ
 B::SVOP		T_OP_OBJ
-B::GVOP		T_OP_OBJ
+B::PADOP	T_OP_OBJ
 B::PVOP		T_OP_OBJ
 B::CVOP		T_OP_OBJ
 B::LOOP		T_OP_OBJ
@@ -31,12 +30,13 @@ B::IO		T_SV_OBJ
 B::MAGIC	T_MG_OBJ
 SSize_t		T_IV
 STRLEN		T_IV
+PADOFFSET	T_UV
 
 INPUT
 T_OP_OBJ
 	if (SvROK($arg)) {
 	    IV tmp = SvIV((SV*)SvRV($arg));
-	    $var = ($type) tmp;
+	    $var = INT2PTR($type,tmp);
 	}
 	else
 	    croak(\"$var is not a reference\")
@@ -44,7 +44,7 @@ T_OP_OBJ
 T_SV_OBJ
 	if (SvROK($arg)) {
 	    IV tmp = SvIV((SV*)SvRV($arg));
-	    $var = ($type) tmp;
+	    $var = INT2PTR($type,tmp);
 	}
 	else
 	    croak(\"$var is not a reference\")
@@ -52,18 +52,18 @@ T_SV_OBJ
 T_MG_OBJ
 	if (SvROK($arg)) {
 	    IV tmp = SvIV((SV*)SvRV($arg));
-	    $var = ($type) tmp;
+	    $var = INT2PTR($type,tmp);
 	}
 	else
 	    croak(\"$var is not a reference\")
 
 OUTPUT
 T_OP_OBJ
-	sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var);
+	sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var));
 
 T_SV_OBJ
-	make_sv_object(($arg), (SV*)($var));
+	make_sv_object(aTHX_ ($arg), (SV*)($var));
 
 
 T_MG_OBJ
-	sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
+	sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));

contrib/perl5/ext/ByteLoader/ByteLoader.pm

@@ -0,0 +1,40 @@
+package ByteLoader;
+
+use XSLoader ();
+
+$VERSION = 0.03;
+
+XSLoader::load 'ByteLoader', $VERSION;
+
+# Preloaded methods go here.
+
+1;
+__END__
+
+=head1 NAME
+
+ByteLoader - load byte compiled perl code
+
+=head1 SYNOPSIS
+
+  use ByteLoader 0.03;
+  <byte code>
+
+  use ByteLoader 0.03;
+  <byte code>
+
+=head1 DESCRIPTION
+
+This module is used to load byte compiled perl code. It uses the source
+filter mechanism to read the byte code and insert it into the compiled
+code at the appropriate point.
+
+=head1 AUTHOR
+
+Tom Hughes <tom@compton.nu> based on the ideas of Tim Bunce and others.
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut

contrib/perl5/ext/ByteLoader/ByteLoader.xs

@@ -0,0 +1,79 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "byterun.h"
+
+static int
+xgetc(PerlIO *io)
+{
+    dTHX;
+    return PerlIO_getc(io);
+}
+
+static int
+xfread(char *buf, size_t size, size_t n, PerlIO *io)
+{
+    dTHX;
+    int i = PerlIO_read(io, buf, n * size);
+    if (i > 0)
+	i /= size;
+    return i;
+}
+
+static void
+freadpv(U32 len, void *data, XPV *pv)
+{
+    dTHX;
+    New(666, pv->xpv_pv, len, char);
+    PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len);
+    pv->xpv_len = len;
+    pv->xpv_cur = len - 1;
+}
+
+static I32
+byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
+{
+    dTHR;
+    OP *saveroot = PL_main_root;
+    OP *savestart = PL_main_start;
+    struct bytestream bs;
+
+    bs.data = PL_rsfp;
+    bs.pfgetc = (int(*) (void*))xgetc;
+    bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread;
+    bs.pfreadpv = freadpv;
+
+    byterun(aTHXo_ bs);
+
+    if (PL_in_eval) {
+        OP *o;
+
+        PL_eval_start = PL_main_start;
+
+        o = newSVOP(OP_CONST, 0, newSViv(1));
+        PL_eval_root = newLISTOP(OP_LINESEQ, 0, PL_main_root, o);
+        PL_main_root->op_next = o;
+        PL_eval_root = newUNOP(OP_LEAVEEVAL, 0, PL_eval_root);
+        o->op_next = PL_eval_root;
+    
+        PL_main_root = saveroot;
+        PL_main_start = savestart;
+    }
+
+    return 0;
+}
+
+MODULE = ByteLoader		PACKAGE = ByteLoader
+
+PROTOTYPES:	ENABLE
+
+void
+import(...)
+  PPCODE:
+    filter_add(byteloader_filter, NULL);
+
+void
+unimport(...)
+  PPCODE:
+    filter_del(byteloader_filter);

contrib/perl5/ext/ByteLoader/Makefile.PL

@@ -0,0 +1,9 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME		=> 'ByteLoader',
+    VERSION_FROM	=> 'ByteLoader.pm',
+    XSPROTOARG		=> '-noprototypes',
+    MAN3PODS		=> {},     # Pods will be built by installman.
+    OBJECT		=> 'byterun$(OBJ_EXT) ByteLoader$(OBJ_EXT)',
+);

contrib/perl5/ext/ByteLoader/bytecode.h

@@ -0,0 +1,161 @@
+typedef char *pvcontents;
+typedef char *strconst;
+typedef U32 PV;
+typedef char *op_tr_array;
+typedef int comment_t;
+typedef SV *svindex;
+typedef OP *opindex;
+typedef IV IV64;
+
+#define BGET_FREAD(argp, len, nelem)	\
+	 bs.pfread((char*)(argp),(len),(nelem),bs.data)
+#define BGET_FGETC() bs.pfgetc(bs.data)
+
+#define BGET_U32(arg)	\
+	BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg)
+#define BGET_I32(arg)	\
+	BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg)
+#define BGET_U16(arg)	\
+	BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg)
+#define BGET_U8(arg)	arg = BGET_FGETC()
+
+#define BGET_PV(arg)	STMT_START {	\
+	BGET_U32(arg);			\
+	if (arg)			\
+	    bs.pfreadpv(arg, bs.data, &bytecode_pv);	\
+	else {				\
+	    bytecode_pv.xpv_pv = 0;		\
+	    bytecode_pv.xpv_len = 0;		\
+	    bytecode_pv.xpv_cur = 0;		\
+	}				\
+    } STMT_END
+
+#ifdef BYTELOADER_LOG_COMMENTS
+#  define BGET_comment_t(arg) \
+    STMT_START {							\
+	char buf[1024];							\
+	int i = 0;							\
+	do {								\
+	    arg = BGET_FGETC();						\
+	    buf[i++] = (char)arg;					\
+	} while (arg != '\n' && arg != EOF);				\
+	buf[i] = '\0';							\
+	PerlIO_printf(PerlIO_stderr(), "%s", buf);			\
+    } STMT_END
+#else
+#  define BGET_comment_t(arg) \
+	do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
+#endif
+
+/*
+ * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
+ * machines such that 32-bit machine compilers don't whine about the shift
+ * count being too high even though the code is never reached there.
+ */
+#define BGET_IV64(arg) STMT_START {			\
+	U32 hi, lo;					\
+	BGET_U32(hi);					\
+	BGET_U32(lo);					\
+	if (sizeof(IV) == 8)				\
+	    arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo);	\
+	else if (((I32)hi == -1 && (I32)lo < 0)		\
+		 || ((I32)hi == 0 && (I32)lo >= 0)) {	\
+	    arg = (I32)lo;				\
+	}						\
+	else {						\
+	    bytecode_iv_overflows++;				\
+	    arg = 0;					\
+	}						\
+    } STMT_END
+
+#define BGET_op_tr_array(arg) do {	\
+	unsigned short *ary;		\
+	int i;				\
+	New(666, ary, 256, unsigned short); \
+	BGET_FREAD(ary, 256, 2);	\
+	for (i = 0; i < 256; i++)	\
+	    ary[i] = PerlSock_ntohs(ary[i]);	\
+	arg = (char *) ary;		\
+    } while (0)
+
+#define BGET_pvcontents(arg)	arg = bytecode_pv.xpv_pv
+#define BGET_strconst(arg) STMT_START {	\
+	for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \
+	arg = PL_tokenbuf;			\
+    } STMT_END
+
+#define BGET_NV(arg) STMT_START {	\
+	char *str;			\
+	BGET_strconst(str);		\
+	arg = Atof(str);		\
+    } STMT_END
+
+#define BGET_objindex(arg, type) STMT_START {	\
+	U32 ix;					\
+	BGET_U32(ix);				\
+	arg = (type)bytecode_obj_list[ix];		\
+    } STMT_END
+#define BGET_svindex(arg) BGET_objindex(arg, svindex)
+#define BGET_opindex(arg) BGET_objindex(arg, opindex)
+
+#define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg]
+				    
+#define BSET_sv_refcnt_add(svrefcnt, arg)	svrefcnt += arg
+#define BSET_gp_refcnt_add(gprefcnt, arg)	gprefcnt += arg
+#define BSET_gp_share(sv, arg) STMT_START {	\
+	gp_free((GV*)sv);			\
+	GvGP(sv) = GvGP(arg);			\
+    } STMT_END
+
+#define BSET_gv_fetchpv(sv, arg)	sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
+#define BSET_gv_stashpv(sv, arg)	sv = (SV*)gv_stashpv(arg, TRUE)
+#define BSET_sv_magic(sv, arg)		sv_magic(sv, Nullsv, arg, 0, 0)
+#define BSET_mg_pv(mg, arg)	mg->mg_ptr = arg; mg->mg_len = bytecode_pv.xpv_cur
+#define BSET_sv_upgrade(sv, arg)	(void)SvUPGRADE(sv, arg)
+#define BSET_xpv(sv)	do {	\
+	SvPV_set(sv, bytecode_pv.xpv_pv);	\
+	SvCUR_set(sv, bytecode_pv.xpv_cur);	\
+	SvLEN_set(sv, bytecode_pv.xpv_len);	\
+    } while (0)
+#define BSET_av_extend(sv, arg)	av_extend((AV*)sv, arg)
+
+#define BSET_av_push(sv, arg)	av_push((AV*)sv, arg)
+#define BSET_hv_store(sv, arg)	\
+	hv_store((HV*)sv, bytecode_pv.xpv_pv, bytecode_pv.xpv_cur, arg, 0)
+#define BSET_pv_free(pv)	Safefree(pv.xpv_pv)
+#define BSET_pregcomp(o, arg) \
+	((PMOP*)o)->op_pmregexp = arg ? \
+		CALLREGCOMP(aTHX_ arg, arg + bytecode_pv.xpv_cur, ((PMOP*)o)) : 0
+#define BSET_newsv(sv, arg)	sv = NEWSV(666,0); SvUPGRADE(sv, arg)
+#define BSET_newop(o, arg)	((o = (OP*)safemalloc(optype_size[arg])), \
+				 memzero((char*)o,optype_size[arg]))
+#define BSET_newopn(o, arg) STMT_START {	\
+	OP *oldop = o;				\
+	BSET_newop(o, arg);			\
+	oldop->op_next = o;			\
+    } STMT_END
+
+#define BSET_ret(foo) return
+
+/*
+ * Kludge special-case workaround for OP_MAPSTART
+ * which needs the ppaddr for OP_GREPSTART. Blech.
+ */
+#define BSET_op_type(o, arg) STMT_START {	\
+	o->op_type = arg;			\
+	if (arg == OP_MAPSTART)			\
+	    arg = OP_GREPSTART;			\
+	o->op_ppaddr = PL_ppaddr[arg];		\
+    } STMT_END
+#define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented")
+#define BSET_curpad(pad, arg) STMT_START {	\
+	PL_comppad = (AV *)arg;			\
+	pad = AvARRAY(arg);			\
+    } STMT_END
+#define BSET_cop_file(cop, arg)		CopFILE_set(cop,arg)
+#define BSET_cop_line(cop, arg)		CopLINE_set(cop,arg)
+#define BSET_cop_stashpv(cop, arg)	CopSTASHPV_set(cop,arg)
+
+#define BSET_OBJ_STORE(obj, ix)		\
+	(I32)ix > bytecode_obj_list_fill ?	\
+	bset_obj_store(aTHXo_ obj, (I32)ix) : (bytecode_obj_list[ix] = obj)

contrib/perl5/ext/ByteLoader/byterun.c

@@ -0,0 +1,899 @@
+/*
+ *      Copyright (c) 1996-1999 Malcolm Beattie
+ *
+ *      You may distribute under the terms of either the GNU General Public
+ *      License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#define NO_XSLOCKS
+#include "XSUB.h"
+
+#ifdef PERL_OBJECT
+#undef CALL_FPTR
+#define CALL_FPTR(fptr) (pPerl->*fptr)
+#undef PL_ppaddr
+#define PL_ppaddr (*get_ppaddr())
+#endif
+
+#include "byterun.h"
+#include "bytecode.h"
+
+
+static int optype_size[] = {
+    sizeof(OP),
+    sizeof(UNOP),
+    sizeof(BINOP),
+    sizeof(LOGOP),
+    sizeof(LISTOP),
+    sizeof(PMOP),
+    sizeof(SVOP),
+    sizeof(PADOP),
+    sizeof(PVOP),
+    sizeof(LOOP),
+    sizeof(COP)
+};
+
+static SV *specialsv_list[4];
+
+static int bytecode_iv_overflows = 0;
+static SV *bytecode_sv;
+static XPV bytecode_pv;
+static void **bytecode_obj_list;
+static I32 bytecode_obj_list_fill = -1;
+
+void *
+bset_obj_store(pTHXo_ void *obj, I32 ix)
+{
+    if (ix > bytecode_obj_list_fill) {
+	if (bytecode_obj_list_fill == -1)
+	    New(666, bytecode_obj_list, ix + 1, void*);
+	else
+	    Renew(bytecode_obj_list, ix + 1, void*);
+	bytecode_obj_list_fill = ix;
+    }
+    bytecode_obj_list[ix] = obj;
+    return obj;
+}
+
+void
+byterun(pTHXo_ struct bytestream bs)
+{
+    dTHR;
+    int insn;
+
+    specialsv_list[0] = Nullsv;
+    specialsv_list[1] = &PL_sv_undef;
+    specialsv_list[2] = &PL_sv_yes;
+    specialsv_list[3] = &PL_sv_no;
+
+    while ((insn = BGET_FGETC()) != EOF) {
+	switch (insn) {
+	  case INSN_COMMENT:		/* 35 */
+	    {
+		comment_t arg;
+		BGET_comment_t(arg);
+		arg = arg;
+		break;
+	    }
+	  case INSN_NOP:		/* 10 */
+	    {
+		break;
+	    }
+	  case INSN_RET:		/* 0 */
+	    {
+		BSET_ret(none);
+		break;
+	    }
+	  case INSN_LDSV:		/* 1 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		bytecode_sv = arg;
+		break;
+	    }
+	  case INSN_LDOP:		/* 2 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		PL_op = arg;
+		break;
+	    }
+	  case INSN_STSV:		/* 3 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		BSET_OBJ_STORE(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_STOP:		/* 4 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		BSET_OBJ_STORE(PL_op, arg);
+		break;
+	    }
+	  case INSN_LDSPECSV:		/* 5 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		BSET_ldspecsv(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_NEWSV:		/* 6 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		BSET_newsv(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_NEWOP:		/* 7 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		BSET_newop(PL_op, arg);
+		break;
+	    }
+	  case INSN_NEWOPN:		/* 8 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		BSET_newopn(PL_op, arg);
+		break;
+	    }
+	  case INSN_NEWPV:		/* 9 */
+	    {
+		PV arg;
+		BGET_PV(arg);
+		break;
+	    }
+	  case INSN_PV_CUR:		/* 11 */
+	    {
+		STRLEN arg;
+		BGET_U32(arg);
+		bytecode_pv.xpv_cur = arg;
+		break;
+	    }
+	  case INSN_PV_FREE:		/* 12 */
+	    {
+		BSET_pv_free(bytecode_pv);
+		break;
+	    }
+	  case INSN_SV_UPGRADE:		/* 13 */
+	    {
+		char arg;
+		BGET_U8(arg);
+		BSET_sv_upgrade(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_SV_REFCNT:		/* 14 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		SvREFCNT(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_SV_REFCNT_ADD:		/* 15 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		BSET_sv_refcnt_add(SvREFCNT(bytecode_sv), arg);
+		break;
+	    }
+	  case INSN_SV_FLAGS:		/* 16 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		SvFLAGS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XRV:		/* 17 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		SvRV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XPV:		/* 18 */
+	    {
+		BSET_xpv(bytecode_sv);
+		break;
+	    }
+	  case INSN_XIV32:		/* 19 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		SvIVX(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIV64:		/* 20 */
+	    {
+		IV64 arg;
+		BGET_IV64(arg);
+		SvIVX(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XNV:		/* 21 */
+	    {
+		NV arg;
+		BGET_NV(arg);
+		SvNVX(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XLV_TARGOFF:		/* 22 */
+	    {
+		STRLEN arg;
+		BGET_U32(arg);
+		LvTARGOFF(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XLV_TARGLEN:		/* 23 */
+	    {
+		STRLEN arg;
+		BGET_U32(arg);
+		LvTARGLEN(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XLV_TARG:		/* 24 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		LvTARG(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XLV_TYPE:		/* 25 */
+	    {
+		char arg;
+		BGET_U8(arg);
+		LvTYPE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XBM_USEFUL:		/* 26 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		BmUSEFUL(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XBM_PREVIOUS:		/* 27 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		BmPREVIOUS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XBM_RARE:		/* 28 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		BmRARE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XFM_LINES:		/* 29 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		FmLINES(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_LINES:		/* 30 */
+	    {
+		long arg;
+		BGET_I32(arg);
+		IoLINES(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_PAGE:		/* 31 */
+	    {
+		long arg;
+		BGET_I32(arg);
+		IoPAGE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_PAGE_LEN:		/* 32 */
+	    {
+		long arg;
+		BGET_I32(arg);
+		IoPAGE_LEN(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_LINES_LEFT:		/* 33 */
+	    {
+		long arg;
+		BGET_I32(arg);
+		IoLINES_LEFT(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_TOP_NAME:		/* 34 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		IoTOP_NAME(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_TOP_GV:		/* 36 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&IoTOP_GV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_FMT_NAME:		/* 37 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		IoFMT_NAME(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_FMT_GV:		/* 38 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&IoFMT_GV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_BOTTOM_NAME:		/* 39 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		IoBOTTOM_NAME(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_BOTTOM_GV:		/* 40 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&IoBOTTOM_GV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_SUBPROCESS:		/* 41 */
+	    {
+		short arg;
+		BGET_U16(arg);
+		IoSUBPROCESS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_TYPE:		/* 42 */
+	    {
+		char arg;
+		BGET_U8(arg);
+		IoTYPE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XIO_FLAGS:		/* 43 */
+	    {
+		char arg;
+		BGET_U8(arg);
+		IoFLAGS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_STASH:		/* 44 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&CvSTASH(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_START:		/* 45 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		CvSTART(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_ROOT:		/* 46 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		CvROOT(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_GV:		/* 47 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&CvGV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_FILE:		/* 48 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		CvFILE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_DEPTH:		/* 49 */
+	    {
+		long arg;
+		BGET_I32(arg);
+		CvDEPTH(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_PADLIST:		/* 50 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&CvPADLIST(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_OUTSIDE:		/* 51 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&CvOUTSIDE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XCV_FLAGS:		/* 52 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		CvFLAGS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_AV_EXTEND:		/* 53 */
+	    {
+		SSize_t arg;
+		BGET_I32(arg);
+		BSET_av_extend(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_AV_PUSH:		/* 54 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		BSET_av_push(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_XAV_FILL:		/* 55 */
+	    {
+		SSize_t arg;
+		BGET_I32(arg);
+		AvFILLp(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XAV_MAX:		/* 56 */
+	    {
+		SSize_t arg;
+		BGET_I32(arg);
+		AvMAX(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XAV_FLAGS:		/* 57 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		AvFLAGS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XHV_RITER:		/* 58 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		HvRITER(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_XHV_NAME:		/* 59 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		HvNAME(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_HV_STORE:		/* 60 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		BSET_hv_store(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_SV_MAGIC:		/* 61 */
+	    {
+		char arg;
+		BGET_U8(arg);
+		BSET_sv_magic(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_MG_OBJ:		/* 62 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		SvMAGIC(bytecode_sv)->mg_obj = arg;
+		break;
+	    }
+	  case INSN_MG_PRIVATE:		/* 63 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		SvMAGIC(bytecode_sv)->mg_private = arg;
+		break;
+	    }
+	  case INSN_MG_FLAGS:		/* 64 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		SvMAGIC(bytecode_sv)->mg_flags = arg;
+		break;
+	    }
+	  case INSN_MG_PV:		/* 65 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		BSET_mg_pv(SvMAGIC(bytecode_sv), arg);
+		break;
+	    }
+	  case INSN_XMG_STASH:		/* 66 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&SvSTASH(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GV_FETCHPV:		/* 67 */
+	    {
+		strconst arg;
+		BGET_strconst(arg);
+		BSET_gv_fetchpv(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_GV_STASHPV:		/* 68 */
+	    {
+		strconst arg;
+		BGET_strconst(arg);
+		BSET_gv_stashpv(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_GP_SV:		/* 69 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		GvSV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_REFCNT:		/* 70 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		GvREFCNT(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_REFCNT_ADD:		/* 71 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		BSET_gp_refcnt_add(GvREFCNT(bytecode_sv), arg);
+		break;
+	    }
+	  case INSN_GP_AV:		/* 72 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&GvAV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_HV:		/* 73 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&GvHV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_CV:		/* 74 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&GvCV(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_FILE:		/* 75 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		GvFILE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_IO:		/* 76 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&GvIOp(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_FORM:		/* 77 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&GvFORM(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_CVGEN:		/* 78 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		GvCVGEN(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_LINE:		/* 79 */
+	    {
+		line_t arg;
+		BGET_U16(arg);
+		GvLINE(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_GP_SHARE:		/* 80 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		BSET_gp_share(bytecode_sv, arg);
+		break;
+	    }
+	  case INSN_XGV_FLAGS:		/* 81 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		GvFLAGS(bytecode_sv) = arg;
+		break;
+	    }
+	  case INSN_OP_NEXT:		/* 82 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		PL_op->op_next = arg;
+		break;
+	    }
+	  case INSN_OP_SIBLING:		/* 83 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		PL_op->op_sibling = arg;
+		break;
+	    }
+	  case INSN_OP_PPADDR:		/* 84 */
+	    {
+		strconst arg;
+		BGET_strconst(arg);
+		BSET_op_ppaddr(PL_op->op_ppaddr, arg);
+		break;
+	    }
+	  case INSN_OP_TARG:		/* 85 */
+	    {
+		PADOFFSET arg;
+		BGET_U32(arg);
+		PL_op->op_targ = arg;
+		break;
+	    }
+	  case INSN_OP_TYPE:		/* 86 */
+	    {
+		OPCODE arg;
+		BGET_U16(arg);
+		BSET_op_type(PL_op, arg);
+		break;
+	    }
+	  case INSN_OP_SEQ:		/* 87 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		PL_op->op_seq = arg;
+		break;
+	    }
+	  case INSN_OP_FLAGS:		/* 88 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		PL_op->op_flags = arg;
+		break;
+	    }
+	  case INSN_OP_PRIVATE:		/* 89 */
+	    {
+		U8 arg;
+		BGET_U8(arg);
+		PL_op->op_private = arg;
+		break;
+	    }
+	  case INSN_OP_FIRST:		/* 90 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cUNOP->op_first = arg;
+		break;
+	    }
+	  case INSN_OP_LAST:		/* 91 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cBINOP->op_last = arg;
+		break;
+	    }
+	  case INSN_OP_OTHER:		/* 92 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cLOGOP->op_other = arg;
+		break;
+	    }
+	  case INSN_OP_CHILDREN:		/* 93 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		cLISTOP->op_children = arg;
+		break;
+	    }
+	  case INSN_OP_PMREPLROOT:		/* 94 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cPMOP->op_pmreplroot = arg;
+		break;
+	    }
+	  case INSN_OP_PMREPLROOTGV:		/* 95 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		*(SV**)&cPMOP->op_pmreplroot = arg;
+		break;
+	    }
+	  case INSN_OP_PMREPLSTART:		/* 96 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cPMOP->op_pmreplstart = arg;
+		break;
+	    }
+	  case INSN_OP_PMNEXT:		/* 97 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		*(OP**)&cPMOP->op_pmnext = arg;
+		break;
+	    }
+	  case INSN_PREGCOMP:		/* 98 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		BSET_pregcomp(PL_op, arg);
+		break;
+	    }
+	  case INSN_OP_PMFLAGS:		/* 99 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		cPMOP->op_pmflags = arg;
+		break;
+	    }
+	  case INSN_OP_PMPERMFLAGS:		/* 100 */
+	    {
+		U16 arg;
+		BGET_U16(arg);
+		cPMOP->op_pmpermflags = arg;
+		break;
+	    }
+	  case INSN_OP_SV:		/* 101 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		cSVOP->op_sv = arg;
+		break;
+	    }
+	  case INSN_OP_PADIX:		/* 102 */
+	    {
+		PADOFFSET arg;
+		BGET_U32(arg);
+		cPADOP->op_padix = arg;
+		break;
+	    }
+	  case INSN_OP_PV:		/* 103 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		cPVOP->op_pv = arg;
+		break;
+	    }
+	  case INSN_OP_PV_TR:		/* 104 */
+	    {
+		op_tr_array arg;
+		BGET_op_tr_array(arg);
+		cPVOP->op_pv = arg;
+		break;
+	    }
+	  case INSN_OP_REDOOP:		/* 105 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cLOOP->op_redoop = arg;
+		break;
+	    }
+	  case INSN_OP_NEXTOP:		/* 106 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cLOOP->op_nextop = arg;
+		break;
+	    }
+	  case INSN_OP_LASTOP:		/* 107 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		cLOOP->op_lastop = arg;
+		break;
+	    }
+	  case INSN_COP_LABEL:		/* 108 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		cCOP->cop_label = arg;
+		break;
+	    }
+	  case INSN_COP_STASHPV:		/* 109 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		BSET_cop_stashpv(cCOP, arg);
+		break;
+	    }
+	  case INSN_COP_FILE:		/* 110 */
+	    {
+		pvcontents arg;
+		BGET_pvcontents(arg);
+		BSET_cop_file(cCOP, arg);
+		break;
+	    }
+	  case INSN_COP_SEQ:		/* 111 */
+	    {
+		U32 arg;
+		BGET_U32(arg);
+		cCOP->cop_seq = arg;
+		break;
+	    }
+	  case INSN_COP_ARYBASE:		/* 112 */
+	    {
+		I32 arg;
+		BGET_I32(arg);
+		cCOP->cop_arybase = arg;
+		break;
+	    }
+	  case INSN_COP_LINE:		/* 113 */
+	    {
+		line_t arg;
+		BGET_U16(arg);
+		BSET_cop_line(cCOP, arg);
+		break;
+	    }
+	  case INSN_COP_WARNINGS:		/* 114 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		cCOP->cop_warnings = arg;
+		break;
+	    }
+	  case INSN_MAIN_START:		/* 115 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		PL_main_start = arg;
+		break;
+	    }
+	  case INSN_MAIN_ROOT:		/* 116 */
+	    {
+		opindex arg;
+		BGET_opindex(arg);
+		PL_main_root = arg;
+		break;
+	    }
+	  case INSN_CURPAD:		/* 117 */
+	    {
+		svindex arg;
+		BGET_svindex(arg);
+		BSET_curpad(PL_curpad, arg);
+		break;
+	    }
+	  default:
+	    Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
+	    /* NOTREACHED */
+	}
+    }
+}

contrib/perl5/ext/ByteLoader/byterun.h

@@ -0,0 +1,161 @@
+/*
+ *      Copyright (c) 1996-1999 Malcolm Beattie
+ *
+ *      You may distribute under the terms of either the GNU General Public
+ *      License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+struct bytestream {
+    void *data;
+    int (*pfgetc)(void *);
+    int (*pfread)(char *, size_t, size_t, void *);
+    void (*pfreadpv)(U32, void *, XPV *);
+};
+
+enum {
+    INSN_RET,			/* 0 */
+    INSN_LDSV,			/* 1 */
+    INSN_LDOP,			/* 2 */
+    INSN_STSV,			/* 3 */
+    INSN_STOP,			/* 4 */
+    INSN_LDSPECSV,			/* 5 */
+    INSN_NEWSV,			/* 6 */
+    INSN_NEWOP,			/* 7 */
+    INSN_NEWOPN,			/* 8 */
+    INSN_NEWPV,			/* 9 */
+    INSN_NOP,			/* 10 */
+    INSN_PV_CUR,			/* 11 */
+    INSN_PV_FREE,			/* 12 */
+    INSN_SV_UPGRADE,			/* 13 */
+    INSN_SV_REFCNT,			/* 14 */
+    INSN_SV_REFCNT_ADD,			/* 15 */
+    INSN_SV_FLAGS,			/* 16 */
+    INSN_XRV,			/* 17 */
+    INSN_XPV,			/* 18 */
+    INSN_XIV32,			/* 19 */
+    INSN_XIV64,			/* 20 */
+    INSN_XNV,			/* 21 */
+    INSN_XLV_TARGOFF,			/* 22 */
+    INSN_XLV_TARGLEN,			/* 23 */
+    INSN_XLV_TARG,			/* 24 */
+    INSN_XLV_TYPE,			/* 25 */
+    INSN_XBM_USEFUL,			/* 26 */
+    INSN_XBM_PREVIOUS,			/* 27 */
+    INSN_XBM_RARE,			/* 28 */
+    INSN_XFM_LINES,			/* 29 */
+    INSN_XIO_LINES,			/* 30 */
+    INSN_XIO_PAGE,			/* 31 */
+    INSN_XIO_PAGE_LEN,			/* 32 */
+    INSN_XIO_LINES_LEFT,			/* 33 */
+    INSN_XIO_TOP_NAME,			/* 34 */
+    INSN_COMMENT,			/* 35 */
+    INSN_XIO_TOP_GV,			/* 36 */
+    INSN_XIO_FMT_NAME,			/* 37 */
+    INSN_XIO_FMT_GV,			/* 38 */
+    INSN_XIO_BOTTOM_NAME,			/* 39 */
+    INSN_XIO_BOTTOM_GV,			/* 40 */
+    INSN_XIO_SUBPROCESS,			/* 41 */
+    INSN_XIO_TYPE,			/* 42 */
+    INSN_XIO_FLAGS,			/* 43 */
+    INSN_XCV_STASH,			/* 44 */
+    INSN_XCV_START,			/* 45 */
+    INSN_XCV_ROOT,			/* 46 */
+    INSN_XCV_GV,			/* 47 */
+    INSN_XCV_FILE,			/* 48 */
+    INSN_XCV_DEPTH,			/* 49 */
+    INSN_XCV_PADLIST,			/* 50 */
+    INSN_XCV_OUTSIDE,			/* 51 */
+    INSN_XCV_FLAGS,			/* 52 */
+    INSN_AV_EXTEND,			/* 53 */
+    INSN_AV_PUSH,			/* 54 */
+    INSN_XAV_FILL,			/* 55 */
+    INSN_XAV_MAX,			/* 56 */
+    INSN_XAV_FLAGS,			/* 57 */
+    INSN_XHV_RITER,			/* 58 */
+    INSN_XHV_NAME,			/* 59 */
+    INSN_HV_STORE,			/* 60 */
+    INSN_SV_MAGIC,			/* 61 */
+    INSN_MG_OBJ,			/* 62 */
+    INSN_MG_PRIVATE,			/* 63 */
+    INSN_MG_FLAGS,			/* 64 */
+    INSN_MG_PV,			/* 65 */
+    INSN_XMG_STASH,			/* 66 */
+    INSN_GV_FETCHPV,			/* 67 */
+    INSN_GV_STASHPV,			/* 68 */
+    INSN_GP_SV,			/* 69 */
+    INSN_GP_REFCNT,			/* 70 */
+    INSN_GP_REFCNT_ADD,			/* 71 */
+    INSN_GP_AV,			/* 72 */
+    INSN_GP_HV,			/* 73 */
+    INSN_GP_CV,			/* 74 */
+    INSN_GP_FILE,			/* 75 */
+    INSN_GP_IO,			/* 76 */
+    INSN_GP_FORM,			/* 77 */
+    INSN_GP_CVGEN,			/* 78 */
+    INSN_GP_LINE,			/* 79 */
+    INSN_GP_SHARE,			/* 80 */
+    INSN_XGV_FLAGS,			/* 81 */
+    INSN_OP_NEXT,			/* 82 */
+    INSN_OP_SIBLING,			/* 83 */
+    INSN_OP_PPADDR,			/* 84 */
+    INSN_OP_TARG,			/* 85 */
+    INSN_OP_TYPE,			/* 86 */
+    INSN_OP_SEQ,			/* 87 */
+    INSN_OP_FLAGS,			/* 88 */
+    INSN_OP_PRIVATE,			/* 89 */
+    INSN_OP_FIRST,			/* 90 */
+    INSN_OP_LAST,			/* 91 */
+    INSN_OP_OTHER,			/* 92 */
+    INSN_OP_CHILDREN,			/* 93 */
+    INSN_OP_PMREPLROOT,			/* 94 */
+    INSN_OP_PMREPLROOTGV,			/* 95 */
+    INSN_OP_PMREPLSTART,			/* 96 */
+    INSN_OP_PMNEXT,			/* 97 */
+    INSN_PREGCOMP,			/* 98 */
+    INSN_OP_PMFLAGS,			/* 99 */
+    INSN_OP_PMPERMFLAGS,			/* 100 */
+    INSN_OP_SV,			/* 101 */
+    INSN_OP_PADIX,			/* 102 */
+    INSN_OP_PV,			/* 103 */
+    INSN_OP_PV_TR,			/* 104 */
+    INSN_OP_REDOOP,			/* 105 */
+    INSN_OP_NEXTOP,			/* 106 */
+    INSN_OP_LASTOP,			/* 107 */
+    INSN_COP_LABEL,			/* 108 */
+    INSN_COP_STASHPV,			/* 109 */
+    INSN_COP_FILE,			/* 110 */
+    INSN_COP_SEQ,			/* 111 */
+    INSN_COP_ARYBASE,			/* 112 */
+    INSN_COP_LINE,			/* 113 */
+    INSN_COP_WARNINGS,			/* 114 */
+    INSN_MAIN_START,			/* 115 */
+    INSN_MAIN_ROOT,			/* 116 */
+    INSN_CURPAD,			/* 117 */
+    MAX_INSN = 117
+};
+
+enum {
+    OPt_OP,		/* 0 */
+    OPt_UNOP,		/* 1 */
+    OPt_BINOP,		/* 2 */
+    OPt_LOGOP,		/* 3 */
+    OPt_LISTOP,		/* 4 */
+    OPt_PMOP,		/* 5 */
+    OPt_SVOP,		/* 6 */
+    OPt_PADOP,		/* 7 */
+    OPt_PVOP,		/* 8 */
+    OPt_LOOP,		/* 9 */
+    OPt_COP		/* 10 */
+};
+
+extern void byterun(pTHXo_ struct bytestream bs);
+
+#define INIT_SPECIALSV_LIST STMT_START { \
+	PL_specialsv_list[0] = Nullsv; \
+	PL_specialsv_list[1] = &PL_sv_undef; \
+	PL_specialsv_list[2] = &PL_sv_yes; \
+	PL_specialsv_list[3] = &PL_sv_no; \
+    } STMT_END

contrib/perl5/ext/ByteLoader/hints/sunos.pl

@@ -0,0 +1,2 @@
+$self->{CCFLAGS} = $Config{ccflags} . ' -DNEED_FGETC_PROTOTYPE -DNEED_FREAD_PROTOTYPE';
+

contrib/perl5/ext/DB_File/Changes

@@ -230,5 +230,64 @@
    * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail.
 
 1.65 6th March 1999
+
    * Fixed a bug in the recno PUSH logic.
    * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2
+
+1.66 15th March 1999
+
+   * Added DBM Filter code
+
+1.67 6th June 1999
+
+   * Added DBM Filter documentation to DB_File.pm
+
+   * Fixed DBM Filter code to work with 5.004
+
+   * A few instances of newSVpvn were used in 1.66. This isn't available in
+     Perl 5.004_04 or earlier. Replaced with newSVpv.
+
+1.68 22nd July 1999
+
+   * Merged changes from 5.005_58 
+
+   * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB
+     2 databases.
+
+   * Added some of the examples in the POD into the test harness.
+
+1.69 3rd August 1999
+
+   * fixed a bug in push -- DB_APPEND wasn't working properly.
+
+   * Fixed the R_SETCURSOR bug introduced in 1.68
+
+   * Added a new Perl variable $DB_File::db_ver
+   
+1.70 4th August 1999
+
+   * Initialise $DB_File::db_ver and $DB_File::db_version with
+     GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons.
+
+   * Added a BOOT check to test for equivalent versions of db.h &
+     libdb.a/so.
+
+1.71 7th September 1999
+
+   * Fixed a bug that prevented 1.70 from compiling under win32
+
+   * Updated to support Berkeley DB 3.x
+
+   * Updated dbinfo for Berkeley DB 3.x file formats.
+
+1.72 16th January 2000
+
+   * Added hints/sco.pl
+
+   * The module will now use XSLoader when it is available. When it
+     isn't it will use DynaLoader.
+
+   * The locking section in DB_File.pm has been discredited. Many thanks
+     to David Harris for spotting the underlying problem, contributing
+     the updates to the documentation and writing DB_File::Lock (available
+     on CPAN).

contrib/perl5/ext/DB_File/DB_File.pm

@@ -1,10 +1,10 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 6th March 1999
-# version 1.65
+# last modified 16th January 2000
+# version 1.72
 #
-#     Copyright (c) 1995-9 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-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.
 
@@ -141,11 +141,13 @@ sub TIEHASH
 package DB_File ;
 
 use strict;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
+            $db_version $use_XSLoader
+           ) ;
 use Carp;
 
 
-$VERSION = "1.65" ;
+$VERSION = "1.72" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -155,8 +157,18 @@ $DB_RECNO = new DB_File::RECNOINFO ;
 require Tie::Hash;
 require Exporter;
 use AutoLoader;
-require DynaLoader;
-@ISA = qw(Tie::Hash Exporter DynaLoader);
+BEGIN {
+    $use_XSLoader = 1 ;
+    eval { require XSLoader } ;
+
+    if ($@) {
+        $use_XSLoader = 0 ;
+        require DynaLoader;
+        @ISA = qw(DynaLoader);
+    }
+}
+
+push @ISA, qw(Tie::Hash Exporter);
 @EXPORT = qw(
         $DB_BTREE $DB_HASH $DB_RECNO 
 
@@ -196,7 +208,7 @@ sub AUTOLOAD {
     ($constname = $AUTOLOAD) =~ s/.*:://;
     my $val = constant($constname, @_ ? $_[0] : 0);
     if ($! != 0) {
-	if ($! =~ /Invalid/) {
+	if ($! =~ /Invalid/ || $!{EINVAL}) {
 	    $AutoLoader::AUTOLOAD = $AUTOLOAD;
 	    goto &AutoLoader::AUTOLOAD;
 	}
@@ -219,19 +231,10 @@ eval {
     push(@EXPORT, @O);
 };
 
-## import borrowed from IO::File
-##   exports Fcntl constants if available.
-#sub import {
-#    my $pkg = shift;
-#    my $callpkg = caller;
-#    Exporter::export $pkg, $callpkg, @_;
-#    eval {
-#        require Fcntl;
-#        Exporter::export 'Fcntl', $callpkg, '/^O_/';
-#    };
-#}
-
-bootstrap DB_File $VERSION;
+if ($use_XSLoader)
+  { XSLoader::load("DB_File", $VERSION)}
+else
+  { bootstrap DB_File $VERSION }
 
 # Preloaded methods go here.  Autoload methods go after __END__, and are
 # processed by the autosplit program.
@@ -408,6 +411,12 @@ DB_File - Perl5 access to Berkeley DB version 1.x
  $a = $X->shift;
  $X->unshift(list);
 
+ # DBM Filters
+ $old_filter = $db->filter_store_key  ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
  untie %hash ;
  untie @array ;
 
@@ -415,10 +424,10 @@ DB_File - Perl5 access to Berkeley DB version 1.x
 
 B<DB_File> is a module which allows Perl programs to make use of the
 facilities provided by Berkeley DB version 1.x (if you have a newer
-version of DB, see L<Using DB_File with Berkeley DB version 2>). It is
-assumed that you have a copy of the Berkeley DB manual pages at hand
-when reading this documentation. The interface defined here mirrors the
-Berkeley DB interface closely.
+version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>).
+It is assumed that you have a copy of the Berkeley DB manual pages at
+hand when reading this documentation. The interface defined here
+mirrors the Berkeley DB interface closely.
 
 Berkeley DB is a C library which provides a consistent interface to a
 number of database formats.  B<DB_File> provides an interface to all
@@ -459,32 +468,28 @@ number.
 
 =back
 
-=head2 Using DB_File with Berkeley DB version 2
+=head2 Using DB_File with Berkeley DB version 2 or 3
 
 Although B<DB_File> is intended to be used with Berkeley DB version 1,
-it can also be used with version 2. In this case the interface is
+it can also be used with version 2.or 3 In this case the interface is
 limited to the functionality provided by Berkeley DB 1.x. Anywhere the
-version 2 interface differs, B<DB_File> arranges for it to work like
-version 1. This feature allows B<DB_File> scripts that were built with
-version 1 to be migrated to version 2 without any changes.
+version 2 or 3 interface differs, B<DB_File> arranges for it to work
+like version 1. This feature allows B<DB_File> scripts that were built
+with version 1 to be migrated to version 2 or 3 without any changes.
 
 If you want to make use of the new features available in Berkeley DB
-2.x, use the Perl module B<BerkeleyDB> instead.
+2.x or greater, use the Perl module B<BerkeleyDB> instead.
 
-At the time of writing this document the B<BerkeleyDB> module is still
-alpha quality (the version number is < 1.0), and so unsuitable for use
-in any serious development work. Once its version number is >= 1.0, it
-is considered stable enough for real work.
-
-B<Note:> The database file format has changed in Berkeley DB version 2.
-If you cannot recreate your databases, you must dump any existing
-databases with the C<db_dump185> utility that comes with Berkeley DB.
-Once you have rebuilt DB_File to use Berkeley DB version 2, your
+B<Note:> The database file format has changed in both Berkeley DB
+version 2 and 3. If you cannot recreate your databases, you must dump
+any existing databases with the C<db_dump185> utility that comes with
+Berkeley DB.
+Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
 databases can be recreated using C<db_load>. Refer to the Berkeley DB
 documentation for further details.
 
-Please read L<"COPYRIGHT"> before using version 2.x of Berkeley DB with
-DB_File.
+Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley
+DB with DB_File.
 
 =head2 Interface to Berkeley DB
 
@@ -664,6 +669,7 @@ contents of the database.
     use DB_File ;
     use vars qw( %h $k $v ) ;
 
+    unlink "fruit" ;
     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
         or die "Cannot open file 'fruit': $!\n";
 
@@ -723,6 +729,7 @@ insensitive compare function will be used.
     # specify the Perl sub that will do the comparison
     $DB_BTREE->{'compare'} = \&Compare ;
 
+    unlink "tree" ;
     tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE 
         or die "Cannot open file 'tree': $!\n" ;
 
@@ -799,7 +806,7 @@ code:
 
     # iterate through the associative array
     # and print each key/value pair.
-    foreach (keys %h)
+    foreach (sort keys %h)
       { print "$_  -> $h{$_}\n" }
 
     untie %h ;
@@ -901,6 +908,19 @@ particular value occurred in the BTREE.
 So assuming the database created above, we can use C<get_dup> like
 this:
 
+    use strict ;
+    use DB_File ;
+ 
+    use vars qw($filename $x %h ) ;
+
+    $filename = "tree" ;
+ 
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+ 
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+	or die "Cannot open $filename: $!\n";
+
     my $cnt  = $x->get_dup("Wall") ;
     print "Wall occurred $cnt times\n" ;
 
@@ -908,7 +928,7 @@ this:
     print "Larry is there\n" if $hash{'Larry'} ;
     print "There are $hash{'Brick'} Brick Walls\n" ;
 
-    my @list = $x->get_dup("Wall") ;
+    my @list = sort $x->get_dup("Wall") ;
     print "Wall =>	[@list]\n" ;
 
     @list = $x->get_dup("Smith") ;
@@ -931,7 +951,7 @@ and it will print:
 
     $status = $X->find_dup($key, $value) ;
 
-This method checks for the existance of a specific key/value pair. If the
+This method checks for the existence of a specific key/value pair. If the
 pair exists, the cursor is left pointing to the pair and the method 
 returns 0. Otherwise the method returns a non-zero value.
 
@@ -961,7 +981,7 @@ Assuming the database from the previous example:
 
 prints this
 
-    Larry Wall is there
+    Larry Wall is  there
     Harry Wall is not there
 
 
@@ -973,7 +993,7 @@ This method deletes a specific key/value pair. It returns
 0 if they exist and have been deleted successfully.
 Otherwise the method returns a non-zero value.
 
-Again assuming the existance of the C<tree> database
+Again assuming the existence of the C<tree> database
 
     use strict ;
     use DB_File ;
@@ -1053,7 +1073,7 @@ and print the first matching key/value pair given a partial key.
 	 $st == 0 ;
          $st = $x->seq($key, $value, R_NEXT) )
 	
-      {  print "$key -> $value\n" }
+      {  print "$key	-> $value\n" }
  
     print "\nPARTIAL MATCH\n" ;
 
@@ -1126,8 +1146,11 @@ L<Extra RECNO Methods> for a workaround).
     use strict ;
     use DB_File ;
 
+    my $filename = "text" ;
+    unlink $filename ;
+
     my @h ;
-    tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO 
+    tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO 
         or die "Cannot open file 'text': $!\n" ;
 
     # Add a few key/value pairs to the file
@@ -1160,7 +1183,7 @@ Here is the output from the script:
 
     The array contains 5 entries
     popped black
-    unshifted white
+    shifted white
     Element 1 Exists with value blue
     The last element is green
     The 2nd last element is yellow
@@ -1466,8 +1489,8 @@ R_CURSOR is the only valid flag at present.
 
 Returns the file descriptor for the underlying database.
 
-See L<Locking Databases> for an example of how to make use of the
-C<fd> method to lock your database.
+See L<Locking: The Trouble with fd> for an explanation for why you should
+not use C<fd> to lock your database.
 
 =item B<$status = $X-E<gt>seq($key, $value, $flags) ;>
 
@@ -1488,67 +1511,262 @@ R_RECNOSYNC is the only valid flag at present.
 
 =back
 
+=head1 DBM FILTERS
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a
+DBM database.
+
+There are four methods associated with DBM Filters. All work identically,
+and each is used to install (or uninstall) a single DBM Filter. Each
+expects a single parameter, namely a reference to a sub. The only
+difference between them is the place that the filter is installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database
+that you need to share with a third-party C application. The C application
+assumes that I<all> keys and values are NULL terminated. Unfortunately
+when Perl writes to DBM databases it doesn't use NULL termination, so
+your Perl application will have to manage NULL termination itself. When
+you write to the database you will have to use something like this:
+
+    $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+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 strict ;
+    use DB_File ;
+
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
+      or die "Cannot open $filename: $!\n" ;
+
+    # Install DBM Filters
+    $db->filter_fetch_key  ( sub { s/\0$//    } ) ;
+    $db->filter_store_key  ( sub { $_ .= "\0" } ) ;
+    $db->filter_fetch_value( sub { s/\0$//    } ) ;
+    $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+    $hash{"abc"} = "def" ;
+    my $a = $hash{"ABC"} ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+    $hash{12345} = "soemthing" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+    use strict ;
+    use DB_File ;
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+
+    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
+      or die "Cannot open $filename: $!\n" ;
+
+    $db->filter_fetch_key  ( sub { $_ = unpack("i", $_) } ) ;
+    $db->filter_store_key  ( sub { $_ = pack ("i", $_) } ) ;
+    $hash{123} = "def" ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
 =head1 HINTS AND TIPS 
 
 
-=head2 Locking Databases
+=head2 Locking: The Trouble with fd
 
-Concurrent access of a read-write database by several parties requires
-them all to use some kind of locking.  Here's an example of Tom's that
-uses the I<fd> method to get the file descriptor, and then a careful
-open() to give something Perl will flock() for you.  Run this repeatedly
-in the background to watch the locks granted in proper order.
+Until version 1.72 of this module, the recommended technique for locking
+B<DB_File> databases was to flock the filehandle returned from the "fd"
+function. Unfortunately this technique has been shown to be fundamentally
+flawed (Kudos to David Harris for tracking this down). Use it at your own
+peril!
 
-    use DB_File;
+The locking technique went like this. 
 
-    use strict;
-
-    sub LOCK_SH { 1 }
-    sub LOCK_EX { 2 }
-    sub LOCK_NB { 4 }
-    sub LOCK_UN { 8 }
-
-    my($oldval, $fd, $db, %db, $value, $key);
-
-    $key = shift || 'default';
-    $value = shift || 'magic';
-
-    $value .= " $$";
-
-    $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) 
-	    || die "dbcreat /tmp/foo.db $!";
+    $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644)
+        || die "dbcreat /tmp/foo.db $!";
     $fd = $db->fd;
-    print "$$: db fd is $fd\n";
     open(DB_FH, "+<&=$fd") || die "dup $!";
-
-
-    unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
-	print "$$: CONTENTION; can't read during write update!
-		    Waiting for read lock ($!) ....";
-	unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" }
-    } 
-    print "$$: Read lock granted\n";
-
-    $oldval = $db{$key};
-    print "$$: Old value was $oldval\n";
-    flock(DB_FH, LOCK_UN);
-
-    unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
-	print "$$: CONTENTION; must have exclusive lock!
-		    Waiting for write lock ($!) ....";
-	unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
-    } 
-
-    print "$$: Write lock granted\n";
-    $db{$key} = $value;
-    $db->sync;	# to flush
-    sleep 10;
-
+    flock (DB_FH, LOCK_EX) || die "flock: $!";
+    ...
+    $db{"Tom"} = "Jerry" ;
+    ...
     flock(DB_FH, LOCK_UN);
     undef $db;
     untie %db;
     close(DB_FH);
-    print "$$: Updated db to $key=$value\n";
+
+In simple terms, this is what happens:
+
+=over 5
+
+=item 1.
+
+Use "tie" to open the database.
+
+=item 2.
+
+Lock the database with fd & flock.
+
+=item 3.
+
+Read & Write to the database.
+
+=item 4.
+
+Unlock and close the database.
+
+=back
+
+Here is the crux of the problem. A side-effect of opening the B<DB_File>
+database in step 2 is that an initial block from the database will get
+read from disk and cached in memory.
+
+To see why this is a problem, consider what can happen when two processes,
+say "A" and "B", both want to update the same B<DB_File> database
+using the locking steps outlined above. Assume process "A" has already
+opened the database and has a write lock, but it hasn't actually updated
+the database yet (it has finished step 2, but not started step 3 yet). Now
+process "B" tries to open the same database - step 1 will succeed,
+but it will block on step 2 until process "A" releases the lock. The
+important thing to notice here is that at this point in time both
+processes will have cached identical initial blocks from the database.
+
+Now process "A" updates the database and happens to change some of the
+data held in the initial buffer. Process "A" terminates, flushing
+all cached data to disk and releasing the database lock. At this point
+the database on disk will correctly reflect the changes made by process
+"A".
+
+With the lock released, process "B" can now continue. It also updates the
+database and unfortunately it too modifies the data that was in its
+initial buffer. Once that data gets flushed to disk it will overwrite
+some/all of the changes process "A" made to the database.
+
+The result of this scenario is at best a database that doesn't contain
+what you expect. At worst the database will corrupt.
+
+The above won't happen every time competing process update the same
+B<DB_File> database, but it does illustrate why the technique should
+not be used.
+
+=head2 Safe ways to lock a database
+
+Starting with version 2.x, Berkeley DB  has internal support for locking.
+The companion module to this one, B<BerkeleyDB>, provides an interface
+to this locking functionality. If you are serious about locking
+Berkeley DB databases, I strongly recommend using B<BerkeleyDB>.
+
+If using B<BerkeleyDB> isn't an option, there are a number of modules
+available on CPAN that can be used to implement locking. Each one
+implements locking differently and has different goals in mind. It is
+therefore worth knowing the difference, so that you can pick the right
+one for your application. Here are the three locking wrappers:
+
+=over 5
+
+=item B<Tie::DB_Lock>
+
+A B<DB_File> wrapper which creates copies of the database file for
+read access, so that you have a kind of a multiversioning concurrent read
+system. However, updates are still serial. Use for databases where reads
+may be lengthy and consistency problems may occur.
+
+=item B<Tie::DB_LockFile> 
+
+A B<DB_File> wrapper that has the ability to lock and unlock the database
+while it is being used. Avoids the tie-before-flock problem by simply
+re-tie-ing the database when you get or drop a lock.  Because of the
+flexibility in dropping and re-acquiring the lock in the middle of a
+session, this can be massaged into a system that will work with long
+updates and/or reads if the application follows the hints in the POD
+documentation.
+
+=item B<DB_File::Lock> 
+
+An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile
+before tie-ing the database and drops the lock after the untie. Allows
+one to use the same lockfile for multiple databases to avoid deadlock
+problems, if desired. Use for databases where updates are reads are
+quick and simple flock locking semantics are enough.
+
+=back
 
 =head2 Sharing Databases With C Applications
 
@@ -1557,7 +1775,7 @@ shared by both a Perl and a C application.
 
 The vast majority of problems that are reported in this area boil down
 to the fact that C strings are NULL terminated, whilst Perl strings are
-not. 
+not. See L<DBM FILTERS> for a generic way to work around this problem.
 
 Here is a real example. Netscape 2.0 keeps a record of the locations you
 visit along with the time you last visited them in a DB_HASH database.
@@ -1654,7 +1872,7 @@ C<%x>, and C<$X> above hold a reference to the object. The call to
 untie() will destroy the first, but C<$X> still holds a valid
 reference, so the destructor will not get called and the database file
 F<tst.fil> will remain open. The fact that Berkeley DB then reports the
-attempt to open a database that is alreday open via the catch-all
+attempt to open a database that is already open via the catch-all
 "Invalid argument" doesn't help.
 
 If you run the script with the C<-w> flag the error message becomes:
@@ -1746,6 +1964,19 @@ double quotes, like this:
 Although it might seem like a real pain, it is really worth the effort
 of having a C<use strict> in all your scripts.
 
+=head1 REFERENCES
+
+Articles that are either about B<DB_File> or make use of it.
+
+=over 5
+
+=item 1.
+
+I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com),
+Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41
+
+=back
+
 =head1 HISTORY
 
 Moved to the Changes file.
@@ -1768,13 +1999,12 @@ date, so the most recent version can always be found on CPAN (see
 L<perlmod/CPAN> for details), in the directory
 F<modules/by-module/DB_File>.
 
-This version of B<DB_File> will work with either version 1.x or 2.x of
-Berkeley DB, but is limited to the functionality provided by version 1.
+This version of B<DB_File> will work with either version 1.x, 2.x or
+3.x of Berkeley DB, but is limited to the functionality provided by
+version 1.
 
-The official web site for Berkeley DB is
-F<http://www.sleepycat.com/db>. The ftp equivalent is
-F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are
-available there.
+The official web site for Berkeley DB is F<http://www.sleepycat.com>.
+All versions of Berkeley DB are available there.
 
 Alternatively, Berkeley DB version 1 is available at your nearest CPAN
 archive in F<src/misc/db.1.85.tar.gz>.
@@ -1785,7 +2015,7 @@ compile properly on IRIX 5.3.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-1999 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.
 
@@ -1794,7 +2024,7 @@ makes use of, namely Berkeley DB, is not. Berkeley DB has its own
 copyright and its own license. Please take the time to read it.
 
 Here are are few words taken from the Berkeley DB FAQ (at
-http://www.sleepycat.com) regarding the license:
+F<http://www.sleepycat.com>) regarding the license:
 
     Do I have to license DB to use it in Perl scripts? 
 
@@ -1811,7 +2041,8 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
 
 =head1 SEE ALSO
 
-L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> 
+L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>,
+L<dbmfilter>
 
 =head1 AUTHOR
 

contrib/perl5/ext/DB_File/Makefile.PL

@@ -14,7 +14,15 @@ WriteMakefile(
         MAN3PODS        => {},         # Pods will be built by installman.
 	#INC		=> '-I/usr/local/include',
 	VERSION_FROM	=> 'DB_File.pm',
+	OBJECT		=> 'version$(OBJ_EXT) DB_File$(OBJ_EXT)',
 	XSPROTOARG	=> '-noprototypes',
-	DEFINE		=> "$OS2",
+	DEFINE		=> $OS2 || "",
 	);
 
+sub MY::postamble {
+      '
+version$(OBJ_EXT):	version.c
+
+' ;
+}
+

contrib/perl5/ext/DB_File/dbinfo

@@ -4,8 +4,8 @@
 #			  a database file
 #
 # Author:	Paul Marquess  <Paul.Marquess@btinternet.com>
-# Version: 	1.01 
-# Date		16th April 1998
+# Version: 	1.02 
+# Date		20th August 1999
 #
 #     Copyright (c) 1998 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
@@ -19,7 +19,7 @@ use strict ;
 my %Data =
 	(
 	0x053162 =>	{
-			  Type 	=> "Btree",
+			  Type 	   => "Btree",
 			  Versions => 
 				{
 				  1	=> "Unknown (older than 1.71)",
@@ -27,18 +27,27 @@ my %Data =
 				  3	=> "1.71 -> 1.85, 1.86",
 				  4	=> "Unknown",
 				  5	=> "2.0.0 -> 2.3.0",
-				  6	=> "2.3.1 or greater",
+				  6	=> "2.3.1 -> 2.7.7",
+				  7	=> "3.0.0 or greater",
 				}
 			},
 	0x061561 => 	{
-			  Type => "Hash",
+			  Type     => "Hash",
 			  Versions =>
 				{
 				  1	=> "Unknown (older than 1.71)",
         			  2     => "1.71 -> 1.85",
         			  3     => "1.86",
         			  4     => "2.0.0 -> 2.1.0",
-        			  5     => "2.2.6 or greater",
+        			  5     => "2.2.6 -> 2.7.7",
+        			  6     => "3.0.0 or greater",
+				}
+			},
+	0x042253 => 	{
+			  Type     => "Queue",
+			  Versions =>
+				{
+				  1	=> "3.0.0 or greater",
 				}
 			},
 	) ;

contrib/perl5/ext/DB_File/hints/sco.pl

@@ -0,0 +1,2 @@
+# osr5 needs to explicitly link against libc to pull in some static symbols
+$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ;

contrib/perl5/ext/DB_File/typemap

@@ -1,8 +1,8 @@
 # typemap for Perl 5 interface to Berkeley 
 #
 # written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 21st February 1999
-# version 1.65
+# last modified 7th September 1999
+# version 1.71
 #
 #################################### DB SECTION
 #
@@ -15,21 +15,23 @@ DBTKEY			T_dbtkeydatum
 
 INPUT
 T_dbtkeydatum
+	ckFilter($arg, filter_store_key, \"filter_store_key\");
+	DBT_clear($var) ;
 	if (db->type != DB_RECNO) {
 	    $var.data = SvPV($arg, PL_na);
 	    $var.size = (int)PL_na;
-	    DBT_flags($var);
 	}
 	else {
-	    Value =  GetRecnoKey(db, SvIV($arg)) ; 
+	    Value =  GetRecnoKey(aTHX_ db, SvIV($arg)) ; 
 	    $var.data = & Value; 
 	    $var.size = (int)sizeof(recno_t);
-	    DBT_flags($var);
 	}
 T_dbtdatum
+	ckFilter($arg, filter_store_value, \"filter_store_value\");
+	DBT_clear($var) ;
 	$var.data = SvPV($arg, PL_na);
 	$var.size = (int)PL_na;
-	DBT_flags($var);
+
 
 OUTPUT
 

contrib/perl5/ext/DB_File/version.c

@@ -0,0 +1,71 @@
+/* 
+
+ version.c -- Perl 5 interface to Berkeley DB 
+
+ written by Paul Marquess <Paul.Marquess@btinternet.com>
+ last modified 16th January 2000
+ version 1.72
+
+ All comments/suggestions/problems are welcome
+
+     Copyright (c) 1995-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.
+
+ Changes:
+        1.71 -  Support for Berkeley DB version 3.
+		Support for Berkeley DB 2/3's backward compatability mode.
+        1.72 -  No change.
+
+*/
+
+#include "EXTERN.h"  
+#include "perl.h"
+#include "XSUB.h"
+
+#include <db.h>
+
+void
+__getBerkeleyDBInfo()
+{
+    SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ;
+    SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ;
+    SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ;
+
+#ifdef DB_VERSION_MAJOR
+    int Major, Minor, Patch ;
+
+    (void)db_version(&Major, &Minor, &Patch) ;
+
+    /* Check that the versions of db.h and libdb.a are the same */
+    if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR 
+		|| Patch != DB_VERSION_PATCH)
+	croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n",  
+		DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, 
+		Major, Minor, Patch) ;
+    
+    /* check that libdb is recent enough  -- we need 2.3.4 or greater */
+    if (Major == 2 && (Minor < 3 || (Minor ==  3 && Patch < 4)))
+	croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
+		 Major, Minor, Patch) ;
+ 
+    {
+        char buffer[40] ;
+        sprintf(buffer, "%d.%d", Major, Minor) ;
+        sv_setpv(version_sv, buffer) ; 
+        sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ;
+        sv_setpv(ver_sv, buffer) ; 
+    }
+ 
+#else /* ! DB_VERSION_MAJOR */
+    sv_setiv(version_sv, 1) ;
+    sv_setiv(ver_sv, 1) ;
+#endif /* ! DB_VERSION_MAJOR */
+
+#ifdef COMPAT185
+    sv_setiv(compat_sv, 1) ;
+#else /* ! COMPAT185 */
+    sv_setiv(compat_sv, 0) ;
+#endif /* ! COMPAT185 */
+
+}

contrib/perl5/ext/Data/Dumper/Changes

@@ -6,6 +6,21 @@ HISTORY - public release history for Data::Dumper
 
 =over 8
 
+=item 2.11  (unreleased)
+
+C<0> is now dumped as such, not as C<'0'>.
+
+qr// objects are now dumped correctly (provided a post-5.005_58)
+overload.pm exists).
+
+Implemented $Data::Dumper::Maxdepth, which was on the Todo list.
+Thanks to John Nolan <jpnolan@Op.Net>.
+
+=item 2.101 (30 Apr 1999)
+
+Minor release to sync with version in 5.005_03.  Fixes dump of
+dummy coderefs.
+
 =item 2.10  (31 Oct 1998)
 
 Bugfixes for dumping related undef values, globs, and better double

contrib/perl5/ext/Data/Dumper/Dumper.pm

@@ -9,22 +9,22 @@
 
 package Data::Dumper;
 
-$VERSION = $VERSION = '2.101';
+$VERSION = '2.101';
 
 #$| = 1;
 
-require 5.004;
+require 5.005_64;
 require Exporter;
-require DynaLoader;
+use XSLoader ();
 require overload;
 
 use Carp;
 
-@ISA = qw(Exporter DynaLoader);
+@ISA = qw(Exporter);
 @EXPORT = qw(Dumper);
 @EXPORT_OK = qw(DumperX);
 
-bootstrap Data::Dumper;
+XSLoader::load 'Data::Dumper';
 
 # module vars and their defaults
 $Indent = 2 unless defined $Indent;
@@ -39,7 +39,7 @@ $Deepcopy = 0 unless defined $Deepcopy;
 $Quotekeys = 1 unless defined $Quotekeys;
 $Bless = "bless" unless defined $Bless;
 #$Expdepth = 0 unless defined $Expdepth;
-#$Maxdepth = 0 unless defined $Maxdepth;
+$Maxdepth = 0 unless defined $Maxdepth;
 
 #
 # expects an arrayref of values to be dumped.
@@ -74,7 +74,7 @@ sub new {
              quotekeys	=> $Quotekeys,  # quote hash keys
              'bless'	=> $Bless,	# keyword to use for "bless"
 #	     expdepth   => $Expdepth,   # cutoff depth for explicit dumping
-#	     maxdepth	=> $Maxdepth,   # depth beyond which we give up
+	     maxdepth	=> $Maxdepth,   # depth beyond which we give up
 	   };
 
   if ($Indent > 0) {
@@ -146,11 +146,17 @@ sub Names {
 
 sub DESTROY {}
 
+sub Dump {
+    return &Dumpxs
+	unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq});
+    return &Dumpperl;
+}
+
 #
 # dump the refs in the current dumper object.
 # expects same args as new() if called via package name.
 #
-sub Dump {
+sub Dumpperl {
   my($s) = shift;
   my(@out, $val, $name);
   my($i) = 0;
@@ -214,14 +220,13 @@ sub _dump {
   if ($type) {
 
     # prep it, if it looks like an object
-    if ($type =~ /[a-z_:]/) {
-      my $freezer = $s->{freezer};
-      $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer);
+    if (my $freezer = $s->{freezer}) {
+      $val->$freezer() if UNIVERSAL::can($val, $freezer);
     }
 
     ($realpack, $realtype, $id) =
       (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);
-    
+
     # if it has a name, we need to either look it up, or keep a tab
     # on it so we know when we hit it later
     if (defined($name) and length($name)) {
@@ -231,7 +236,7 @@ sub _dump {
 	  if ($s->{purity} and $s->{level} > 0) {
 	    $out = ($realtype eq 'HASH')  ? '{}' :
 	      ($realtype eq 'ARRAY') ? '[]' :
-		"''" ;
+		'do{my $o}' ;
 	    push @post, $name . " = " . $s->{seen}{$id}[0];
 	  }
 	  else {
@@ -259,14 +264,33 @@ sub _dump {
       }
     }
 
-    $s->{level}++;
-    $ipad = $s->{xpad} x $s->{level};
+    if ($realpack and $realpack eq 'Regexp') {
+	$out = "$val";
+	$out =~ s,/,\\/,g;
+	return "qr/$out/";
+    }
 
-    if ($realpack) {          # we have a blessed ref
+    # If purity is not set and maxdepth is set, then check depth: 
+    # if we have reached maximum depth, return the string
+    # representation of the thing we are currently examining
+    # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). 
+    if (!$s->{purity}
+	and $s->{maxdepth} > 0
+	and $s->{level} >= $s->{maxdepth})
+    {
+      return qq['$val'];
+    }
+
+    # we have a blessed ref
+    if ($realpack) {
       $out = $s->{'bless'} . '( ';
       $blesspad = $s->{apad};
       $s->{apad} .= '       ' if ($s->{indent} >= 2);
     }
+
+    $s->{level}++;
+    $ipad = $s->{xpad} x $s->{level};
+
     
     if ($realtype eq 'SCALAR') {
       if ($realpack) {
@@ -389,7 +413,7 @@ sub _dump {
     elsif (!defined($val)) {
       $out .= "undef";
     }
-    elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number
+    elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})$/) { # safe decimal number
       $out .= $val;
     }
     else {				 # string
@@ -422,9 +446,7 @@ sub Dumper {
   return Data::Dumper->Dump([@_]);
 }
 
-#
-# same, only calls the XS version
-#
+# compat stub
 sub DumperX {
   return Data::Dumper->Dumpxs([@_], []);
 }
@@ -511,6 +533,12 @@ sub Bless {
   defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
 }
 
+sub Maxdepth {
+  my($s, $v) = @_;
+  defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
+}
+
+
 # used by qquote below
 my %esc = (  
     "\a" => "\\a",
@@ -526,25 +554,35 @@ my %esc = (
 sub qquote {
   local($_) = shift;
   s/([\\\"\@\$])/\\$1/g;
-  return qq("$_") unless /[^\040-\176]/;  # fast exit
+  return qq("$_") unless 
+    /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/;  # fast exit
 
   my $high = shift || "";
   s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
 
-  # no need for 3 digits in escape for these
-  s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
-
-  s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
-  if ($high eq "iso8859") {
-    s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
-  } elsif ($high eq "utf8") {
-#   use utf8;
-#   $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
-  } elsif ($high eq "8bit") {
-      # leave it as it is
-  } else {
-    s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+  if (ord('^')==94)  { # ascii
+    # no need for 3 digits in escape for these
+    s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
+    s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
+    # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
+    if ($high eq "iso8859") {
+      s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
+    } elsif ($high eq "utf8") {
+#     use utf8;
+#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+    } elsif ($high eq "8bit") {
+        # leave it as it is
+    } else {
+      s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+    }
   }
+  else { # ebcdic
+      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
+       {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
+      s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
+       {'\\'.sprintf('%03o',ord($1))}eg;
+  }
+
   return qq("$_");
 }
 
@@ -653,12 +691,6 @@ of strings corresponding to the supplied values.
 The second form, for convenience, simply calls the C<new> method on its
 arguments before dumping the object immediately.
 
-=item I<$OBJ>->Dumpxs  I<or>  I<PACKAGE>->Dumpxs(I<ARRAYREF [>, I<ARRAYREF]>)
-
-This method is available if you were able to compile and install the XSUB
-extension to C<Data::Dumper>. It is exactly identical to the C<Dump> method 
-above, only about 4 to 5 times faster, since it is written entirely in C.
-
 =item I<$OBJ>->Seen(I<[HASHREF]>)
 
 Queries or adds to the internal table of already encountered references.
@@ -702,12 +734,6 @@ configuration options below.  The values will be named C<$VAR>I<n> in the
 output, where I<n> is a numeric suffix.  Will return a list of strings
 in an array context.
 
-=item DumperX(I<LIST>)
-
-Identical to the C<Dumper()> function above, but this calls the XSUB 
-implementation.  Only available if you were able to compile and install
-the XSUB extensions in C<Data::Dumper>.
-
 =back
 
 =head2 Configuration Variables or Methods
@@ -763,8 +789,8 @@ When set, enables the use of double quotes for representing string values.
 Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
 characters will be backslashed, and unprintable characters will be output as
 quoted octal integers.  Since setting this variable imposes a performance
-penalty, the default is 0.  The C<Dumpxs()> method does not honor this
-flag yet.
+penalty, the default is 0.  C<Dump()> will run slower if this flag is set,
+since the fast XSUB implementation doesn't support it yet.
 
 =item $Data::Dumper::Terse  I<or>  I<$OBJ>->Terse(I<[NEWVAL]>)
 
@@ -814,6 +840,14 @@ builtin operator used to create objects.  A function with the specified
 name should exist, and should accept the same arguments as the builtin.
 Default is C<bless>.
 
+=item $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
+
+Can be set to a positive integer that specifies the depth beyond which
+which we don't venture into a structure.  Has no effect when
+C<Data::Dumper::Purity> is set.  (Useful in debugger when we often don't
+want to see more than enough).  Default is 0, which means there is 
+no maximum depth. 
+
 =back
 
 =head2 Exports
@@ -847,7 +881,7 @@ distribution for more examples.)
     $boo = [ 1, [], "abcd", \*foo,
              {1 => 'a', 023 => 'b', 0x45 => 'c'}, 
              \\"p\q\'r", $foo, $fuz];
-    
+
     ########
     # simple usage
     ########
@@ -868,12 +902,12 @@ distribution for more examples.)
 
     $Data::Dumper::Useqq = 1;          # print strings in double quotes
     print Dumper($boo);
-    
-    
+
+
     ########
     # recursive structures
     ########
-    
+
     @c = ('c');
     $c = \@c;
     $b = {};
@@ -882,37 +916,52 @@ distribution for more examples.)
     $b->{b} = $a->[1];
     $b->{c} = $a->[2];
     print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);
-    
-    
+
+
     $Data::Dumper::Purity = 1;         # fill in the holes for eval
     print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
     print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b
-    
-    
+
+
     $Data::Dumper::Deepcopy = 1;       # avoid cross-refs
     print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
-    
-    
+
+
     $Data::Dumper::Purity = 0;         # avoid cross-refs
     print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
-    
-    
+
+    ########
+    # deep structures
+    ########
+
+    $a = "pearl";
+    $b = [ $a ];
+    $c = { 'b' => $b };
+    $d = [ $c ];
+    $e = { 'd' => $d };
+    $f = { 'e' => $e };
+    print Data::Dumper->Dump([$f], [qw(f)]);
+
+    $Data::Dumper::Maxdepth = 3;       # no deeper than 3 refs down
+    print Data::Dumper->Dump([$f], [qw(f)]);
+
+
     ########
     # object-oriented usage
     ########
-    
+
     $d = Data::Dumper->new([$a,$b], [qw(a b)]);
     $d->Seen({'*c' => $c});            # stash a ref without printing it
     $d->Indent(3);
     print $d->Dump;
     $d->Reset->Purity(0);              # empty the seen cache
     print join "----\n", $d->Dump;
-    
-    
+
+
     ########
     # persistence
     ########
-    
+
     package Foo;
     sub new { bless { state => 'awake' }, shift }
     sub Freeze {
@@ -921,7 +970,7 @@ distribution for more examples.)
 	$s->{state} = 'asleep';
 	return bless $s, 'Foo::ZZZ';
     }
-    
+
     package Foo::ZZZ;
     sub Thaw {
         my $s = shift;
@@ -929,7 +978,7 @@ distribution for more examples.)
 	$s->{state} = 'awake';
 	return bless $s, 'Foo';
     }
-    
+
     package Foo;
     use Data::Dumper;
     $a = Foo->new;
@@ -940,12 +989,12 @@ distribution for more examples.)
     print $c;
     $d = eval $c;
     print Data::Dumper->Dump([$d], ['d']);
-    
-    
+
+
     ########
     # symbol substitution (useful for recreating CODE refs)
     ########
-    
+
     sub foo { print "foo speaking\n" }
     *other = \&foo;
     $bar = [ \&other ];
@@ -974,15 +1023,15 @@ to have, you can use the C<Seen> method to pre-seed the internal reference
 table and make the dumped output point to them, instead.  See L<EXAMPLES>
 above.
 
-The C<Useqq> flag is not honored by C<Dumpxs()> (it always outputs
-strings in single quotes).
+The C<Useqq> flag makes Dump() run slower, since the XSUB implementation
+does not support it.
 
 SCALAR objects have the weirdest looking C<bless> workaround.
 
 
 =head1 AUTHOR
 
-Gurusamy Sarathy        gsar@umich.edu
+Gurusamy Sarathy        gsar@activestate.com
 
 Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
 This program is free software; you can redistribute it and/or
@@ -991,7 +1040,7 @@ modify it under the same terms as Perl itself.
 
 =head1 VERSION
 
-Version 2.10    (31 Oct 1998)
+Version 2.11   (unreleased)
 
 =head1 SEE ALSO
 

contrib/perl5/ext/Data/Dumper/Dumper.xs

@@ -1,10 +1,14 @@
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
+#ifndef PERL_VERSION
 #include "patchlevel.h"
+#define PERL_VERSION PATCHLEVEL
+#endif
 
-#if PATCHLEVEL < 5
+#if PERL_VERSION < 5
 #  ifndef PL_sv_undef
 #    define PL_sv_undef	sv_undef
 #  endif
@@ -16,14 +20,15 @@
 #  endif
 #endif
 
-static I32 num_q _((char *s, STRLEN slen));
-static I32 esc_q _((char *dest, char *src, STRLEN slen));
-static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n));
-static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval,
-		      HV *seenhv, AV *postav, I32 *levelp, I32 indent,
-		      SV *pad, SV *xpad, SV *apad, SV *sep,
-		      SV *freezer, SV *toaster,
-		      I32 purity, I32 deepcopy, I32 quotekeys, SV *bless));
+static I32 num_q (char *s, STRLEN slen);
+static I32 esc_q (char *dest, char *src, STRLEN slen);
+static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
+static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
+		    HV *seenhv, AV *postav, I32 *levelp, I32 indent,
+		    SV *pad, SV *xpad, SV *apad, SV *sep,
+		    SV *freezer, SV *toaster,
+		    I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
+		    I32 maxdepth);
 
 /* does a string need to be protected? */
 static I32
@@ -40,11 +45,12 @@ TOP:
     }
     if (isIDFIRST(*s)) {
 	while (*++s)
-	    if (!isALNUM(*s))
+	    if (!isALNUM(*s)) {
 		if (*s == ':')
 		    goto TOP;
 		else
 		    return 1;
+	    }
     }
     else 
 	return 1;
@@ -92,7 +98,7 @@ esc_q(register char *d, register char *s, register STRLEN slen)
 
 /* append a repeated string to an SV */
 static SV *
-sv_x(SV *sv, register char *str, STRLEN len, I32 n)
+sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
 {
     if (sv == Nullsv)
 	sv = newSVpvn("", 0);
@@ -123,10 +129,10 @@ sv_x(SV *sv, register char *str, STRLEN len, I32 n)
  * efficiency raisins.)  Ugggh!
  */
 static I32
-DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
+DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
 	SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
-	I32 deepcopy, I32 quotekeys, SV *bless)
+	I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth)
 {
     char tmpbuf[128];
     U32 i;
@@ -196,7 +202,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 			else if (realtype == SVt_PVAV)
 			    sv_catpvn(retval, "[]", 2);
 			else
-			    sv_catpvn(retval, "''", 2);
+			    sv_catpvn(retval, "do{my $o}", 9);
 			postentry = newSVpvn(name, namelen);
 			sv_catpvn(postentry, " = ", 3);
 			sv_catsv(postentry, othername);
@@ -248,11 +254,39 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		SvREFCNT_dec(seenentry);
 	    }
 	}
-	
-	(*levelp)++;
-	ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
 
-	if (realpack) {   /* we have a blessed ref */
+	if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
+	    STRLEN rlen;
+	    char *rval = SvPV(val, rlen);
+	    char *slash = strchr(rval, '/');
+	    sv_catpvn(retval, "qr/", 3);
+	    while (slash) {
+		sv_catpvn(retval, rval, slash-rval);
+		sv_catpvn(retval, "\\/", 2);
+		rlen -= slash-rval+1;
+		rval = slash+1;
+		slash = strchr(rval, '/');
+	    }
+	    sv_catpvn(retval, rval, rlen);
+	    sv_catpvn(retval, "/", 1);
+	    return 1;
+	}
+
+	/* If purity is not set and maxdepth is set, then check depth:
+	 * if we have reached maximum depth, return the string
+	 * representation of the thing we are currently examining
+	 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). 
+	 */
+	if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
+	    STRLEN vallen;
+	    char *valstr = SvPV(val,vallen);
+	    sv_catpvn(retval, "'", 1);
+	    sv_catpvn(retval, valstr, vallen);
+	    sv_catpvn(retval, "'", 1);
+	    return 1;
+	}
+
+	if (realpack) {				/* we have a blessed ref */
 	    STRLEN blesslen;
 	    char *blessstr = SvPV(bless, blesslen);
 	    sv_catpvn(retval, blessstr, blesslen);
@@ -260,26 +294,31 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    if (indent >= 2) {
 		blesspad = apad;
 		apad = newSVsv(apad);
-		sv_x(apad, " ", 1, blesslen+2);
+		sv_x(aTHX_ apad, " ", 1, blesslen+2);
 	    }
 	}
 
+	(*levelp)++;
+	ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
+
 	if (realtype <= SVt_PVBM) {			     /* scalar ref */
 	    SV *namesv = newSVpvn("${", 2);
 	    sv_catpvn(namesv, name, namelen);
 	    sv_catpvn(namesv, "}", 1);
 	    if (realpack) {				     /* blessed */ 
 		sv_catpvn(retval, "do{\\(my $o = ", 13);
-		DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+		DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, apad, sep,
-			freezer, toaster, purity, deepcopy, quotekeys, bless);
+			freezer, toaster, purity, deepcopy, quotekeys, bless,
+			maxdepth);
 		sv_catpvn(retval, ")}", 2);
 	    }						     /* plain */
 	    else {
 		sv_catpvn(retval, "\\", 1);
-		DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+		DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, apad, sep,
-			freezer, toaster, purity, deepcopy, quotekeys, bless);
+			freezer, toaster, purity, deepcopy, quotekeys, bless,
+			maxdepth);
 	    }
 	    SvREFCNT_dec(namesv);
 	}
@@ -288,9 +327,10 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	    sv_catpvn(namesv, name, namelen);
 	    sv_catpvn(namesv, "}", 1);
 	    sv_catpvn(retval, "\\", 1);
-	    DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+	    DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
 		    postav, levelp,	indent, pad, xpad, apad, sep,
-		    freezer, toaster, purity, deepcopy, quotekeys, bless);
+		    freezer, toaster, purity, deepcopy, quotekeys, bless,
+		    maxdepth);
 	    SvREFCNT_dec(namesv);
 	}
 	else if (realtype == SVt_PVAV) {
@@ -345,7 +385,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		
 		ilen = inamelen;
 		sv_setiv(ixsv, ix);
-                (void) sprintf(iname+ilen, "%ld", ix);
+                (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
 		ilen = strlen(iname);
 		iname[ilen++] = ']'; iname[ilen] = '\0';
 		if (indent >= 3) {
@@ -356,14 +396,15 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		}
 		sv_catsv(retval, totpad);
 		sv_catsv(retval, ipad);
-		DD_dump(elem, iname, ilen, retval, seenhv, postav,
+		DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
 			levelp,	indent, pad, xpad, apad, sep,
-			freezer, toaster, purity, deepcopy, quotekeys, bless);
+			freezer, toaster, purity, deepcopy, quotekeys, bless,
+			maxdepth);
 		if (ix < ixmax)
 		    sv_catpvn(retval, ",", 1);
 	    }
 	    if (ixmax >= 0) {
-		SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
+		SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
 		sv_catsv(retval, totpad);
 		sv_catsv(retval, opad);
 		SvREFCNT_dec(opad);
@@ -462,16 +503,17 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 		else
 		    newapad = apad;
 
-		DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
+		DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
 			postav, levelp,	indent, pad, xpad, newapad, sep,
-			freezer, toaster, purity, deepcopy, quotekeys, bless);
+			freezer, toaster, purity, deepcopy, quotekeys, bless,
+			maxdepth);
 		SvREFCNT_dec(sname);
 		Safefree(nkey);
 		if (indent >= 2)
 		    SvREFCNT_dec(newapad);
 	    }
 	    if (i) {
-		SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
+		SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
 		sv_catsv(retval, totpad);
 		sv_catsv(retval, opad);
 		SvREFCNT_dec(opad);
@@ -543,7 +585,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 	if (SvIOK(val)) {
             STRLEN len;
 	    i = SvIV(val);
-            (void) sprintf(tmpbuf, "%d", i);
+            (void) sprintf(tmpbuf, "%"IVdf, (IV)i);
             len = strlen(tmpbuf);
 	    sv_catpvn(retval, tmpbuf, len);
 	}
@@ -599,12 +641,12 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
 			
 			SvCUR(newapad) = 0;
 			if (indent >= 2)
-			    (void)sv_x(newapad, " ", 1, SvCUR(postentry));
+			    (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
 			
-			DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
+			DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
 				seenhv, postav, &nlevel, indent, pad, xpad,
 				newapad, sep, freezer, toaster, purity,
-				deepcopy, quotekeys, bless);
+				deepcopy, quotekeys, bless, maxdepth);
 			SvREFCNT_dec(e);
 		    }
 		}
@@ -664,28 +706,22 @@ Data_Dumper_Dumpxs(href, ...)
 	    SV **svp;
 	    SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
 	    SV *freezer, *toaster, *bless;
-	    I32 purity, deepcopy, quotekeys;
+	    I32 purity, deepcopy, quotekeys, maxdepth = 0;
 	    char tmpbuf[1024];
 	    I32 gimme = GIMME;
 
 	    if (!SvROK(href)) {		/* call new to get an object first */
-		SV *valarray;
-		SV *namearray;
-
-		if (items == 3) {
-		    valarray = ST(1);
-		    namearray = ST(2);
-		}
-		else
-		    croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)");
+		if (items < 2)
+		    croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
 		
 		ENTER;
 		SAVETMPS;
 		
 		PUSHMARK(sp);
 		XPUSHs(href);
-		XPUSHs(sv_2mortal(newSVsv(valarray)));
-		XPUSHs(sv_2mortal(newSVsv(namearray)));
+		XPUSHs(sv_2mortal(newSVsv(ST(1))));
+		if (items >= 3)
+		    XPUSHs(sv_2mortal(newSVsv(ST(2))));
 		PUTBACK;
 		i = perl_call_method("new", G_SCALAR);
 		SPAGAIN;
@@ -747,6 +783,8 @@ Data_Dumper_Dumpxs(href, ...)
 		    quotekeys = SvTRUE(*svp);
 		if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
 		    bless = *svp;
+		if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
+		    maxdepth = SvIV(*svp);
 		postav = newAV();
 
 		if (todumpav)
@@ -795,13 +833,13 @@ Data_Dumper_Dumpxs(href, ...)
 			STRLEN nchars = 0;
 			sv_setpvn(name, "$", 1);
 			sv_catsv(name, varname);
-			(void) sprintf(tmpbuf, "%ld", i+1);
+			(void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
 			nchars = strlen(tmpbuf);
 			sv_catpvn(name, tmpbuf, nchars);
 		    }
 		    
 		    if (indent >= 2) {
-			SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3);
+			SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
 			newapad = newSVsv(apad);
 			sv_catsv(newapad, tmpsv);
 			SvREFCNT_dec(tmpsv);
@@ -809,10 +847,10 @@ Data_Dumper_Dumpxs(href, ...)
 		    else
 			newapad = apad;
 		    
-		    DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv,
+		    DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
 			    postav, &level, indent, pad, xpad, newapad, sep,
 			    freezer, toaster, purity, deepcopy, quotekeys,
-			    bless);
+			    bless, maxdepth);
 		    
 		    if (indent >= 2)
 			SvREFCNT_dec(newapad);

contrib/perl5/ext/Data/Dumper/Todo

@@ -8,12 +8,6 @@ The following functionality will be supported in the next few releases.
 
 =over 4
 
-=item $Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<NEWVAL>)
-
-Depth beyond which we don't venture into a structure.  Has no effect when
-C<Data::Dumper::Purity> is set.  (useful in debugger when we often don't
-want to see more than enough).
-
 =item  $Data::Dumper::Expdepth I<or> $I<OBJ>->Expdepth(I<NEWVAL>)
 
 Dump contents explicitly up to a certain depth and then use names for

contrib/perl5/ext/Devel/DProf/Changes

@@ -0,0 +1,176 @@
+1999 Jan 8
+
+ Ilya Zakharevich:
+  Newer perls: Add PERL_POLLUTE and dTHR.
+
+1998 Nov 10 
+This version of DProf should work with older Perls too, but to get
+full benefits some patches to 5.004_55 are needed.  Patches take effect 
+after new version of Perl is installed, and DProf recompiled.
+
+Without these patches the overhead of DProf is too big, thus the statistic
+may be very skewed.
+
+Oct 98:
+ Ilya Zakharevich:
+  DProf.xs
+    - correct defstash to PL_defstash
+    - nonlocal exits work
+  dprofpp
+    - nonlocal exits work
+  DProf.pm
+    - documentation updated
+  t/test6.*
+    - added
+
+Nov-Dec 97:
+ Jason E. Holt and Ilya Zakharevich:
+  DProf.xs
+    - will not wait until completion to write the output, size of buffer
+      regulated by PERL_DPROF_BUFFER, default 2**14 words;
+
+ Ilya Zakharevich:
+  dprofpp
+    - smarter in fixing garbled profiles;
+    - subtracts DProf output overhead, and suggested profiler overhead;
+    - new options -A, -R, -g subroutine, -S;
+    - handles 'goto' too;
+  DProf.xs
+    - 7x denser output (time separated from name, ids for subs);
+    - outputs report-write overhead;
+    - optional higher-resolution (currently OS/2 only, cannot grok VMS code);
+    - outputs suggested profiler overhead;
+    - handles 'goto' too;
+    - handles PERL_DPROF_TICKS (on OS/2, VMS may be easily modified too)
+
+Jun 14, 97 andreas koenig adds the compatibility notes to the README
+and lets the Makefile.PL die on $] < 5.004.
+
+Jun 06, 97 andreas koenig applies a patch by gurusamy sarathy because
+Dean is not available for comments at that time. The patch is available
+from CPAN in the authors/id/GSAR directory for inspection.
+
+Sep 30, 96 dmr
+  DProf.xs
+  - added Ilya's patches to fix "&bar as &bar(@_)" bug.  This also fixes
+    the coredumps people have seen when using this with 5.003+.
+  DProf.pm
+  - updated manpage
+  t/bug.t
+  - moved to test5
+  Makefile.PL
+  - remove special case for bug.t
+
+Jun 26, 96 dmr
+  dprofpp.PL
+  - smarter r.e. to find VERSION in Makefile (for MM5.27).
+  DProf.pm
+  - updated manpage
+  DProf.xs
+  - keep pid of profiled process, if process forks then only the
+    parent is profiled.  Added test4 for this.
+
+Mar 2, 96 dmr
+  README
+  - updated
+  dprofpp
+  - updated manpage, point to DProf for raw profile description.
+  DProf.pm
+  - update manpage, update raw profile description with XS_VERSION.
+  - update manpage for AUTOLOAD changes.
+  DProf.xs
+  - smart handling of &AUTOLOAD--looks in $AUTOLOAD for the sub name.
+      this fixes one problem with corrupt profiles.
+
+Feb 5, 96 dmr 
+  dprofpp
+  - updated manpage
+  - added -E/-I for exclusive/inclusive times
+  - added DPROFPP_OPTS -- lazily
+  - added -p/-Q for profile-then-analyze
+  - added version check
+  dprofpp.PL
+  - pull dprofpp's version id from the makefile
+  DProf.pm
+  - added version to bootstrap
+  - updated doc
+  - updated doc, DProf and -w are now friendly to each other
+  DProf.xs
+  - using savepv
+  - added Tim's patch to check for DBsub, avoids -MDevel::DProf coredump
+  - turn off warnings during newXS("DB::sub")
+  tests
+  - added Tim's patch to ignore Loader::import in results
+  - added Tim's patch to aid readability of test?.v output
+
+
+-- from those days when I kept a unique changelog for each module --
+
+# Devel::DProf - a Perl code profiler
+#  31oct95
+#
+# changes/bugs fixed since 5apr95 version -dmr:
+#  -added VMS patches from CharlesB.
+#  -now open ./tmon.out in BOOT.
+# changes/bugs fixed since 2apr95 version -dmr:
+#  -now mallocing an extra byte for the \0 :)
+# changes/bugs fixed since 01mar95 version -dmr:
+#  -stringified code ref is used for name of anonymous sub.
+#  -include stash name with stringified code ref.
+#  -use perl.c's DBsingle and DBsub.
+#  -now using croak() and warn().
+#  -print "timer is on" before turning timer on.
+#  -use safefree() instead of free().
+#  -rely on PM to provide full path name to tmon.out.
+#  -print errno if unable to write tmon.out.
+# changes/bugs fixed since 03feb95 version -dmr:
+#  -comments
+# changes/bugs fixed since 31dec94 version -dmr:
+#  -added patches from AndyD.
+#
+
+# Devel::DProf - a Perl code profiler
+#  31oct95
+#
+# changes/bugs fixed since 05apr95 version -dmr:
+#  - VMS-related prob; now let tmon.out name be handled in XS.
+# changes/bugs fixed since 01mar95 version -dmr:
+#  - record $pwd and build pathname for tmon.out
+# changes/bugs fixed since 03feb95 version -dmr:
+#  - fixed some doc bugs
+#  - added require 5.000
+#  - added -w note to bugs section of pod
+# changes/bugs fixed since 31dec94 version -dmr:
+#  - podified
+#
+
+
+# dprofpp - display perl profile data
+#  31oct95
+#
+# changes/bugs fixed since 7oct95 version -dmr:
+#  - PL'd
+# changes/bugs fixed since 5apr95 version -dmr:
+#  - touch up handling of exit timestamps.
+#  - suggests -F when exit timestamps are missing.
+#  - added compressed execution tree patches from AchimB, put under -t.
+#      now -z is the default action; user+system time.
+#  - doc changes.
+# changes/bugs fixed since 10feb95 version -dmr:
+#  - summary info is printed by default, opt_c is gone.
+#  - fixed some doc bugs
+#  - changed name to dprofpp
+# changes/bugs fixed since 03feb95 version -dmr:
+#  - fixed division by zero.
+#  - replace many local()s with my().
+#  - now prints user+system times by default
+#     now -u prints user time, -U prints unsorted.
+#  - fixed documentation
+#  - fixed output, to clarify that times are given in seconds.
+#  - can now fake exit timestamps if the profile is garbled.
+# changes/bugs fixed since 17jun94 version -dmr:
+#  - podified.
+#  - correct old documentation flaws.
+#  - added AndyD's patches.
+#
+ 

contrib/perl5/ext/Devel/DProf/DProf.pm

@@ -0,0 +1,196 @@
+require 5.005_64;
+
+=head1 NAME
+
+Devel::DProf - a Perl code profiler
+
+=head1 SYNOPSIS
+
+	perl5 -d:DProf test.pl
+
+=head1 DESCRIPTION
+
+The Devel::DProf package is a Perl code profiler.  This will collect
+information on the execution time of a Perl script and of the subs in that
+script.  This information can be used to determine which subroutines are
+using the most time and which subroutines are being called most often.  This
+information can also be used to create an execution graph of the script,
+showing subroutine relationships.
+
+To profile a Perl script run the perl interpreter with the B<-d> debugging
+switch.  The profiler uses the debugging hooks.  So to profile script
+F<test.pl> the following command should be used:
+
+	perl5 -d:DProf test.pl
+
+When the script terminates (or when the output buffer is filled) the
+profiler will dump the profile information to a file called
+F<tmon.out>.  A tool like I<dprofpp> can be used to interpret the
+information which is in that profile.  The following command will
+print the top 15 subroutines which used the most time:
+
+	dprofpp
+
+To print an execution graph of the subroutines in the script use the
+following command:
+
+	dprofpp -T
+
+Consult L<dprofpp> for other options.
+
+=head1 PROFILE FORMAT
+
+The old profile is a text file which looks like this:
+
+	#fOrTyTwO
+	$hz=100;
+	$XS_VERSION='DProf 19970606';
+	# All values are given in HZ
+	$rrun_utime=2; $rrun_stime=0; $rrun_rtime=7
+	PART2
+	+ 26 28 566822884 DynaLoader::import
+	- 26 28 566822884 DynaLoader::import
+	+ 27 28 566822885 main::bar
+	- 27 28 566822886 main::bar
+	+ 27 28 566822886 main::baz
+	+ 27 28 566822887 main::bar
+	- 27 28 566822888 main::bar
+	[....]
+
+The first line is the magic number.  The second line is the hertz value, or
+clock ticks, of the machine where the profile was collected.  The third line
+is the name and version identifier of the tool which created the profile.
+The fourth line is a comment.  The fifth line contains three variables
+holding the user time, system time, and realtime of the process while it was
+being profiled.  The sixth line indicates the beginning of the sub
+entry/exit profile section.
+
+The columns in B<PART2> are:
+
+	sub entry(+)/exit(-) mark
+	app's user time at sub entry/exit mark, in ticks
+	app's system time at sub entry/exit mark, in ticks
+	app's realtime at sub entry/exit mark, in ticks
+	fully-qualified sub name, when possible
+
+With newer perls another format is used, which may look like this:
+
+        #fOrTyTwO
+        $hz=10000;
+        $XS_VERSION='DProf 19971213';
+        # All values are given in HZ
+        $over_utime=5917; $over_stime=0; $over_rtime=5917;
+        $over_tests=10000;
+        $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284;
+        $total_marks=6;
+
+        PART2
+        @ 406 0 406
+        & 2 main bar
+        + 2
+        @ 456 0 456
+        - 2
+        @ 1 0 1
+        & 3 main baz
+        + 3
+        @ 141 0 141
+        + 2
+        @ 141 0 141
+        - 2
+        @ 1 0 1
+        & 4 main foo
+        + 4
+        @ 142 0 142
+        + & Devel::DProf::write
+        @ 5 0 5
+        - & Devel::DProf::write
+
+(with high value of $ENV{PERL_DPROF_TICKS}).  
+
+New C<$over_*> values show the measured overhead of making $over_tests
+calls to the profiler These values are used by the profiler to
+subtract the overhead from the runtimes.
+
+The lines starting with C<@> mark time passed from the previous C<@>
+line.  The lines starting with C<&> introduce new subroutine I<id> and
+show the package and the subroutine name of this id.  Lines starting
+with C<+>, C<-> and C<*> mark entering and exit of subroutines by
+I<id>s, and C<goto &subr>.
+
+The I<old-style> C<+>- and C<->-lines are used to mark the overhead
+related to writing to profiler-output file.
+
+=head1 AUTOLOAD
+
+When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the
+C<$AUTOLOAD> variable to find the real name of the sub being called.  See
+L<perlsub/"Autoloading">.
+
+=head1 ENVIRONMENT
+
+C<PERL_DPROF_BUFFER> sets size of output buffer in words.  Defaults to 2**14.
+
+C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where
+a replacement for times() is used.  Defaults to the value of C<HZ> macro.
+
+C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file.  If not set,
+defaults to tmon.out.
+
+=head1 BUGS
+
+Builtin functions cannot be measured by Devel::DProf.
+
+With a newer Perl DProf relies on the fact that the numeric slot of
+$DB::sub contains an address of a subroutine.  Excessive manipulation
+of this variable may overwrite this slot, as in
+
+  $DB::sub = 'current_sub';
+  ...
+  $addr = $DB::sub + 0;
+
+will set this numeric slot to numeric value of the string
+C<current_sub>, i.e., to C<0>.  This will cause a segfault on the exit
+from this subroutine.  Note that the first assignment above does not
+change the numeric slot (it will I<mark> it as invalid, but will not
+write over it).
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>.
+
+=head1 SEE ALSO
+
+L<perl>, L<dprofpp>, times(2)
+
+=cut
+
+# This sub is needed for calibration.
+package Devel::DProf;
+
+sub NONESUCH_noxs {
+	return $Devel::DProf::VERSION;
+}
+
+package DB;
+
+#
+# As of perl5.003_20, &DB::sub stub is not needed (some versions
+# even had problems if stub was redefined with XS version).
+#
+
+# disable DB single-stepping
+BEGIN { $single = 0; }
+
+# This sub is needed during startup.
+sub DB { 
+#	print "nonXS DBDB\n";
+}
+
+use XSLoader ();
+
+# Underscore to allow older Perls to access older version from CPAN
+$Devel::DProf::VERSION = '20000000.00_00';  # this version not authorized by
+				     # Dean Roehrich. See "Changes" file.
+
+XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION;
+
+1;

contrib/perl5/ext/Devel/DProf/DProf.xs

@@ -0,0 +1,689 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#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    */
+
+#ifdef DBG_SUB
+#  define DBG_SUB_NOTIFY(A,B) warn(A, B)
+#else
+#  define DBG_SUB_NOTIFY(A,B)  /* nothing */
+#endif
+
+#ifdef DBG_TIMER
+#  define DBG_TIMER_NOTIFY(A) warn(A)
+#else
+#  define DBG_TIMER_NOTIFY(A)  /* nothing */
+#endif
+
+/* HZ == clock ticks per second */
+#ifdef VMS
+#  define HZ ((I32)CLK_TCK)
+#  define DPROF_HZ HZ
+#  include <starlet.h>  /* prototype for sys$gettim() */
+#  define Times(ptr) (dprof_times(aTHX_ ptr))
+#else
+#  ifndef HZ
+#    ifdef CLK_TCK
+#      define HZ ((I32)CLK_TCK)
+#    else
+#      define HZ 60
+#    endif
+#  endif
+#  ifdef OS2				/* times() has significant overhead */
+#    define Times(ptr) (dprof_times(aTHX_ ptr))
+#    define INCL_DOSPROFILE
+#    define INCL_DOSERRORS
+#    include <os2.h>
+#    define toLongLong(arg) (*(long long*)&(arg))
+#    define DPROF_HZ g_dprof_ticks
+#  else
+#    define Times(ptr) (times(ptr))
+#    define DPROF_HZ HZ
+#  endif 
+#endif
+
+XS(XS_Devel__DProf_END);        /* used by prof_mark() */
+
+/* Everything is built on times(2).  See its manpage for a description
+ * of the timings.
+ */
+
+union prof_any {
+        clock_t tms_utime;  /* cpu time spent in user space */
+        clock_t tms_stime;  /* cpu time spent in system */
+        clock_t realtime;   /* elapsed real time, in ticks */
+        char *name;
+        U32 id;
+        opcode ptype;
+};
+
+typedef union prof_any PROFANY;
+
+typedef struct {
+    U32		dprof_ticks;
+    char*	out_file_name;	/* output file (defaults to tmon.out) */
+    PerlIO*	fp;		/* pointer to tmon.out file */
+    long	TIMES_LOCATION;	/* Where in the file to store the time totals */
+    int		SAVE_STACK;	/* How much data to buffer until end of run */
+    int		prof_pid;	/* pid of profiled process */
+    struct tms	prof_start;
+    struct tms	prof_end;
+    clock_t	rprof_start;	/* elapsed real time ticks */
+    clock_t	rprof_end;
+    clock_t	wprof_u;
+    clock_t	wprof_s;
+    clock_t	wprof_r;
+    clock_t	otms_utime;
+    clock_t	otms_stime;
+    clock_t	orealtime;
+    PROFANY*	profstack;
+    int		profstack_max;
+    int		profstack_ix;
+    HV*		cv_hash;
+    U32		total;
+    U32		lastid;
+    U32		default_perldb;
+    U32		depth;
+#ifdef OS2
+    ULONG	frequ;
+    long long	start_cnt;
+#endif
+#ifdef PERL_IMPLICIT_CONTEXT
+#  define register
+    pTHX;
+#  undef register
+#endif
+} prof_state_t;
+
+prof_state_t g_prof_state;
+
+#define g_dprof_ticks		g_prof_state.dprof_ticks
+#define g_out_file_name		g_prof_state.out_file_name
+#define g_fp			g_prof_state.fp
+#define g_TIMES_LOCATION	g_prof_state.TIMES_LOCATION
+#define g_SAVE_STACK		g_prof_state.SAVE_STACK
+#define g_prof_pid		g_prof_state.prof_pid
+#define g_prof_start		g_prof_state.prof_start
+#define g_prof_end		g_prof_state.prof_end
+#define g_rprof_start		g_prof_state.rprof_start
+#define g_rprof_end		g_prof_state.rprof_end
+#define g_wprof_u		g_prof_state.wprof_u
+#define g_wprof_s		g_prof_state.wprof_s
+#define g_wprof_r		g_prof_state.wprof_r
+#define g_otms_utime		g_prof_state.otms_utime
+#define g_otms_stime		g_prof_state.otms_stime
+#define g_orealtime		g_prof_state.orealtime
+#define g_profstack		g_prof_state.profstack
+#define g_profstack_max		g_prof_state.profstack_max
+#define g_profstack_ix		g_prof_state.profstack_ix
+#define g_cv_hash		g_prof_state.cv_hash
+#define g_total			g_prof_state.total
+#define g_lastid		g_prof_state.lastid
+#define g_default_perldb	g_prof_state.default_perldb
+#define g_depth			g_prof_state.depth
+#ifdef PERL_IMPLICIT_CONTEXT
+#  define g_THX			g_prof_state.aTHX
+#endif
+#ifdef OS2
+#  define g_frequ		g_prof_state.frequ
+#  define g_start_cnt		g_prof_state.start_cnt
+#endif
+
+clock_t
+dprof_times(pTHX_ struct tms *t)
+{
+#ifdef OS2
+    ULONG rc;
+    QWORD cnt;
+    STRLEN n_a;
+    
+    if (!g_frequ) {
+	if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
+	    croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
+	else
+	    g_frequ = g_frequ/DPROF_HZ;	/* count per tick */
+	if (CheckOSError(DosTmrQueryTime(&cnt)))
+	    croak("DosTmrQueryTime: %s",
+		  SvPV(perl_get_sv("!",TRUE), n_a));
+	g_start_cnt = toLongLong(cnt);
+    }
+
+    if (CheckOSError(DosTmrQueryTime(&cnt)))
+	    croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
+    t->tms_stime = 0;
+    return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
+#else		/* !OS2 */
+#  ifdef VMS
+    clock_t retval;
+    /* Get wall time and convert to 10 ms intervals to
+     * produce the return value dprof expects */
+#    if defined(__DECC) && defined (__ALPHA)
+#      include <ints.h>
+    uint64 vmstime;
+    _ckvmssts(sys$gettim(&vmstime));
+    vmstime /= 100000;
+    retval = vmstime & 0x7fffffff;
+#    else
+    /* (Older hw or ccs don't have an atomic 64-bit type, so we
+     * juggle 32-bit ints (and a float) to produce a time_t result
+     * with minimal loss of information.) */
+    long int vmstime[2],remainder,divisor = 100000;
+    _ckvmssts(sys$gettim((unsigned long int *)vmstime));
+    vmstime[1] &= 0x7fff;  /* prevent overflow in EDIV */
+    _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
+#    endif
+    /* Fill in the struct tms using the CRTL routine . . .*/
+    times((tbuffer_t *)t);
+    return (clock_t) retval;
+#  else		/* !VMS && !OS2 */
+    return times(t);
+#  endif
+#endif
+}
+
+static void
+prof_dumpa(pTHX_ opcode ptype, U32 id)
+{
+    if (ptype == OP_LEAVESUB) {
+	PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_ENTERSUB) {
+	PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_GOTO) {
+	PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_DIE) {
+	PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
+    }
+    else {
+	PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
+    }
+}   
+
+static void
+prof_dumps(pTHX_ U32 id, char *pname, char *gname)
+{
+    PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
+}   
+
+static void
+prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
+{
+    PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
+}   
+
+static void
+prof_dump_until(pTHX_ long ix)
+{
+    long base = 0;
+    struct tms t1, t2;
+    clock_t realtime1, realtime2;
+
+    realtime1 = Times(&t1);
+
+    while (base < ix) {
+	opcode ptype = g_profstack[base++].ptype;
+	if (ptype == OP_TIME) {
+	    long tms_utime = g_profstack[base++].tms_utime;
+	    long tms_stime = g_profstack[base++].tms_stime;
+	    long realtime = g_profstack[base++].realtime;
+
+	    prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
+	}
+	else if (ptype == OP_GV) {
+	    U32 id = g_profstack[base++].id;
+	    char *pname = g_profstack[base++].name;
+	    char *gname = g_profstack[base++].name;
+
+	    prof_dumps(aTHX_ id, pname, gname);
+	}
+	else {
+	    U32 id = g_profstack[base++].id;
+	    prof_dumpa(aTHX_ ptype, id);
+	}
+    }
+    PerlIO_flush(g_fp);
+    realtime2 = Times(&t2);
+    if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
+	|| t1.tms_stime != t2.tms_stime) {
+	g_wprof_r += realtime2 - realtime1;
+	g_wprof_u += t2.tms_utime - t1.tms_utime;
+	g_wprof_s += t2.tms_stime - t1.tms_stime;
+
+	PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
+	PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", 
+		      /* The (IV) casts are one possibility:
+		       * the Painfully Correct Way would be to
+		       * have Clock_t_f. */
+		      (IV)(t2.tms_utime - t1.tms_utime),
+		      (IV)(t2.tms_stime - t1.tms_stime), 
+		      (IV)(realtime2 - realtime1));
+	PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
+	g_otms_utime = t2.tms_utime;
+	g_otms_stime = t2.tms_stime;
+	g_orealtime = realtime2;
+	PerlIO_flush(g_fp);
+    }
+}
+
+static void
+prof_mark(pTHX_ opcode ptype)
+{
+    struct tms t;
+    clock_t realtime, rdelta, udelta, sdelta;
+    char *name, *pv;
+    char *hvname;
+    STRLEN len;
+    SV *sv;
+    U32 id;
+    SV *Sub = GvSV(PL_DBsub);	/* name of current sub */
+
+    if (g_SAVE_STACK) {
+	if (g_profstack_ix + 5 > g_profstack_max) {
+		g_profstack_max = g_profstack_max * 3 / 2;
+		Renew(g_profstack, g_profstack_max, PROFANY);
+	}
+    }
+
+    realtime = Times(&t);
+    rdelta = realtime - g_orealtime;
+    udelta = t.tms_utime - g_otms_utime;
+    sdelta = t.tms_stime - g_otms_stime;
+    if (rdelta || udelta || sdelta) {
+	if (g_SAVE_STACK) {
+	    g_profstack[g_profstack_ix++].ptype = OP_TIME;
+	    g_profstack[g_profstack_ix++].tms_utime = udelta;
+	    g_profstack[g_profstack_ix++].tms_stime = sdelta;
+	    g_profstack[g_profstack_ix++].realtime = rdelta;
+	}
+	else { /* Write it to disk now so's not to eat up core */
+	    if (g_prof_pid == (int)getpid()) {
+		prof_dumpt(aTHX_ udelta, sdelta, rdelta);
+		PerlIO_flush(g_fp);
+	    }
+	}
+	g_orealtime = realtime;
+	g_otms_stime = t.tms_stime;
+	g_otms_utime = t.tms_utime;
+    }
+
+    {
+	SV **svp;
+	char *gname, *pname;
+	CV *cv;
+
+	cv = INT2PTR(CV*,SvIVX(Sub));
+	svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
+	if (!SvOK(*svp)) {
+	    GV *gv = CvGV(cv);
+		
+	    sv_setiv(*svp, id = ++g_lastid);
+	    pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) 
+		     ? HvNAME(GvSTASH(gv)) 
+		     : "(null)");
+	    gname = GvNAME(gv);
+	    if (CvXSUB(cv) == XS_Devel__DProf_END)
+		return;
+	    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
+		g_profstack[g_profstack_ix++].ptype = OP_GV;
+		g_profstack[g_profstack_ix++].id = id;
+		g_profstack[g_profstack_ix++].name = pname;
+		g_profstack[g_profstack_ix++].name = gname;
+	    }
+	    else { /* Write it to disk now so's not to eat up core */
+		/* Only record the parent's info */
+		if (g_prof_pid == (int)getpid()) {
+		    prof_dumps(aTHX_ id, pname, gname);
+		    PerlIO_flush(g_fp);
+		}
+		else
+		    PL_perldb = 0;		/* Do not debug the kid. */
+	    }
+	}
+	else {
+	    id = SvIV(*svp);
+	}
+    }
+
+    g_total++;
+    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
+	g_profstack[g_profstack_ix++].ptype = ptype;
+	g_profstack[g_profstack_ix++].id = id;
+
+	/* Only record the parent's info */
+	if (g_SAVE_STACK < g_profstack_ix) {
+	    if (g_prof_pid == (int)getpid())
+		prof_dump_until(aTHX_ g_profstack_ix);
+	    else
+		PL_perldb = 0;		/* Do not debug the kid. */
+	    g_profstack_ix = 0;
+	}
+    }
+    else { /* Write it to disk now so's not to eat up core */
+
+	/* Only record the parent's info */
+	if (g_prof_pid == (int)getpid()) {
+	    prof_dumpa(aTHX_ ptype, id);
+	    PerlIO_flush(g_fp);
+	}
+	else
+	    PL_perldb = 0;		/* Do not debug the kid. */
+    }
+}
+
+#ifdef PL_NEEDED
+#  define defstash PL_defstash
+#endif
+
+/* Counts overhead of prof_mark and extra XS call. */
+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;
+    struct tms t1, t2;
+    clock_t realtime1, realtime2;
+    U32 ototal = g_total;
+    U32 ostack = g_SAVE_STACK;
+    U32 operldb = PL_perldb;
+
+    g_SAVE_STACK = 1000000;
+    realtime1 = Times(&t1);
+    
+    while (k < 2) {
+	i = 0;
+	    /* Disable debugging of perl_call_sv on second pass: */
+	PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
+	PL_perldb = g_default_perldb;
+	while (++i <= 100) {
+	    j = 0;
+	    g_profstack_ix = 0;		/* Do not let the stack grow */
+	    while (++j <= 100) {
+/* 		prof_mark(aTHX_ OP_ENTERSUB); */
+
+		PUSHMARK(PL_stack_sp);
+		perl_call_sv((SV*)cv, G_SCALAR);
+		PL_stack_sp--;
+/* 		prof_mark(aTHX_ OP_LEAVESUB); */
+	    }
+	}
+	PL_curstash = oldstash;
+	if (k == 0) {			/* Put time with debugging */
+	    realtime2 = Times(&t2);
+	    *r = realtime2 - realtime1;
+	    *u = t2.tms_utime - t1.tms_utime;
+	    *s = t2.tms_stime - t1.tms_stime;
+	}
+	else {				/* Subtract time without debug */
+	    realtime1 = Times(&t1);
+	    *r -= realtime1 - realtime2;
+	    *u -= t1.tms_utime - t2.tms_utime;
+	    *s -= t1.tms_stime - t2.tms_stime;	    
+	}
+	k++;
+    }
+    g_total = ototal;
+    g_SAVE_STACK = ostack;
+    PL_perldb = operldb;
+}
+
+static void
+prof_recordheader(pTHX)
+{
+    clock_t r, u, s;
+
+    /* g_fp is opened in the BOOT section */
+    PerlIO_printf(g_fp, "#fOrTyTwO\n");
+    PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
+    PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
+    PerlIO_printf(g_fp, "# All values are given in HZ\n");
+    test_time(aTHX_ &r, &u, &s);
+    PerlIO_printf(g_fp,
+		  "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
+		  /* The (IV) casts are one possibility:
+		   * the Painfully Correct Way would be to
+		   * have Clock_t_f. */
+		  (IV)u, (IV)s, (IV)r);
+    PerlIO_printf(g_fp, "$over_tests=10000;\n");
+
+    g_TIMES_LOCATION = PerlIO_tell(g_fp);
+
+    /* Pad with whitespace. */
+    /* This should be enough even for very large numbers. */
+    PerlIO_printf(g_fp, "%*s\n", 240 , "");
+
+    PerlIO_printf(g_fp, "\n");
+    PerlIO_printf(g_fp, "PART2\n");
+
+    PerlIO_flush(g_fp);
+}
+
+static void
+prof_record(pTHX)
+{
+    /* g_fp is opened in the BOOT section */
+
+    /* Now that we know the runtimes, fill them in at the recorded
+       location -JH */
+
+    clock_t r, u, s;
+
+    if (g_SAVE_STACK) {
+	prof_dump_until(aTHX_ g_profstack_ix);
+    }
+    PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
+    /* Write into reserved 240 bytes: */
+    PerlIO_printf(g_fp,
+		  "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
+		  /* The (IV) casts are one possibility:
+		   * the Painfully Correct Way would be to
+		   * have Clock_t_f. */
+		  (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
+		  (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
+		  (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
+    PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
+    
+    PerlIO_close(g_fp);
+}
+
+#define NONESUCH()
+
+static void
+check_depth(pTHX_ void *foo)
+{
+    U32 need_depth = (U32)foo;
+    if (need_depth != g_depth) {
+	if (need_depth > g_depth) {
+	    warn("garbled call depth when profiling");
+	}
+	else {
+	    I32 marks = g_depth - need_depth;
+
+/* 	    warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
+	    while (marks--) {
+		prof_mark(aTHX_ OP_DIE);
+	    }
+	    g_depth = need_depth;
+	}
+    }
+}
+
+#define for_real
+#ifdef for_real
+
+XS(XS_DB_sub)
+{
+    dXSARGS;
+    dORIGMARK;
+    SV *Sub = GvSV(PL_DBsub);		/* name of current sub */
+
+#ifdef PERL_IMPLICIT_CONTEXT
+    /* profile only the interpreter that loaded us */
+    if (g_THX != aTHX) {
+        PUSHMARK(ORIGMARK);
+        perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
+    }
+    else
+#endif
+    {
+	HV *oldstash = PL_curstash;
+
+        DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
+
+	SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
+	g_depth++;
+
+        prof_mark(aTHX_ OP_ENTERSUB);
+        PUSHMARK(ORIGMARK);
+        perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
+        prof_mark(aTHX_ OP_LEAVESUB);
+	g_depth--;
+    }
+    return;
+}
+
+XS(XS_DB_goto)
+{
+#ifdef PERL_IMPLICIT_CONTEXT
+    if (g_THX == aTHX)
+#endif
+    {
+        prof_mark(aTHX_ OP_GOTO);
+        return;
+    }
+}
+
+#endif /* for_real */
+
+#ifdef testing
+
+        MODULE = Devel::DProf           PACKAGE = DB
+
+        void
+        sub(...)
+	PPCODE:
+	    {
+                dORIGMARK;
+                HV *oldstash = PL_curstash;
+		SV *Sub = GvSV(PL_DBsub);	/* name of current sub */
+                /* SP -= items;  added by xsubpp */
+                DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
+
+                sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */
+
+                prof_mark(aTHX_ OP_ENTERSUB);
+                PUSHMARK(ORIGMARK);
+
+                PL_curstash = PL_debstash;	/* To disable debugging of perl_call_sv */
+                perl_call_sv(Sub, GIMME);
+                PL_curstash = oldstash;
+
+                prof_mark(aTHX_ OP_LEAVESUB);
+                SPAGAIN;
+                /* PUTBACK;  added by xsubpp */
+	    }
+
+#endif /* testing */
+
+MODULE = Devel::DProf           PACKAGE = Devel::DProf
+
+void
+END()
+PPCODE:
+    {
+        if (PL_DBsub) {
+	    /* maybe the process forked--we want only
+	     * the parent's profile.
+	     */
+	    if (
+#ifdef PERL_IMPLICIT_CONTEXT
+		g_THX == aTHX &&
+#endif
+		g_prof_pid == (int)getpid())
+	    {
+		g_rprof_end = Times(&g_prof_end);
+		DBG_TIMER_NOTIFY("Profiler timer is off.\n");
+		prof_record(aTHX);
+	    }
+	}
+    }
+
+void
+NONESUCH()
+
+BOOT:
+    {
+	g_TIMES_LOCATION = 42;
+	g_SAVE_STACK = 1<<14;
+    	g_profstack_max = 128;
+#ifdef PERL_IMPLICIT_CONTEXT
+	g_THX = aTHX;
+#endif
+
+        /* Before we go anywhere make sure we were invoked
+         * properly, else we'll dump core.
+         */
+        if (!PL_DBsub)
+	    croak("DProf: run perl with -d to use DProf.\n");
+
+        /* When we hook up the XS DB::sub we'll be redefining
+         * the DB::sub from the PM file.  Turn off warnings
+         * while we do this.
+         */
+        {
+	    I32 warn_tmp = PL_dowarn;
+	    PL_dowarn = 0;
+	    newXS("DB::sub", XS_DB_sub, file);
+	    newXS("DB::goto", XS_DB_goto, file);
+	    PL_dowarn = warn_tmp;
+        }
+
+        sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */
+
+	{
+	    char *buffer = getenv("PERL_DPROF_BUFFER");
+
+	    if (buffer) {
+		g_SAVE_STACK = atoi(buffer);
+	    }
+
+	    buffer = getenv("PERL_DPROF_TICKS");
+
+	    if (buffer) {
+		g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
+	    }
+	    else {
+		g_dprof_ticks = HZ;
+	    }
+
+	    buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
+	    g_out_file_name = savepv(buffer ? buffer : "tmon.out");
+	}
+
+        if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
+	    croak("DProf: unable to write '%s', errno = %d\n",
+		  g_out_file_name, errno);
+
+	g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
+	g_cv_hash = newHV();
+        g_prof_pid = (int)getpid();
+
+	New(0, g_profstack, g_profstack_max, PROFANY);
+        prof_recordheader(aTHX);
+        DBG_TIMER_NOTIFY("Profiler timer is on.\n");
+	g_orealtime = g_rprof_start = Times(&g_prof_start);
+	g_otms_utime = g_prof_start.tms_utime;
+	g_otms_stime = g_prof_start.tms_stime;
+	PL_perldb = g_default_perldb;
+    }

contrib/perl5/ext/Devel/DProf/Makefile.PL

@@ -0,0 +1,17 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+	NAME		=> 'Devel::DProf',
+	DISTNAME	=> 'DProf',
+	VERSION_FROM	=> 'DProf.pm',
+	clean		=> { 'FILES' => 'tmon.out t/tmon.out t/err'},
+	XSPROTOARG	=> '-noprototypes',
+	DEFINE		=> '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 '
+			  .'-DG_NODEBUG=32 -DPL_NEEDED',
+	dist		=> {
+			     COMPRESS => 'gzip -9f',
+			     SUFFIX => 'gz',
+			     DIST_DEFAULT => 'all tardist',
+			   },
+	MAN3PODS	=> {},
+);

contrib/perl5/ext/Devel/DProf/Todo

@@ -0,0 +1,13 @@
+- work on test suite.
+- localize the depth to guard against non-local exits.
+Current overhead (with PERLDBf_NONAME) wrt non-debugging run (estimates):
+	 8% extra call frame on DB::sub
+	 7% output of subroutine data
+	70% output of timing data (on OS/2, 35% with custom dprof_times())
+(Additional 17% are spent to write the output, but they are counted
+ and subtracted.)  
+
+With compensation for DProf overhead all but some odd 12% are subtracted ?!
+
+- Calculate overhead/count for XS calls and Perl calls separately.
+- goto &XSUB in pp_ctl.c;