mirror of
https://git.FreeBSD.org/src.git
synced 2024-10-20 02:38:43 +00:00
Vendor import of Perl 5.006
This commit is contained in:
parent
7c312e6b6a
commit
120a02d4f3
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/vendor/perl5/dist/; revision=62076
120
contrib/perl5/AUTHORS
Normal file
120
contrib/perl5/AUTHORS
Normal file
@ -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
|
44334
contrib/perl5/Changes
44334
contrib/perl5/Changes
File diff suppressed because it is too large
Load Diff
19336
contrib/perl5/Changes5.005
Normal file
19336
contrib/perl5/Changes5.005
Normal file
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
879
contrib/perl5/MAINTAIN
Normal file
879
contrib/perl5/MAINTAIN
Normal file
@ -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
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
|
@ -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.
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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"'
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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");
|
||||
|
@ -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
|
||||
|
@ -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 {
|
||||
|
118
contrib/perl5/Porting/p4desc
Executable file
118
contrib/perl5/Porting/p4desc
Executable file
@ -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;
|
||||
}
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 $
|
||||
|
@ -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
|
||||
|
47
contrib/perl5/README.Y2K
Normal file
47
contrib/perl5/README.Y2K
Normal file
@ -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.)
|
131
contrib/perl5/README.posix-bc
Normal file
131
contrib/perl5/README.posix-bc
Normal file
@ -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;
|
@ -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
|
||||
|
@ -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
|
||||
|
156
contrib/perl5/Todo-5.6
Normal file
156
contrib/perl5/Todo-5.6
Normal file
@ -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
|
@ -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 */
|
||||
|
@ -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);
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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) ;;
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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"
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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); \
|
||||
|
@ -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)
|
||||
|
@ -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 */
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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 */
|
||||
|
1092
contrib/perl5/dump.c
1092
contrib/perl5/dump.c
File diff suppressed because it is too large
Load Diff
@ -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);
|
||||
}
|
||||
}
|
||||
|
63
contrib/perl5/eg/cgi/dna_small_gif.uu
Normal file
63
contrib/perl5/eg/cgi/dna_small_gif.uu
Normal file
@ -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
|
@ -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),
|
||||
|
@ -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>
|
||||
|
13
contrib/perl5/eg/cgi/wilogo_gif.uu
Normal file
13
contrib/perl5/eg/cgi/wilogo_gif.uu
Normal file
@ -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
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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));
|
||||
}
|
||||
}
|
||||
|
@ -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) {
|
||||
|
@ -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 }
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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;
|
||||
|
@ -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 {
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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);
|
||||
|
@ -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);
|
||||
|
@ -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;
|
||||
}
|
||||
|
||||
|
42
contrib/perl5/ext/B/B/Stash.pm
Normal file
42
contrib/perl5/ext/B/B/Stash.pm
Normal file
@ -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;
|
@ -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 {
|
||||
|
@ -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;
|
||||
}
|
||||
|
@ -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
|
||||
#}
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
35
contrib/perl5/ext/B/defsubs_h.PL
Normal file
35
contrib/perl5/ext/B/defsubs_h.PL
Normal file
@ -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
|
||||
}
|
@ -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:
|
||||
|
@ -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
|
||||
|
@ -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));
|
||||
|
40
contrib/perl5/ext/ByteLoader/ByteLoader.pm
Normal file
40
contrib/perl5/ext/ByteLoader/ByteLoader.pm
Normal file
@ -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
|
79
contrib/perl5/ext/ByteLoader/ByteLoader.xs
Normal file
79
contrib/perl5/ext/ByteLoader/ByteLoader.xs
Normal file
@ -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);
|
9
contrib/perl5/ext/ByteLoader/Makefile.PL
Normal file
9
contrib/perl5/ext/ByteLoader/Makefile.PL
Normal file
@ -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)',
|
||||
);
|
161
contrib/perl5/ext/ByteLoader/bytecode.h
Normal file
161
contrib/perl5/ext/ByteLoader/bytecode.h
Normal file
@ -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)
|
899
contrib/perl5/ext/ByteLoader/byterun.c
Normal file
899
contrib/perl5/ext/ByteLoader/byterun.c
Normal file
@ -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 */
|
||||
}
|
||||
}
|
||||
}
|
161
contrib/perl5/ext/ByteLoader/byterun.h
Normal file
161
contrib/perl5/ext/ByteLoader/byterun.h
Normal file
@ -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
|
2
contrib/perl5/ext/ByteLoader/hints/sunos.pl
Normal file
2
contrib/perl5/ext/ByteLoader/hints/sunos.pl
Normal file
@ -0,0 +1,2 @@
|
||||
$self->{CCFLAGS} = $Config{ccflags} . ' -DNEED_FGETC_PROTOTYPE -DNEED_FREAD_PROTOTYPE';
|
||||
|
@ -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).
|
||||
|
@ -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
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
' ;
|
||||
}
|
||||
|
||||
|
@ -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",
|
||||
}
|
||||
},
|
||||
) ;
|
||||
|
2
contrib/perl5/ext/DB_File/hints/sco.pl
Normal file
2
contrib/perl5/ext/DB_File/hints/sco.pl
Normal file
@ -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\..' ;
|
@ -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
|
||||
|
||||
|
71
contrib/perl5/ext/DB_File/version.c
Normal file
71
contrib/perl5/ext/DB_File/version.c
Normal file
@ -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 */
|
||||
|
||||
}
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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);
|
||||
|
@ -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
|
||||
|
176
contrib/perl5/ext/Devel/DProf/Changes
Normal file
176
contrib/perl5/ext/Devel/DProf/Changes
Normal file
@ -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.
|
||||
#
|
||||
|
196
contrib/perl5/ext/Devel/DProf/DProf.pm
Normal file
196
contrib/perl5/ext/Devel/DProf/DProf.pm
Normal file
@ -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;
|
689
contrib/perl5/ext/Devel/DProf/DProf.xs
Normal file
689
contrib/perl5/ext/Devel/DProf/DProf.xs
Normal file
@ -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;
|
||||
}
|
17
contrib/perl5/ext/Devel/DProf/Makefile.PL
Normal file
17
contrib/perl5/ext/Devel/DProf/Makefile.PL
Normal file
@ -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 => {},
|
||||
);
|
13
contrib/perl5/ext/Devel/DProf/Todo
Normal file
13
contrib/perl5/ext/Devel/DProf/Todo
Normal file
@ -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;
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user