complex jhi,raphael
cpan k
cxux tom.horsley
-cygwin32 win32
+cygwin win32
dec_osf jhi,spider
dgux roderick
doc tchrist
----------------
-Version 5.005_58 Development release working toward 5.006
+Version 5.005_59 Development release working toward 5.006
+----------------
+
+____________________________________________________________________________
+[ 3849] By: gsar on 1999/08/01 19:50:20
+ Log: notes on PERL_IMPLICIT_CONTEXT (from a version by Nathan Torkington
+ <gnat@frii.com>)
+ Branch: perl
+ ! perl.h pod/perldelta.pod pod/perlguts.pod
+____________________________________________________________________________
+[ 3848] By: gsar on 1999/08/01 18:34:41
+ Log: fix defined(@foo) encarpments
+ Branch: perl
+ ! ext/B/B/C.pm lib/CGI.pm lib/Dumpvalue.pm lib/dumpvar.pl
+ ! pod/perltrap.pod
+____________________________________________________________________________
+[ 3847] By: jhi on 1999/08/01 17:17:07
+ Log: Undo #3790 and the patches that attempted to fix it
+ (#3837, #3838, #3845). The #3790 caused linkage failures
+ and/or core dumps in Solaris 2.6, Digital UNIX 4.0D, and
+ IRIX 6.5.
+ Branch: cfgperl
+ - ext/SDBM_File/hints/dec_osf.pl ext/SDBM_File/hints/solaris.pl
+ ! MANIFEST ext/SDBM_File/Makefile.PL lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MakeMaker.pm os2/OS2/REXX/Makefile.PL perl.h
+____________________________________________________________________________
+[ 3846] By: jhi on 1999/08/01 11:41:52
+ Log: Reading 64-bit decimal numbers was broken because
+ the NV was cast to an I32, not an IV.
+ Branch: cfgperl
+ ! toke.c
+____________________________________________________________________________
+[ 3845] By: jhi on 1999/08/01 11:00:24
+ Log: Solaris doesn't like PERL_MALLOC_OK in SDBM_File.
+ Branch: cfgperl
+ + ext/SDBM_File/hints/solaris.pl
+____________________________________________________________________________
+[ 3844] By: jhi on 1999/08/01 10:55:44
+ Log: Enable Solaris largefiles support only if -Duse64bits is used.
+ (Effectively removes #3311).
+ Branch: cfgperl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 3843] By: jhi on 1999/07/31 22:44:56
+ Log: Integer overflow iteration.
+ Branch: cfgperl
+ ! t/op/oct.t toke.c util.c
+____________________________________________________________________________
+[ 3842] By: jhi on 1999/07/31 22:11:03
+ Log: Remove a lot of unused regnode codes.
+ Noticed by Ilya.
+ Branch: cfgperl
+ ! regcomp.c regcomp.sym regexec.c regnodes.h
+____________________________________________________________________________
+[ 3841] By: jhi on 1999/07/31 21:53:54
+ Log: Make the use64bits and usethreads friendlier/braver;
+ they no more wimp out if the platform is unknown.
+ On use64bits if gcc used -DUSE_LONG_LONG is added
+ to the ccflags (this dependency on gcc caused a slightly weird
+ reordering of Configure, but things still seem to work.)
+ Branch: cfgperl
+ ! Configure README.threads config_h.SH
+ Branch: metaconfig
+ ! U/threads/usethreads.U
+ Branch: metaconfig/U/perl
+ ! use64bits.U
+____________________________________________________________________________
+[ 3840] By: jhi on 1999/07/31 20:26:22
+ Log: Hack the "integer overflow" code some more.
+ Branch: cfgperl
+ ! perl.h toke.c util.c
+____________________________________________________________________________
+[ 3839] By: jhi on 1999/07/31 20:22:00
+ Log: Test oct() at the 2^32-1 limit.
+ Branch: cfgperl
+ ! t/op/oct.t
+____________________________________________________________________________
+[ 3838] By: jhi on 1999/07/31 20:08:43
+ Log: Update MANIFEST for #3837.
+ Branch: cfgperl
+ ! MANIFEST
+____________________________________________________________________________
+[ 3837] By: jhi on 1999/07/31 20:02:40
+ Log: Digital UNIX 4.0D doesn't like perl malloc on sdbm
+ (a core dump with a corrput stack ensues).
+ Branch: cfgperl
+ + ext/SDBM_File/hints/dec_osf.pl
+____________________________________________________________________________
+[ 3836] By: jhi on 1999/07/29 21:09:01
+ Log: Allow for Configure -Ubincompat5005 override.
+ Branch: cfgperl
+ ! Configure config_h.SH
+ Branch: metaconfig/U/perl
+ ! bincompat5005.U
+____________________________________________________________________________
+[ 3835] By: jhi on 1999/07/29 21:04:02
+ Log: Make Configure support PERL_BINCOMPAT_5005.
+ Branch: cfgperl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH
+ Branch: metaconfig/U/perl
+ + bincompat5005.U
+____________________________________________________________________________
+[ 3834] By: jhi on 1999/07/29 19:25:35
+ Log: AIX tweak, need reported by David R. Fravor <dfavor@austin.ibm.com>
+ Branch: cfgperl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 3833] By: jhi on 1999/07/29 14:07:09
+ Log: Integrate with Sarathy. I overruled on perldelta
+ and perldiag.
+ Branch: cfgperl
+ !> README.win32 emacs/cperl-mode.el globals.c installperl
+ !> iperlsys.h makedef.pl perl.h pod/perldelta.pod
+ !> pod/perldiag.pod pod/perllexwarn.pod toke.c utils/perldoc.PL
+ !> win32/Makefile win32/bin/pl2bat.pl win32/makefile.mk
+ !> win32/perllib.c win32/win32.c
+____________________________________________________________________________
+[ 3832] By: jhi on 1999/07/29 14:02:50
+ Log: Repent and make overly large integerish
+ constants non-fatal. They are now promoted
+ to NVs, accompanied by an overflow warning that
+ is by default on.
+ Branch: cfgperl
+ ! embed.pl global.sym pod/perldelta.pod pod/perldiag.pod pp.c
+ ! proto.h t/op/oct.t t/pragma/warn/6default t/pragma/warn/util
+ ! toke.c util.c
+____________________________________________________________________________
+[ 3831] By: jhi on 1999/07/29 11:40:04
+ Log: AIX exhibits different error on failed system().
+ Slightly modified patch via private email from
+ David R. Favor <dfavor@austin.ibm.com>
+ Branch: cfgperl
+ ! t/op/exec.t
+____________________________________________________________________________
+[ 3830] By: gsar on 1999/07/29 07:46:11
+ Log: cperl-mode.el v4.19
+ Branch: perl
+ ! emacs/cperl-mode.el
+____________________________________________________________________________
+[ 3829] By: gsar on 1999/07/29 07:30:35
+ Log: From: jan.dubois@ibm.net (Jan Dubois)
+ Date: Wed, 28 Jul 1999 22:01:42 +0200
+ Message-ID: <37aa5f9b.12941448@smtp1.ibm.net>
+ Subject: [PATCH 5.005_58] win32/bin/pl2bat.pl doesn't work correctly
+ Branch: perl
+ ! win32/bin/pl2bat.pl
+____________________________________________________________________________
+[ 3828] By: gsar on 1999/07/29 07:19:27
+ Log: tweak previous change for multiple hits
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 3827] By: gsar on 1999/07/29 07:10:00
+ Log: band-aid for perldoc -t broken-ness (the new Pod::Text
+ really needs a pod2text() compatibility function)
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 3826] By: gsar on 1999/07/29 01:33:46
+ Log: minor tweaks to pods and toke.c comments
+ Branch: perl
+ ! pod/perldelta.pod pod/perldiag.pod pod/perllexwarn.pod toke.c
+____________________________________________________________________________
+[ 3825] By: gsar on 1999/07/29 00:12:52
+ Log: integrate cfgperl changes into mainline
+ Branch: perl
+ !> Configure Porting/Glossary Porting/config.sh Porting/config_H
+ !> README.threads config_h.SH ext/IO/lib/IO/Handle.pm
+ !> ext/IO/lib/IO/Socket.pm ext/IO/lib/IO/Socket/INET.pm
+ !> ext/POSIX/POSIX.xs lib/ExtUtils/Install.pm perl.h
+ !> pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ !> pod/perllexwarn.pod pod/perlre.pod pp.c pp_sys.c
+ !> t/lib/io_unix.t t/op/oct.t t/pragma/warn/6default
+ !> t/pragma/warn/util toke.c util.c
+____________________________________________________________________________
+[ 3824] By: jhi on 1999/07/28 21:15:04
+ Log: Tiny patch to go over #3820 (via private mail from Lincoln).
+ Branch: cfgperl
+ ! ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Socket.pm
+ ! ext/IO/lib/IO/Socket/INET.pm
+____________________________________________________________________________
+[ 3823] By: jhi on 1999/07/28 20:29:17
+ Log: Continue pack() doc honing.
+ Branch: cfgperl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 3822] By: jhi on 1999/07/28 20:17:37
+ Log: Enhance pack() doc.
+ Branch: cfgperl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 3821] By: jhi on 1999/07/28 18:34:50
+ Log: UNIX Domain Sockets are not implemented under QNX.
+
+ From: Norton Allen <allen@huarp.harvard.edu>
+ To: perl5-porters@perl.org
+ Subject: [ID 19990728.010] Patch:t/lib/io_unix.t _58 QNX
+ Date: Wed, 28 Jul 1999 14:07:16 -0400 (edt)
+ Message-Id: <199907281807.OAA13167@bottesini.harvard.edu>
+ Branch: cfgperl
+ ! t/lib/io_unix.t
+____________________________________________________________________________
+[ 3820] By: jhi on 1999/07/28 18:13:37
+ Log: IO::* enhancements.
+
+ 1) write() and syswrite() will now accept a single-argument
+ form of the call, for consistency with Perl's syswrite().
+ 2) You can create a TCP-based IO::Socket::INET without forcing
+ a connect attempt. This allows you to configure its options
+ (like making it non-blocking) and then call connect() manually.
+ 3) Fixed a bug that prevented the IO::Socket::protocol() accessor
+ from ever returning the correct value.
+
+ From: Lincoln Stein <lstein@formaggio.cshl.org>
+ To: Graham Barr <gbarr@pobox.com>
+ Cc: Lincoln Stein <lstein@cshl.org>, perl5-porters@perl.org
+ Subject: Re: patch for IO::*
+ Date: Wed, 28 Jul 1999 13:55:05 -0400 (EDT)
+ Message-ID: <14239.17401.330408.145295@formaggio.cshl.org>
+ Branch: cfgperl
+ ! ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Socket.pm
+ ! ext/IO/lib/IO/Socket/INET.pm
+____________________________________________________________________________
+[ 3819] By: gsar on 1999/07/28 18:08:06
+ Log: misc PERL_OBJECT tweaks; perlcore.dll is now perl56.dll
+ Branch: perl
+ ! README.win32 globals.c installperl iperlsys.h makedef.pl
+ ! perl.h win32/Makefile win32/makefile.mk win32/perllib.c
+ ! win32/win32.c
+____________________________________________________________________________
+[ 3818] By: jhi on 1999/07/28 17:48:16
+ Log: Need to add QNX to the list for DONT_DECLARE_STD.
+ (The elimination of use of the _() macro apparently triggered
+ an incompatability with a #define of atof)
+
+ From: Norton Allen <allen@huarp.harvard.edu>
+ To: perl5-porters@perl.org
+ Subject: [ID 19990728.008] Patch:perl.h _58 QNX
+ Date: Wed, 28 Jul 1999 13:06:23 -0400 (edt)
+ Message-Id: <199907281706.NAA07617@bottesini.harvard.edu>
+ Branch: cfgperl
+ ! perl.h
+____________________________________________________________________________
+[ 3817] By: jhi on 1999/07/28 17:46:30
+ Log: Need to add some more conditions to deal with the case
+ defined(HAS_GETSPNAM) && ! defined(HAS_GETSPENT)
+ which is true for QNX4.
+ From: Norton Allen <allen@huarp.harvard.edu>
+ To: perl5-porters@perl.org
+ Subject: [ID 19990728.009] Patch:pp_sys.c _58 QNX
+ Date: Wed, 28 Jul 1999 13:08:42 -0400 (edt)
+ Message-Id: <199907281708.NAA07947@bottesini.harvard.edu>
+ Branch: cfgperl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 3816] By: jhi on 1999/07/28 17:43:40
+ Log: The QNX shell needs a couple more semicolons.
+
+ From: Norton Allen <allen@huarp.harvard.edu>
+ To: perl5-porters@perl.org
+ Subject: [ID 19990728.007] Patch:Configure _58 QNX
+ Date: Wed, 28 Jul 1999 13:03:00 -0400 (edt)
+ Message-Id: <199907281703.NAA07363@bottesini.harvard.edu>
+
+ plus silence metalint moanings on vendorprefix.
+ Branch: cfgperl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH
+____________________________________________________________________________
+[ 3815] By: jhi on 1999/07/28 17:31:11
+ Log: Silence metalint on vendorprefix.U.
+ Branch: metaconfig
+ ! U/installdirs/vendorprefix.U
+____________________________________________________________________________
+[ 3814] By: jhi on 1999/07/28 17:13:29
+ Log: QNX shell needs more semicolons.
+ Branch: metaconfig/U/perl
+ ! Extensions.U
+____________________________________________________________________________
+[ 3813] By: jhi on 1999/07/28 17:05:08
+ Log: Integrate with Sarathy.
+ Branch: cfgperl
+ !> lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 3812] By: jhi on 1999/07/28 16:20:17
+ Log: Fix a typo, un-shout, and reformat the installation output.
+ Branch: cfgperl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 3811] By: gsar on 1999/07/28 15:41:11
+ Log: fix typo that caused INSTALLPRIVLIB to have doubled 'perl5'
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 3810] By: jhi on 1999/07/28 13:55:57
+ Log: Talk more about subsecond things in perlfunc.
+ (Yes, redundant with perlfaq8.)
+ Branch: cfgperl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 3809] By: jhi on 1999/07/28 07:23:48
+ Log: Integrate with Sarathy.
+ Branch: cfgperl
+ !> configpm hints/freebsd.sh lib/Pod/Html.pm perl.h t/op/grent.t
+ !> t/op/pwent.t
+____________________________________________________________________________
+[ 3808] By: jhi on 1999/07/28 07:23:03
+ Log: Document toke.c.
+ From: Nathan Torkington <gnat@frii.com>
+ To: perl5-porters@perl.org
+ Subject: Re: toke.c patch, work in progress
+ Date: Tue, 27 Jul 1999 23:02:09 -0600 (MDT)
+ Message-ID: <14238.36561.979473.667842@localhost.frii.com>
+ Branch: cfgperl
+ ! toke.c
+____________________________________________________________________________
+[ 3807] By: jhi on 1999/07/28 07:10:56
+ Log: perlre clarification.
+
+ From: Ian Phillipps <ian@dial.pipex.com>
+ To: Perl 5 Porters <perl5-porters@perl.org>
+ Subject: [PATCH 5.00557] Add definite article to perlre.pod
+ Date: Tue, 27 Jul 1999 10:46:29 +0100
+ Message-ID: <19990727104629.A10074@homer.diplex.co.uk>
+ Branch: cfgperl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 3806] By: gsar on 1999/07/28 07:07:46
+ Log: fix the perl -V breakage
+
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ To: Jarkko Hietaniemi <jhi@iki.fi>
+ Cc: "John L. Allen" <allen@grumman.com>, perl5-porters@perl.org,
+ gsar@activestate.com
+ Subject: Re: Follow up to: _58 on AIX 431
+ Date: Tue, 27 Jul 1999 17:42:00 -0400
+ Message-ID: <19990727174200.A12775@monk.mps.ohio-state.edu>
+ Branch: perl
+ ! configpm
+____________________________________________________________________________
+[ 3805] By: gsar on 1999/07/28 07:03:34
+ Log: avoid warning (from Doug MacEachern)
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 3804] By: gsar on 1999/07/28 06:59:30
+ Log: Pod::Html tweak
+
+ From: jan.dubois@ibm.net (Jan Dubois)
+ To: perl5-porters@perl.org
+ Subject: [PATCH 5.005_58] pod2html: Missing chunk for VMS filenames
+ Date: Tue, 27 Jul 1999 22:14:12 +0200
+ Message-ID: <37a50af0.46171380@smtp1.ibm.net>
+ Branch: perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 3803] By: gsar on 1999/07/28 06:56:38
+ Log: freebsd hints update
+
+ From: Anton Berezin <tobez@plab.ku.dk>
+ To: perl5-porters@perl.org
+ Subject: [ID 19990727.034] Not OK: perl 5.00558 on i386-freebsd-thread4.0-current (UNINSTALLED)
+ Date: Tue, 27 Jul 1999 20:29:39 +0200 (CEST)
+ Message-Id: <199907271829.UAA62861@lion.plab.ku.dk>
+ Branch: perl
+ ! hints/freebsd.sh
+____________________________________________________________________________
+[ 3802] By: gsar on 1999/07/28 06:51:32
+ Log: cosmetic testsuite patch
+
+ From: Graham Barr <gbarr@ti.com>
+ To: Perl5 Porters <perl5-porters@perl.org>
+ Subject: 5.005_58 build
+ Date: Tue, 27 Jul 1999 08:09:25 -0500
+ Message-ID: <19990727080925.F4683@dal.asp.ti.com>
+ Branch: perl
+ ! t/op/grent.t t/op/pwent.t
+____________________________________________________________________________
+[ 3801] By: jhi on 1999/07/27 13:49:39
+ Log: Minuscule cleanup of the integer overflow patch.
+ Branch: cfgperl
+ ! util.c
+____________________________________________________________________________
+[ 3800] By: jhi on 1999/07/27 13:37:23
+ Log: Test hex('x...').
+ Branch: cfgperl
+ ! t/op/oct.t
+____________________________________________________________________________
+[ 3799] By: jhi on 1999/07/27 12:45:45
+ Log: Integrate with Sarathy (5.005_58).
+ Branch: cfgperl
+ - ext/B/byteperl.c
+ !> Changes MANIFEST Porting/makerel configpm embed.h embed.pl
+ !> ext/Devel/DProf/DProf.xs ext/POSIX/POSIX.pm
+ !> ext/SDBM_File/Makefile.PL lib/AutoLoader.pm
+ !> lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+ !> lib/Pod/Parser.pm lib/SelfLoader.pm os2/OS2/REXX/Makefile.PL
+ !> perl.h pod/perldelta.pod pod/perlfaq9.pod pod/perlhist.pod
+ !> win32/bin/pl2bat.pl win32/config_H.bc win32/config_H.gc
+ !> win32/config_H.vc
+____________________________________________________________________________
+[ 3798] By: jhi on 1999/07/27 12:42:43
+ Log: Integer constants (0x, 0[0-7], 0b) now overflow fatally,
+ they used to be just optional lexical warnings.
+ Also, with warnings turned on, constants > 2**32-1
+ trigger a non-portability warning.
+ Branch: cfgperl
+ ! pod/perldelta.pod pod/perldiag.pod pod/perllexwarn.pod pp.c
+ ! t/op/oct.t t/pragma/warn/6default t/pragma/warn/util toke.c
+ ! util.c
+____________________________________________________________________________
+[ 3797] By: gsar on 1999/07/27 10:48:27
+ Log: here lies 5.005_58
+ Branch: perl
+ - ext/B/byteperl.c
+ ! Changes MANIFEST Porting/makerel pod/perldelta.pod
+ ! pod/perlfaq9.pod pod/perlhist.pod
+
+----------------
+Version 5.005_58
----------------
____________________________________________________________________________
# define dEXTCONST const
# endif
# else
-# if defined(CYGWIN32) && defined(USEIMPORTLIB)
+# if defined(CYGWIN) && defined(USEIMPORTLIB)
# define EXT extern __declspec(dllimport)
# define dEXT
# define EXTCONST extern __declspec(dllimport) const
To build a shared libperl, the environment variable controlling shared
library search (LD_LIBRARY_PATH in most systems, DYLD_LIBRARY_PATH for
NeXTSTEP/OPENSTEP/Rhapsody, LIBRARY_PATH for BeOS, SHLIB_PATH for
-HP-UX, LIBPATH for AIX, PATH for cygwin32) must be set up to include
+HP-UX, LIBPATH for AIX, PATH for cygwin) must be set up to include
the Perl build directory because that's where the shared libperl will
be created. Configure arranges makefile to have the correct shared
library search settings.
README
README.amiga amiga
README.beos beos
-README.cygwin32 cygwin32
+README.cygwin cygwin
README.dos dos
README.hpux hpux
README.lexwarn lexwarn
configure.gnu
cop.h
cv.h
-cygwin32/* cygwin32
+cygwin/* cygwin
deb.c
djgpp/* dos
doio.c
ext/DynaLoader/Makefile.PL
ext/DynaLoader/README
ext/DynaLoader/dl_aix.xs aix
-ext/DynaLoader/dl_cygwin32.xs cygwin32
+ext/DynaLoader/dl_cygwin.xs cygwin
ext/DynaLoader/dl_dld.xs rsanders
ext/DynaLoader/dl_dlopen.xs timb
ext/DynaLoader/dl_hpux.xs hpux
hints/bsdos.sh bsdos
hints/convexos.sh
hints/cxux.sh cxux
-hints/cygwin32.sh cygwin32x
+hints/cygwin.sh cygwinx
hints/dcosx.sh
hints/dec_osf.sh dec_osf
hints/dgux.sh dgux
README.amiga Notes about AmigaOS port
README.apollo Notes about Apollo DomainOS port
README.beos Notes about BeOS port
-README.cygwin32 Notes about Cygwin32 port
+README.cygwin Notes about Cygwin port
README.dos Notes about dos/djgpp port
README.epoc Notes about EPOC port
README.hpux Notes about HP-UX port
configure.gnu Crude emulation of GNU configure
cop.h Control operator header
cv.h Code value header
-cygwin32/Makefile.SHs Shared library generation for Cygwin32 port
-cygwin32/ld2.in ld wrapper template for Cygwin32 port
-cygwin32/perlld.in dll generator template for Cygwin32 port
-cygwin32/build-instructions.charles-wilson Cygwin32 porters notes
-cygwin32/build-instructions.READFIRST Cygwin32 porters notes
-cygwin32/build-instructions.steven-morlock2 Cygwin32 porters notes
-cygwin32/build-instructions.sebastien-barre Cygwin32 porters notes
-cygwin32/build-instructions.steven-morlock Cygwin32 porters notes
+cygwin/Makefile.SHs Shared library generation for Cygwin port
+cygwin/ld2.in ld wrapper template for Cygwin port
+cygwin/perlld.in dll generator template for Cygwin port
deb.c Debugging routines
djgpp/config.over DOS/DJGPP port
djgpp/configure.bat DOS/DJGPP port
ext/DynaLoader/README Dynamic Loader notes and intro
ext/DynaLoader/dl_aix.xs AIX implementation
ext/DynaLoader/dl_beos.xs BeOS implementation
-ext/DynaLoader/dl_cygwin32.xs Cygwin32 implementation
+ext/DynaLoader/dl_cygwin.xs Cygwin implementation
ext/DynaLoader/dl_dld.xs GNU dld style implementation
ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation
ext/DynaLoader/dl_hpux.xs HP-UX implementation
hints/bsdos.sh Hints for named architecture
hints/convexos.sh Hints for named architecture
hints/cxux.sh Hints for named architecture
-hints/cygwin32.sh Hints for named architecture
+hints/cygwin.sh Hints for named architecture
hints/dcosx.sh Hints for named architecture
hints/dec_osf.sh Hints for named architecture
hints/dgux.sh Hints for named architecture
# Load up custom Makefile.SH fragment for shared loading and executables:
case "$osname" in
cygwin*)
- Makefile_s="cygwin32/Makefile.SHs"
+ Makefile_s="cygwin/Makefile.SHs"
;;
*)
Makefile_s="$osname/Makefile.SHs"
!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
$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
=head1 NAME
-README.cygwin32 - notes about porting Perl to Cygwin32
+README.cygwin - notes about porting Perl to Cygwin
=head1 SYNOPSIS
=over
-=item Cygwin32
+=item Cygwin
The Cygwin tools are ports of the popular GNU development tools for
Windows NT, 95, and 98. They run thanks to the Cygwin library which
=item libperl.dll
-These instructions and the default cygwin32 hints build a shared
+These instructions and the default cygwin hints build a shared
libperl.dll Perl library and enables dynamically loaded extensions.
=back
=head2 Configure
-Check hints/cygwin32.sh for any system specific settings. In
+Check hints/cygwin.sh for any system specific settings. In
particular change libpth to point to the correct location of
...../i586-cygwin32/lib.
=end text
-select "cygwin32".
+select "cygwin".
Do not use the malloc that comes with perl--using the perl malloc
collides with some cygwin startup routines.
"Configure".
You may also want to look at two other options for building
-a perl that will work on Windows NT: the README.cygwin32 and
+a perl that will work on Windows NT: the README.cygwin and
README.os2 files, which each give a different set of rules to build
a Perl that will work on Win32 platforms. Those two methods will
probably enable you to build a more Unix-compatible perl, but you
#define ST(off) PL_stack_base[ax + (off)]
-#if defined(CYGWIN32) && defined(USE_DYNAMIC_LOADING)
+#if defined(CYGWIN) && defined(USE_DYNAMIC_LOADING)
# define XS(name) __declspec(dllexport) void name(pTHXo_ CV* cv)
#else
# define XS(name) void name(pTHXo_ CV* cv)
$spitshell >>Makefile <<!GROK!THIS!
# shell script feeding perlld to decent perl
-ld2: $& Makefile perlld ${src}/cygwin32/ld2.in
+ld2: $& Makefile perlld ${src}/cygwin/ld2.in
@echo "extracting ld2 (with variable substitutions)"
- @$sed s,@buildpath@,$addtopath,g <${src}/cygwin32/ld2.in >ld2
+ @$sed s,@buildpath@,$addtopath,g <${src}/cygwin/ld2.in >ld2
@echo "installing ld2 into $installbin"
# install is included in Cygwin distributions, and we make a note of th
-# requirement in the README.cygwin32 file. However, let's give them
+# requirement in the README.cygwin file. However, let's give them
# a warning.
@if test -n "`type $1 2>&1 | sed -n -e '/'$1'$/p'`" ; then \
install -c -m 755 ld2 ${installbin}/ld2 ; \
else \
echo "*************************************************" ; \
- echo "Oh, no! You didn't read the README.cygwin32" ; \
+ echo "Oh, no! You didn't read the README.cygwin" ; \
echo "file, which stated that \"install\" was required." ; \
echo "Make will probably fail in a few more steps." ; \
echo "When it does, copy \"ld2\" to a directory in" ; \
DEF_EXT = .def
EXP_EXT = .exp
-perlld: $& Makefile ${src}/cygwin32/perlld.in
+perlld: $& Makefile ${src}/cygwin/perlld.in
@echo "extracting perlld (with variable substitutions)"
@$sed -e s,@CC@,\${CC}, -e s,@DLLWRAP@,\${DLLWRAP},g \\
-e s,@WRAPDRIVER@,\${WRAPDRIVER},g -e s,@DLLTOOL@,\${DLLTOOL},g \\
-e s,@AS@,\${AS},g -e s,@EXPORT_ALL@,\${EXPORT_ALL},g \\
-e s,@DEF_EXT@,\${DEF_EXT},g -e s,@EXP_EXT@,\${EXP_EXT},g \\
-e s,@LIB_EXT@,\${LIB_EXT},g \\
- ${src}/cygwin32/perlld.in >perlld
+ ${src}/cygwin/perlld.in >perlld
!GROK!THIS!
+++ /dev/null
-This document is obsolete. Refer to README.cygwin32. However, if you want
-to build a statically linked perl binary, then you applied the wrong patch.
-You want perl5.005_03-static-patch, which will build "Pre-release 1"
-according to the nomenclature in README.cygwin32.
-
-The perl source distribution is available from
- http://www.cpan.org/src/index.html
-
-For the easiest build of perl under Cygwin, do the following:
-
-(1) read
- *(a) README.cygwin from the perl source distribution
- *(b) read build-instructions.charles-wilson
- (b) read build-instructions.sebastien-barre
- (c) read build-instructions.steven-morlock
- (d) read build-instructions.steven-morlock2
- (e) read build-instructions.teun-burgers
-
-(2) prepare the source
- (a) unpack perl source distribution in /usr/local/src
- (b) copy perl5.005_03-static-patch into /usr/local/src/perl5.005_03/
- (c) cd /usr/local/src/perl5.005_03
- (d) chmod -R +w *
- (e) patch -p1 < perl5.005_03-static-patch
-
-(3) get ready to build
- (a) cp cygwin32/cw32imp.h .
- (b) cp cygwin32/gcc2 .
- (c) cp cygwin32/ld2 .
- (d) cp cygwin32/perlgcc .
- (e) cp cygwin32/perlld .
- (f) cp gcc2 /usr/local/bin
- (g) cp ld2 /usr/local/bin
- (h) cp hints/cygwin32.sh config.sh
- (i) sh Configure -d
- (automatically does a make depend)
-
-(4) build and install
- (b) make
- (c) make test
- (d) make install
-
-To customize, look around in the patchfile or ignore the patch and
-follow the build-instructions.* directly. If you want to edit the paths
-in the patchfile to reflect your system, search for "/usr/" within the
-patchfile.
-
-* MUST read.
-
+++ /dev/null
-This document is obsolete. Refer to README.cygwin32.
-
-DATE: 13 May 99
-
-Here are a few hints for building perl with cygwin:
-
-(1) There have been some problems compiling with the default compiler
-installed with cygwin-b20.1. If you're reading this file, then you've
-already applied perl5.005_03-static-patch. Some of the patches in
-perl5.005_03-static-patch attempt to correct these problems, but it
-would probably be a good idea to upgrade your compiler to egcs-1.1.1
-(or better) from Mumit Khan's website --
-http://www.xraylith.wisc.edu/~khan/software/gnu-win32/
-
-(2) To avoid some failures when doing a "make test", use CYGWIN=ntea
-while testing. However, see the Cygwin FAQ concerning the use of ntea
-with FAT partitions. The tests that fail are those that deal with file
-ownership and access.
-
-(3) Perl should build without trouble under text mounts or binary
-mounts. However, some tests ("make test") may fail when using text
-mounts. The tests that fail are those that involve using tie() to
-attach a hashtable variable to a file.
-
-(4) There have been a few hints that some tests may also fail depending
-on whether you're building, testing, and/or installing as a normal
-user, or as a member of the Administrators group (NT only). However,
-we're not sure about this one yet.
-
-(5) When compiling static modules for perl, don't mix modules compiled
-under text mounts and modules compiled under binary mounts.
-
-(6) The sourcefiles in the tarball extract as "-r--r--r--" by default.
-This may or may not cause problems, depending on your setup. To be safe,
-I executed "chmod -R +w *".
-
-(7) To make life easier, you should download install-cygwin-b20.sh from
-ftp://ftp.franken.de/pub/win32/develop/gnuwin32/cygwin/
- porters/Humblet_Pierre_A/
-and use it as your install "executable." Just follow the instructions
-that are embedded as comments in that shell script.
-
-(8) There were a number of failed operations when installing. These
-occurred in two cases: first, when trying to create man pages whose
-names had ":" in them -- i.e. man/man3/Tie::Array.3, and second,
-when copying the pod files from SRCDIR/pod/*.pod to
-/usr/local/lib/perl5/perl5.00503/pod/. I'm not sure why, but I just
-completed that operation by hand afterwards.
-
-RESULTS:
-****************************************************
-
-I built and tested as a normal user (not Administrator and not a member
-of the Administrators group). However, I had to
-'chown -R cwilson /usr/local/*' in order to avoid various NTisms.
-(Previously, my /usr/local tree was owned by the Administrators GROUP,
-and since I was building as a normal user, I couldn't install
-completely. Why didn't I just switch to the Administrator account to
-install? Well, that has its own share of problems: basically, the
-Administrator couldn't write to those directories either - they were
-owned by the Admin group, not the Admin user. And the permissions were
--rw-r--r-- (or -r--r--r--), so group members weren't allowed write
-access. Blame MS.)
-
-RESULTS: make test
-------------------
-
-Failed 4 test scripts out of 190, 92.63% okay.
-u=2.143 s=4.897 cu=120.165 cs=159.697 scripts=180 tests=6430
-
-RESULTS: ./perl harness
------------------------
-most things were "foo/bar............ok" with the following exceptions:
-
-
-base/rs.............ok, 4/14 subtests skipped
-op/groups...........skipping test on this platform
-op/magic............FAILED test 23
- Failed 1/35 tests, 97.14% okay (-4 skipped tests: 30 okay,
-85.71%)
-op/stat.............ls: /dev: No such file or directory
-FAILED tests 4, 35
- Failed 2/58 tests, 96.55% okay
-op/taint............FAILED tests 1, 3, 31
- Failed 3/149 tests, 97.99% okay (-12 skipped tests: 134 okay,
-89.93%)
- (Also got the following popup message four times - "The dynamic
-link
- library cygwin1.dll could not be found in the specified path
- F:\cygnus\cygwin-b20\usr\local\src\perl5.005_03\t;.;
- E:\WINNT\System32;E:\WINNT\system;E:\WINNT;..")
-lib/findbin.........FAILED test 1
- Failed 1/1 tests, 0.00% okay
-lib/db-btree........skipping test on this platform
-lib/db-hash.........skipping test on this platform
-lib/db-recno........skipping test on this platform
-lib/gdbm............skipping test on this platform
-lib/ipc_sysv........skipping test on this platform
-lib/ndbm............skipping test on this platform
-lib/odbm............skipping test on this platform
-lib/posix...........skipping test on this platform
-lib/thread..........skipping test on this platform
-
-Failed Test Status Wstat Total Fail Failed List of failed
-------------------------------------------------------------------------
--------
-lib/findbin.t 1 1 100.00% 1
-op/magic.t 35 1 2.86% 23
-op/stat.t 58 2 3.45% 4, 35
-op/taint.t 149 3 2.01% 1, 3, 31
-10 tests skipped, plus 20 subtests skipped.
-Failed 4/190 test scripts, 97.89% okay. 7/6430 subtests failed, 99.89%
-okay.
+++ /dev/null
-This document is obsolete. Refer to README.cygwin32.
-
-perl5.005_03-static-patch implements all of the
-suggestions below. Results in a static build, 93.85%
-successful test on NT.
-
-
-**********************************
-Subject: Re: Compiling Perl under b20.1
- Date: Fri, 05 Mar 1999 16:41:52 +0100
- From: Sebastien Barre <Sebastien.Barre@utc.fr>
- To: Allan Peda <allan@interport.net>
- CC: Cygwin Mailing List <cygwin@sourceware.cygnus.com>
-
-At 22:04 04/03/99 -0500, Allan Peda wrote:
-
->Has there been much success with this? I've done it with MSVC + nmake,
->but I'd get more of a thrill using cygwin.
-
-I did (5.005_002 static build, 91.4% successfull test).
-
-As many people from this list helped me, I'd glad to offer the same.
-
-Basically,
-
-*) Read the README.cywin32
-
-*) Edit the hints/cygwin32.sh file to reflect your paths.
-
-Here are also a couple of settings I found useful when performing
-automatic
-build (copy hints/cygwin32.sh to config.sh, and do sh Configure -d)
-
-usedl='n'
-i_stdarg='define'
-i_varargs='undef'
-osname='cygwin_nt-4.0'
-osvers='20.1'
-archname='cygwin32'
-signal_t='int'
-d_voidsig='define'
-i_sysselct='undef'
-signal_t='void'
-
-*) Browse Usenet archives (DejaNews), and find "HOWTO: Builiding Perl
-under Win95/98 using Cygwin32 "
-Steven Morlock <newspost@morlock.net>
-1998/12/21
-comp.lang.perl.misc
-
-*) Then apply this patch (Thanks to Todd Goodman)
-
-This is my change in Cwd.pm:
---- cwd.pm Fri Feb 26 21:52:42 1999
-+++ cwd.pm.orig Fri Jan 22 20:49:54 1999
-@@ -208,8 +208,6 @@
- my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
-- return cwd() if ( $^O =~ /cygwin/ );
--
- unless (@cst = stat( $start ))
- {
-
-And tell me (email) if it fails.
-
-______________________________________________________________
-Sebastien Barre http://www.hds.utc.fr/~barre/
-
---
-Want to unsubscribe from this list?
-Send a message to cygwin-unsubscribe@sourceware.cygnus.com
-
-
+++ /dev/null
-This document is obsolete. Refer to README.cygwin32.
-
-From comp.lang.perl.misc. perl5.005_03-static-patch
-implements most of the suggestions below. My observations during the
-build process are commented within the body of Mr. Morlock's message,
-set off by ******CSW******
-
-
-**************************************
-Subject: HOWTO: Builiding Perl under Win95/98 using Cygwin32
-Author: Steven Morlock <newspost@morlock.net>
-Date: 1998/12/21
-Forum: comp.lang.perl.misc
-
-If you have a desire to build Perl under Windows 95/98 using Cygnus'
-Cygwin Win32 ports of the GNU development tools (Cygwin32) you might
-get something out of my experience of building it.
-
-An advantage of the versions Perl built with Cygwin32 is that Cygwin32
-has a POSIX compatible library including support for the fork()
-function.
-
-Steve
-
---
-Steven Morlock
-Foliage Software Systems
-aka The Nerd Farm
-http://www.foliage.com
-==
-
-These are the steps I took to build the latest development
-version of Perl (5.005.53) under the Windows 95 & Window 98
-operating system using Cygnus' Cygwin Win32 ports of the GNU
-development tools.
-
-The release of the Cygwin32 tools used was B20.1. These tools
-can be found at:
-
- http://sourceware.cygnus.com/cygwin
-
-Install Cygwin32 as described on the Cygnus web site. Additionally
-you should mount /bin as described in the following document:
-
- http://sourceware.cygnus.com/cygwin/cygwin-ug-net/setup-mount.html
-
-Note that the mount command shown in their example should appear on a
-single line:
-
- mount C:/cygnus/cygwin-b20/H-i586-cygwin32/bin /bin
-
-You must run the described build process below under the Cygwin32
-'bash' shell.
-
-In the following <PERL> will refer to the perl source/build
-directory. <INST> will refer to the perl target/install directory.
-
-* Pre-build checklist:
-
- - I found that building Perl on a unmounted partition/drive other
- than the root will fail. It appears that the double forward slash
- that Cygwin32 uses to reference drives other than the root drive
- (typically C:) gets converted to a single forward slash at several
- points in the build process. I have not tried, but expect it would
- work, to mount the non-root drive. This problem held true for both
- the drive where the perl source were and the drive where the
- Cygwin32 binaries where located. In the build described in these
- notes the Perl source and Cygwin32 binaries were located on the
- root drive.
-
- - Following the instructions in <PERL>/README.cygwin32:
-*******CSW********
-apply the patch, first
-******************
-
- + Copy the contents of the <PERL>cygwin32 directory to <PERL>
-
- + Edit the 'ld2' & 'gcc2' scripts to reflect the build path <PERL>
-
- + Either move 'ld2' & 'gcc2' to a directory on your path or add
- <PERL> to you path.
-
- - Edit <PERL>/hints/cygwin32.sh:
-
- + Add the following lines to the script:
-*******CSW********
-the patch does this
-******************
- i_stdarg='define'
- i_varargs='undef'
-
- This change allows us to pick up the right version of
- va_start(). Cygwin32 has both a signal and double parameter
- versions floating around in their header files.
-
- + Remove support for dynamic linking. I found that all
- DynaLoader'd extensions crashed during the running of the
- test suite. Add or edit 'usedl' entry to read:
-*******CSW********
-the patch does this
-******************
- usedl='n'
-
- If there is enough push I will try to sort out the problems with
- dynamic loading. I have made several unsuccessful attempts at
- modifying <PERL>/perlld to fix this problem. If you are
- interested, write me.
-
- + Change the path to the Cygwin32 directories. This includes the
- entries for 'usrinc', 'libpth', 'lddlflags', 'libc' and
- 'usrinc'.
-*******CSW********
-the patch does this ^
-******************
-
- - Edit makedepend.SH. The original version of makedepend.SH produces
- dependencies that include double backslashes. This can not be
- processed by Cygwin32's 'make'. Apply the following modification
- to makedepend.SH to correct these unfortunate filenames:
-*******CSW********
-and this, as well \/
-******************
-
-*** makedepend.SH.ORIG Wed Sep 23 09:51:56 1998
---- makedepend.SH Mon Dec 21 09:27:30 1998
-***************
-*** 100,105 ****
---- 100,107 ----
- # for file in `cat /dev/null`; do
- if [ "$osname" = uwin ]; then
- uwinfix="-e s,\\\\\\\\,/,g -e s,\\([a-zA-Z]\\):/,/\\1/,g"
-+ elif [ "$archname" = cygwin32 ]; then
-+ uwinfix="-e s,\\\\\\\\,/,g"
- else
- uwinfix=
- fi
-
- - Edit config_h.SH. The original version of config_h.SH has an bogus
- #include that gets propagated into the dependency list in Makefile
- create from the makedepend script. The Apply the following
- modification to config_h.SH to work around this unfortunate
- filename:
-*******CSW********
-the patch does this, too
-******************
-
-*** config_h.SH.ORIG Wed Oct 28 23:16:10 1998
---- config_h.SH Mon Dec 21 10:14:28 1998
-***************
-*** 1412,1416 ****
- #endif
- #if $cpp_stuff != 1 && $cpp_stuff != 42
-! #include "Bletch: How does this C preprocessor catenate tokens?"
- #endif
-
---- 1412,1416 ----
- #endif
- #if $cpp_stuff != 1 && $cpp_stuff != 42
-! #include "#Bletch: How does this C preprocessor catenate tokens?"
- #endif
-
- The real source of the problem appears that the 'make depend' in the
- 'x2p' directory has problems. The following messages are generated
- by that 'make depend':
-
- Finding dependencies for hash.o.
- gcc2: Can't open gcc2
- ... [similar messages to above]
- You don't seem to have a proper C preprocessor. Using grep
- instead.
- Updating GNUmakefile...
-
- So the grep is pulling the bogus #include from the file. The patch
- turns the #include'd message into a comment.
-
- - Run the Configure in the <PERL> directory as described in the
- document <PERL>/README.cygwin32
-
- I receive the message "THIS PACKAGE SEEMS INCOMPLETE.". This does
- not appear to be a problem.
-
- When presented with the list of handy defaults, select 'cygwin32'
-
- You can use the defaults for the remainder of the prompts.
-
-* Building:
-
- - Issue the command 'make' in the directory <PERL>.
- Cross fingers, wait and be patient.
-
-*******CSW********
-I didn't see this problem \/
-******************
- - I experience problems when building two files 'pp_sys.o' &
- 'doio.o'. The build process will crash with a Windows dialog
- during the build of these two files. The way I get by the problem
- is to control-C the make and issue the build commands for the two
- files by hand. In the Perl directory issue the following commands:
-
- `sh cflags libperl.a pp_sys.o` pp_sys.c
- `sh cflags libperl.a doio.o` doio.c
-
- This appears to be a problem with Cygwin32's make.
-
- Hopefully if you follow the instructions above you will experience no
- problems building Perl.
-
-* Testing:
-
- I found that the majority of the tests passed. There were no errors
- that I thought particularly scary. There were several unexpected
- results such as a couple 'A required .DLL file, CYGWIN1.DLL, was not
- found' dialogs and 'Perl perform an illegal operation' dialogs.
-
-*******CSW********
-saw the "missing dll" during one test
-******************
-
- As long as I can run all my own scripts, things are fine by me...
-
- - Renamed or delete the file <PERL>/t/lib/io_sock.t so it will not be
- executed. This test hangs the system. I have made no attempts to
- fix the problem. From the <PERL> directory issue the following
- command:
-
-*******CSW********
-I didn't do this, and saw no problems.
-******************
-
- mv t/lib/io_sock.t t/lib/io_sock.t.ORIG
-
- - Issue the command 'make test' in the directory <PERL>.
- Cross fingers, wait and be patient.
-
-* Installing:
-
- The install seems to work okay. There are problems when install the
- man pages, but we don't need any stinkin' man pages, right?
-
-*******CSW********
-the man pages that didn't install were those that had "::" in their
-filename.
-******************
-
- - Issue the command 'make install' in the directory <PERL>.
-
-Configuration files available by request to perl@morlock.net
+++ /dev/null
-This document is obsolete. Refer to README.cygwin32.
-
-This is an addendum to Steven Morlock's original post.
-perl5.005_03-static-patch, contains the USEMYBINMODE correction described
-below.
-
-*****************************
-Subject: Re: HOWTO: Builiding Perl under Win95/98 using Cygwin32
-Author: Steven Morlock <newspost@morlock.net>
-Date: 1998/12/22
-Forum: comp.lang.perl.misc
-
-I realized that in my original post I left out a couple important
-details. I'd like to correct that here.
-
-There is a need to address the issue of end of lines being CR/NL or
-NL on the Windows platform. Cygwin32 by default converts NL to CR/NL
-during file I/O by non Cygwin32-savvy applications. This means that
-Perl, since it does not support 'binmode' for the Cygwin32 platform,
-will not be able to read & write untranslated/binary files. There are
-two methods of over coming this. The first is to mount the Cygwin32
-partitions in binary mode. The second is to enable binmode support
-in Perl. In the original post I had mounted the partition as binary
-and neglected to include that fact in the post.
-
-* Using a binary partition:
-
- Mount the Perl source & installation destination partitions in binary
- mode. Refer to the Cygnus documentation on 'mount' for details:
-
- http://sourceware.cygnus.com/cygwin/cygwin-ug-net/mount.html
-
- On my system since everything was in the root partition I issued the
- following commands from the bash shell:
-
- umount /
- mount -b c:\\ /
-
- You must also get and install the gzip'd version of the Perl source
- code archive. The zip'd version of the archive has all NL converted
- to CR/NL pairs in all text files. So you should be downloading the
- files ending in '.gz', not '.zip'.
-
-* Patching Perl to add Cygwin32 binmode support:
-
- For this method you can use either the gzip'd or zip'd version of the
- Perl source archive.
-
- Apply the following patch to <PERL>/perl.h:
-
-*** perl.h.ORIG Tue Dec 22 09:22:42 1998
---- perl.h Tue Dec 22 09:43:10 1998
-***************
-*** 1480,1483 ****
---- 1480,1495 ----
- #endif
-
-+ #if defined(__CYGWIN32__)
-+ /* USEMYBINMODE
-+ * This symbol, if defined, indicates that the program should
-+ * use the routine my_binmode(FILE *fp, char iotype) to insure
-+ * that a file is in "binary" mode -- that is, that no translation
-+ * of bytes occurs on read or write operations.
-+ */
-+ #define USEMYBINMODE / **/
-+ #define my_binmode(fp, iotype) \
-+ (PerlLIO_setmode(PerlIO_fileno(fp), O_BINARY) != -1 ?
-TRUE : NULL)
-+ #endif
-+
- #include "regexp.h"
- #include "sv.h"
-
-Regards,
-Steve
-
---
-Steven Morlock
-Foliage Software Systems
-aka The Nerd Farm
-http://www.foliage.com
}
#endif
#ifdef HAS_RENAME
-#ifndef DOSISH
+#if !defined(DOSISH) && !defined(CYGWIN)
if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
if (ckWARN_d(WARN_INPLACE))
Perl_warner(aTHX_ WARN_INPLACE,
# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v)
# define BIT_BUCKET "nul"
# else
-# define PERL_SYS_INIT(c,v) Perl_my_setenv_init(&environ)
+# define PERL_SYS_INIT(c,v)
# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */
# endif
#endif /* DJGPP */
s |char*|nextchar
s |regnode*|dumpuntil |regnode *start|regnode *node \
|regnode *last|SV* sv|I32 l
-s |void |scan_commit |scan_data_t *data
+s |void |scan_commit |struct scan_data_t *data
s |I32 |study_chunk |regnode **scanp|I32 *deltap \
- |regnode *last|scan_data_t *data|U32 flags
+ |regnode *last|struct scan_data_t *data \
+ |U32 flags
s |I32 |add_data |I32 n|char *s
rs |void|re_croak2 |const char* pat1|const char* pat2|...
s |I32 |regpposixcc |I32 value
#define PL_reg_eval_set (my_perl->Treg_eval_set)
#define PL_reg_flags (my_perl->Treg_flags)
#define PL_reg_ganch (my_perl->Treg_ganch)
+#define PL_reg_leftiter (my_perl->Treg_leftiter)
#define PL_reg_magic (my_perl->Treg_magic)
+#define PL_reg_maxiter (my_perl->Treg_maxiter)
#define PL_reg_oldcurpm (my_perl->Treg_oldcurpm)
#define PL_reg_oldpos (my_perl->Treg_oldpos)
#define PL_reg_oldsaved (my_perl->Treg_oldsaved)
#define PL_reg_oldsavedlen (my_perl->Treg_oldsavedlen)
+#define PL_reg_poscache (my_perl->Treg_poscache)
+#define PL_reg_poscache_size (my_perl->Treg_poscache_size)
#define PL_reg_re (my_perl->Treg_re)
#define PL_reg_start_tmp (my_perl->Treg_start_tmp)
#define PL_reg_start_tmpl (my_perl->Treg_start_tmpl)
#define PL_reg_starttry (my_perl->Treg_starttry)
#define PL_reg_sv (my_perl->Treg_sv)
+#define PL_reg_whilem_seen (my_perl->Treg_whilem_seen)
#define PL_regbol (my_perl->Tregbol)
#define PL_regcc (my_perl->Tregcc)
#define PL_regcode (my_perl->Tregcode)
#define PL_reg_eval_set (PERL_GET_INTERP->Treg_eval_set)
#define PL_reg_flags (PERL_GET_INTERP->Treg_flags)
#define PL_reg_ganch (PERL_GET_INTERP->Treg_ganch)
+#define PL_reg_leftiter (PERL_GET_INTERP->Treg_leftiter)
#define PL_reg_magic (PERL_GET_INTERP->Treg_magic)
+#define PL_reg_maxiter (PERL_GET_INTERP->Treg_maxiter)
#define PL_reg_oldcurpm (PERL_GET_INTERP->Treg_oldcurpm)
#define PL_reg_oldpos (PERL_GET_INTERP->Treg_oldpos)
#define PL_reg_oldsaved (PERL_GET_INTERP->Treg_oldsaved)
#define PL_reg_oldsavedlen (PERL_GET_INTERP->Treg_oldsavedlen)
+#define PL_reg_poscache (PERL_GET_INTERP->Treg_poscache)
+#define PL_reg_poscache_size (PERL_GET_INTERP->Treg_poscache_size)
#define PL_reg_re (PERL_GET_INTERP->Treg_re)
#define PL_reg_start_tmp (PERL_GET_INTERP->Treg_start_tmp)
#define PL_reg_start_tmpl (PERL_GET_INTERP->Treg_start_tmpl)
#define PL_reg_starttry (PERL_GET_INTERP->Treg_starttry)
#define PL_reg_sv (PERL_GET_INTERP->Treg_sv)
+#define PL_reg_whilem_seen (PERL_GET_INTERP->Treg_whilem_seen)
#define PL_regbol (PERL_GET_INTERP->Tregbol)
#define PL_regcc (PERL_GET_INTERP->Tregcc)
#define PL_regcode (PERL_GET_INTERP->Tregcode)
#define PL_Treg_eval_set PL_reg_eval_set
#define PL_Treg_flags PL_reg_flags
#define PL_Treg_ganch PL_reg_ganch
+#define PL_Treg_leftiter PL_reg_leftiter
#define PL_Treg_magic PL_reg_magic
+#define PL_Treg_maxiter PL_reg_maxiter
#define PL_Treg_oldcurpm PL_reg_oldcurpm
#define PL_Treg_oldpos PL_reg_oldpos
#define PL_Treg_oldsaved PL_reg_oldsaved
#define PL_Treg_oldsavedlen PL_reg_oldsavedlen
+#define PL_Treg_poscache PL_reg_poscache
+#define PL_Treg_poscache_size PL_reg_poscache_size
#define PL_Treg_re PL_reg_re
#define PL_Treg_start_tmp PL_reg_start_tmp
#define PL_Treg_start_tmpl PL_reg_start_tmpl
#define PL_Treg_starttry PL_reg_starttry
#define PL_Treg_sv PL_reg_sv
+#define PL_Treg_whilem_seen PL_reg_whilem_seen
#define PL_Tregbol PL_regbol
#define PL_Tregcc PL_regcc
#define PL_Tregcode PL_regcode
#define PL_reg_eval_set (thr->Treg_eval_set)
#define PL_reg_flags (thr->Treg_flags)
#define PL_reg_ganch (thr->Treg_ganch)
+#define PL_reg_leftiter (thr->Treg_leftiter)
#define PL_reg_magic (thr->Treg_magic)
+#define PL_reg_maxiter (thr->Treg_maxiter)
#define PL_reg_oldcurpm (thr->Treg_oldcurpm)
#define PL_reg_oldpos (thr->Treg_oldpos)
#define PL_reg_oldsaved (thr->Treg_oldsaved)
#define PL_reg_oldsavedlen (thr->Treg_oldsavedlen)
+#define PL_reg_poscache (thr->Treg_poscache)
+#define PL_reg_poscache_size (thr->Treg_poscache_size)
#define PL_reg_re (thr->Treg_re)
#define PL_reg_start_tmp (thr->Treg_start_tmp)
#define PL_reg_start_tmpl (thr->Treg_start_tmpl)
#define PL_reg_starttry (thr->Treg_starttry)
#define PL_reg_sv (thr->Treg_sv)
+#define PL_reg_whilem_seen (thr->Treg_whilem_seen)
#define PL_regbol (thr->Tregbol)
#define PL_regcc (thr->Tregcc)
#define PL_regcode (thr->Tregcode)
{
no strict 'refs';
$unused_sub_packages{$package} = 1;
- if (defined(@{$package.'::ISA'}))
+ if (@{$package.'::ISA'})
{
foreach my $isa (@{$package.'::ISA'})
{
# B::Deparse.pm
-# Copyright (c) 1998,1999 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
- OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT
+ OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
SVf_IOK SVf_NOK SVf_ROK SVf_POK
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.58;
+$VERSION = 0.59;
use strict;
# Changes between 0.50 and 0.51:
# - added -si and -sT to control indenting (also based on a patch from Hugo)
# - added -sv to print something else instead of '???'
# - preliminary version of utf8 tr/// handling
+# Changes after 0.58:
+# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
+# - added support for Hugo's new OP_SETSTATE (like nextstate)
+# Changes between 0.58 and 0.59
+# - added support for Chip's OP_METHOD_NAMED
+# - added support for Ilya's OPpTARGET_MY optimization
+# - elided arrows before `()' subscripts when possible
# Todo:
# - finish tr/// changes
# - recognize `use utf8', `use integer', etc
# - treat top-level block specially for incremental output
# - interpret in high bit chars in string as utf8 \x{...} (when?)
-# - copy comments (look at real text with $^P)
+# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - ',' => '=>' (auto-unquote?)
# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
+# - handle `my $x if 0'?
# - include values of variables (e.g. set in BEGIN)
# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
return "format $name =\n"
. $self->deparse_format($ent->[1]->FORM). "\n";
} else {
- return "sub $name " .
- $self->deparse_sub($ent->[1]->CV);
+ return "sub $name " . $self->deparse_sub($ent->[1]->CV);
}
}
}
}
+sub maybe_targmy {
+ my $self = shift;
+ my($op, $cx, $func, @args) = @_;
+ if ($op->private & OPpTARGET_MY) {
+ my $var = $self->padname($op->targ);
+ my $val = $func->($self, $op, 7, @args);
+ return $self->maybe_parens("$var = $val", $cx, 7);
+ } else {
+ return $func->($self, $op, $cx, @args);
+ }
+}
+
sub padname_sv {
my $self = shift;
my $targ = shift;
sub pp_stub { baseop(@_, "()") }
sub pp_wantarray { baseop(@_, "wantarray") }
sub pp_fork { baseop(@_, "fork") }
-sub pp_wait { baseop(@_, "wait") }
-sub pp_getppid { baseop(@_, "getppid") }
-sub pp_time { baseop(@_, "time") }
+sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
+sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
+sub pp_time { maybe_targmy(@_, \&baseop, "time") }
sub pp_tms { baseop(@_, "times") }
sub pp_ghostent { baseop(@_, "gethostent") }
sub pp_gnetent { baseop(@_, "getnetent") }
sub pp_preinc { pfixop(@_, "++", 23) }
sub pp_predec { pfixop(@_, "--", 23) }
-sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
-sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
+sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
sub pp_i_preinc { pfixop(@_, "++", 23) }
sub pp_i_predec { pfixop(@_, "--", 23) }
-sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
-sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
-sub pp_complement { pfixop(@_, "~", 21) }
+sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
+sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
+sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
-sub pp_negate {
+sub pp_negate { maybe_targmy(@_, \&real_negate) }
+sub real_negate {
my $self = shift;
my($op, $cx) = @_;
if ($op->first->name =~ /^(i_)?negate$/) {
}
}
-sub pp_chop { unop(@_, "chop") }
-sub pp_chomp { unop(@_, "chomp") }
-sub pp_schop { unop(@_, "chop") }
-sub pp_schomp { unop(@_, "chomp") }
+sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
+sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
+sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
sub pp_defined { unop(@_, "defined") }
sub pp_undef { unop(@_, "undef") }
sub pp_study { unop(@_, "study") }
sub pp_ref { unop(@_, "ref") }
sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
-sub pp_sin { unop(@_, "sin") }
-sub pp_cos { unop(@_, "cos") }
-sub pp_rand { unop(@_, "rand") }
+sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
+sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
+sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
sub pp_srand { unop(@_, "srand") }
-sub pp_exp { unop(@_, "exp") }
-sub pp_log { unop(@_, "log") }
-sub pp_sqrt { unop(@_, "sqrt") }
-sub pp_int { unop(@_, "int") }
-sub pp_hex { unop(@_, "hex") }
-sub pp_oct { unop(@_, "oct") }
-sub pp_abs { unop(@_, "abs") }
-
-sub pp_length { unop(@_, "length") }
-sub pp_ord { unop(@_, "ord") }
-sub pp_chr { unop(@_, "chr") }
+sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
+sub pp_log { maybe_targmy(@_, \&unop, "log") }
+sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
+sub pp_int { maybe_targmy(@_, \&unop, "int") }
+sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
+sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
+sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
+
+sub pp_length { maybe_targmy(@_, \&unop, "length") }
+sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
+sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
sub pp_each { unop(@_, "each") }
sub pp_values { unop(@_, "values") }
sub pp_getsockname { unop(@_, "getsockname") }
sub pp_getpeername { unop(@_, "getpeername") }
-sub pp_chdir { unop(@_, "chdir") }
-sub pp_chroot { unop(@_, "chroot") }
+sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
+sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
sub pp_readlink { unop(@_, "readlink") }
-sub pp_rmdir { unop(@_, "rmdir") }
+sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
sub pp_readdir { unop(@_, "readdir") }
sub pp_telldir { unop(@_, "telldir") }
sub pp_rewinddir { unop(@_, "rewinddir") }
sub pp_closedir { unop(@_, "closedir") }
-sub pp_getpgrp { unop(@_, "getpgrp") }
+sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
sub pp_localtime { unop(@_, "localtime") }
sub pp_gmtime { unop(@_, "gmtime") }
sub pp_alarm { unop(@_, "alarm") }
-sub pp_sleep { unop(@_, "sleep") }
+sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
sub pp_dofile { unop(@_, "do") }
sub pp_entereval { unop(@_, "eval") }
sub pp_lcfirst { dq_unop(@_, "lcfirst") }
sub pp_uc { dq_unop(@_, "uc") }
sub pp_lc { dq_unop(@_, "lc") }
-sub pp_quotemeta { dq_unop(@_, "quotemeta") }
+sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
sub loopex {
my $self = shift;
return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
}
-sub pp_add { binop(@_, "+", 18, ASSIGN) }
-sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
-sub pp_subtract { binop(@_, "-",18, ASSIGN) }
-sub pp_divide { binop(@_, "/", 19, ASSIGN) }
-sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
-sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
-sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
-sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
-sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
-sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
-sub pp_pow { binop(@_, "**", 22, ASSIGN) }
-
-sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
-sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
-sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
-sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
-sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
+sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
+sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
+sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
+sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
+sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
+sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
+sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
+
+sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
+sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
+sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
+sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
+sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
sub pp_eq { binop(@_, "==", 14) }
sub pp_ne { binop(@_, "!=", 14) }
# `.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
# programmer had written `($a . $b) .= $c', except legal.
-sub pp_concat {
+sub pp_concat { maybe_targmy(@_, \&real_concat) }
+sub real_concat {
my $self = shift;
my($op, $cx) = @_;
my $left = $op->first;
sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
+
+# xor is syntactically a logop, but it's really a binop (contrary to
+# old versions of opcode.pl). Syntax is what matters here.
sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
sub logassignop {
}
sub pp_bless { listop(@_, "bless") }
-sub pp_atan2 { listop(@_, "atan2") }
+sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
-sub pp_index { listop(@_, "index") }
-sub pp_rindex { listop(@_, "rindex") }
-sub pp_sprintf { listop(@_, "sprintf") }
+sub pp_index { maybe_targmy(@_, \&listop, "index") }
+sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
+sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
sub pp_formline { listop(@_, "formline") } # see also deparse_format
-sub pp_crypt { listop(@_, "crypt") }
+sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
sub pp_unpack { listop(@_, "unpack") }
sub pp_pack { listop(@_, "pack") }
-sub pp_join { listop(@_, "join") }
+sub pp_join { maybe_targmy(@_, \&listop, "join") }
sub pp_splice { listop(@_, "splice") }
-sub pp_push { listop(@_, "push") }
-sub pp_unshift { listop(@_, "unshift") }
+sub pp_push { maybe_targmy(@_, \&listop, "push") }
+sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
sub pp_reverse { listop(@_, "reverse") }
sub pp_warn { listop(@_, "warn") }
sub pp_die { listop(@_, "die") }
sub pp_seek { listop(@_, "seek") }
sub pp_fcntl { listop(@_, "fcntl") }
sub pp_ioctl { listop(@_, "ioctl") }
-sub pp_flock { listop(@_, "flock") }
+sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
sub pp_socket { listop(@_, "socket") }
sub pp_sockpair { listop(@_, "sockpair") }
sub pp_bind { listop(@_, "bind") }
sub pp_shutdown { listop(@_, "shutdown") }
sub pp_gsockopt { listop(@_, "getsockopt") }
sub pp_ssockopt { listop(@_, "setsockopt") }
-sub pp_chown { listop(@_, "chown") }
-sub pp_unlink { listop(@_, "unlink") }
-sub pp_chmod { listop(@_, "chmod") }
-sub pp_utime { listop(@_, "utime") }
-sub pp_rename { listop(@_, "rename") }
-sub pp_link { listop(@_, "link") }
-sub pp_symlink { listop(@_, "symlink") }
-sub pp_mkdir { listop(@_, "mkdir") }
+sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
+sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
+sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
+sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
+sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
+sub pp_link { maybe_targmy(@_, \&listop, "link") }
+sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
+sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
sub pp_open_dir { listop(@_, "opendir") }
sub pp_seekdir { listop(@_, "seekdir") }
-sub pp_waitpid { listop(@_, "waitpid") }
-sub pp_system { listop(@_, "system") }
-sub pp_exec { listop(@_, "exec") }
-sub pp_kill { listop(@_, "kill") }
-sub pp_setpgrp { listop(@_, "setpgrp") }
-sub pp_getpriority { listop(@_, "getpriority") }
-sub pp_setpriority { listop(@_, "setpriority") }
+sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
+sub pp_system { maybe_targmy(@_, \&listop, "system") }
+sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
+sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
+sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
+sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
+sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
sub pp_shmget { listop(@_, "shmget") }
sub pp_shmctl { listop(@_, "shmctl") }
sub pp_shmread { listop(@_, "shmread") }
$expr = $self->deparse($kid, 6);
push @exprs, $expr;
}
- return $self->maybe_parens_func($name,
- $indir . join(", ", @exprs),
+ return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
$cx, 5);
}
}
}
+sub is_subscriptable {
+ my $op = shift;
+ if ($op->name =~ /^[ahg]elem/) {
+ return 1;
+ } elsif ($op->name eq "entersub") {
+ my $kid = $op->first;
+ return 0 unless null $kid->sibling;
+ $kid = $kid->first;
+ $kid = $kid->sibling until null $kid->sibling;
+ return 0 if is_scope($kid);
+ $kid = $kid->first;
+ return 0 if $kid->name eq "gv";
+ return 0 if is_scalar($kid);
+ return is_subscriptable($kid);
+ } else {
+ return 0;
+ }
+}
sub elem {
my $self = shift;
$array = $self->deparse($array, 24);
} else {
# $x[20][3]{hi} or expr->[20]
- my $arrow;
- $arrow = "->" if $array->name !~ /^[ah]elem$/;
+ my $arrow = is_subscriptable($array) ? "" : "->";
return $self->deparse($array, 24) . $arrow .
$left . $self->deparse($idx, 1) . $right;
}
return "\@" . $array . $left . $list . $right;
}
-sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
- "rv2av", "padav")) }
-sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
- "rv2hv", "padhv")) }
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
sub pp_lslice {
my $self = shift;
# as the left side of -> always is, while in the former
# the list is in list context as method arguments always are.
# (Good thing there aren't method prototypes!)
- $meth = $kid->sibling->first;
+ $meth = $kid->sibling;
$kid = $kid->first->sibling; # skip pushmark
$obj = $kid;
$kid = $kid->sibling;
for (; not null $kid->sibling; $kid = $kid->sibling) {
push @exprs, $self->deparse($kid, 6);
}
- $meth = $kid->first;
+ $meth = $kid;
}
$obj = $self->deparse($obj, 24);
- if ($meth->name eq "const") {
- $meth = $meth->sv->PV; # needs to be bare
+ if ($meth->name eq "method_named") {
+ $meth = $meth->sv->PV;
} else {
- $meth = $self->deparse($meth, 1);
+ $meth = $meth->first;
+ if ($meth->name eq "const") {
+ # As of 5.005_58, this case is probably obsoleted by the
+ # method_named case above
+ $meth = $meth->sv->PV; # needs to be bare
+ } else {
+ $meth = $self->deparse($meth, 1);
+ }
}
my $args = join(", ", @exprs);
$kid = $obj . "->" . $meth;
$kid = $self->deparse($kid, 24);
} else {
$prefix = "";
- $kid = $self->deparse($kid, 24) . "->";
+ my $arrow = is_subscriptable($kid->first) ? "" : "->";
+ $kid = $self->deparse($kid, 24) . $arrow;
}
my $args;
if (defined $proto and not $amper) {
sub dquote {
my $self = shift;
my($op, $cx) = shift;
- return $self->deparse($op->first->sibling, $cx) if $self->{'unquote'};
- # skip ex-stringify, pushmark
- return single_delim("qq", '"', $self->dq($op->first->sibling));
+ my $kid = $op->first->sibling; # skip ex-stringify, pushmark
+ return $self->deparse($kid, $cx) if $self->{'unquote'};
+ $self->maybe_targmy($kid, $cx,
+ sub {single_delim("qq", '"', $self->dq($_[1]))});
}
# OP_STRINGIFY is a listop, but it only ever has one arg
-sub pp_stringify { dquote(@_) }
+sub pp_stringify { maybe_targmy(@_, \&dquote) }
# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
# note that tr(from)/to/ is OK, but not tr/from/(to)
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);
* 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.
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 6th June 1999
-# version 1.67
+# last modified 22nd July 1999
+# version 1.68
#
# Copyright (c) 1995-1999 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
use Carp;
-$VERSION = "1.67" ;
+$VERSION = "1.68" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
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";
# 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" ;
# iterate through the associative array
# and print each key/value pair.
- foreach (keys %h)
+ foreach (sort keys %h)
{ print "$_ -> $h{$_}\n" }
untie %h ;
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" ;
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") ;
prints this
- Larry Wall is there
+ Larry Wall is there
Harry Wall is not there
$st == 0 ;
$st = $x->seq($key, $value, R_NEXT) )
- { print "$key -> $value\n" }
+ { print "$key -> $value\n" }
print "\nPARTIAL MATCH\n" ;
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
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
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 6th June 1999
- version 1.67
+ last modified 22nd July 1999
+ version 1.68
All comments/suggestions/problems are welcome
1.67 - Backed off the use of newSVpvn.
Fixed DBM Filter code for Perl 5.004.
Fixed a small memory leak in the filter code.
+ 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE
+ merged in the 5.005_58 changes
#include "XSUB.h"
#ifndef PERL_VERSION
-#include "patchlevel.h"
-#define PERL_REVISION 5
-#define PERL_VERSION PATCHLEVEL
-#define PERL_SUBVERSION SUBVERSION
+# include "patchlevel.h"
+# define PERL_REVISION 5
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
#endif
#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
/* DEFSV appears first in 5.004_56 */
#ifndef DEFSV
-#define DEFSV GvSV(defgv)
+# define DEFSV GvSV(defgv)
#endif
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
be defined here. This clashes with a field name in db.h, so get rid of it.
*/
#ifdef op
-#undef op
+# undef op
#endif
#include <db.h>
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(a,b) newSVpv(a,b)
+#endif
+
#include <fcntl.h>
/* #define TRACE */
/* map version 2 features & constants onto their version 1 equivalent */
#ifdef DB_Prefix_t
-#undef DB_Prefix_t
+# undef DB_Prefix_t
#endif
#define DB_Prefix_t size_t
#ifdef DB_Hash_t
-#undef DB_Hash_t
+# undef DB_Hash_t
#endif
#define DB_Hash_t u_int32_t
#define R_NEXT DB_NEXT
#define R_NOOVERWRITE DB_NOOVERWRITE
#define R_PREV DB_PREV
-#define R_SETCURSOR 0
+#define R_SETCURSOR (-1 )
#define R_RECNOSYNC 0
#define R_FIXEDLEN DB_FIXEDLEN
#define R_DUP DB_DUP
#ifdef DB_VERSION_MAJOR
static int
+#ifdef CAN_PROTOTYPE
db_put(DB_File db, DBTKEY key, DBT value, u_int flags)
+#else
+db_put(db, key, value, flags)
+DB_File db ;
+DBTKEY key ;
+DBT value ;
+u_int flags ;
+#endif
{
int status ;
- if (flagSet(flags, R_CURSOR)) {
- status = ((db->cursor)->c_del)(db->cursor, 0);
- if (status != 0)
- return status ;
-
-#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
- flags &= ~R_CURSOR ;
+ if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) {
+ DBC * temp_cursor ;
+ DBT l_key, l_value;
+
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
+ if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0)
#else
- flags &= ~DB_OPFLAGS_MASK ;
+ if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0)
#endif
+ return (-1) ;
+
+ memset(&l_key, 0, sizeof(l_key));
+ l_key.data = key.data;
+ l_key.size = key.size;
+ memset(&l_value, 0, sizeof(l_value));
+ l_value.data = value.data;
+ l_value.size = value.size;
+ if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) {
+ (void)temp_cursor->c_close(temp_cursor);
+ return (-1);
+ }
+
+ status = temp_cursor->c_put(temp_cursor, &key, &value, flags);
+ (void)temp_cursor->c_close(temp_cursor);
+
+ return (status) ;
+ }
+
+
+ if (flagSet(flags, R_CURSOR)) {
+ return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT);
+ }
+
+ if (flagSet(flags, R_SETCURSOR)) {
+ if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0)
+ return -1 ;
+ return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE);
+
}
return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
static int
+#ifdef CAN_PROTOTYPE
btree_compare(const DBT *key1, const DBT *key2)
+#else
+btree_compare(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
{
+#ifdef dTHX
dTHX;
+#endif
dSP ;
void * data1, * data2 ;
int retval ;
data1 = key1->data ;
data2 = key2->data ;
+#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
string if the size parameter is 0, make sure that data points to an
empty string if the length is 0
data1 = "" ;
if (key2->size == 0)
data2 = "" ;
+#endif
ENTER ;
SAVETMPS;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
- PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
- PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->compare, G_SCALAR);
}
static DB_Prefix_t
+#ifdef CAN_PROTOTYPE
btree_prefix(const DBT *key1, const DBT *key2)
+#else
+btree_prefix(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+#endif
{
+#ifdef dTHX
dTHX;
+#endif
dSP ;
void * data1, * data2 ;
int retval ;
data1 = key1->data ;
data2 = key2->data ;
+#ifndef newSVpvn
/* As newSVpv will assume that the data pointer is a null terminated C
string if the size parameter is 0, make sure that data points to an
empty string if the length is 0
data1 = "" ;
if (key2->size == 0)
data2 = "" ;
+#endif
ENTER ;
SAVETMPS;
PUSHMARK(SP) ;
EXTEND(SP,2) ;
- PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
- PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
+ PUSHs(sv_2mortal(newSVpvn(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
}
static DB_Hash_t
+#ifdef CAN_PROTOTYPE
hash_cb(const void *data, size_t size)
+#else
+hash_cb(data, size)
+const void * data ;
+size_t size ;
+#endif
{
+#ifdef dTHX
dTHX;
+#endif
dSP ;
int retval ;
int count ;
+#ifndef newSVpvn
if (size == 0)
data = "" ;
+#endif
/* DGH - Next two lines added to fix corrupted stack problem */
ENTER ;
PUSHMARK(SP) ;
- XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
+ XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
PUTBACK ;
count = perl_call_sv(CurrentDB->hash, G_SCALAR);
#ifdef TRACE
static void
+#ifdef CAN_PROTOTYPE
PrintHash(INFO *hash)
+#else
+PrintHash(hash)
+INFO * hash ;
+#endif
{
printf ("HASH Info\n") ;
printf (" hash = %s\n",
}
static void
+#ifdef CAN_PROTOTYPE
PrintRecno(INFO *recno)
+#else
+PrintRecno(recno)
+INFO * recno ;
+#endif
{
printf ("RECNO Info\n") ;
printf (" flags = %d\n", recno->db_RE_flags) ;
}
static void
+#ifdef CAN_PROTOTYPE
PrintBtree(INFO *btree)
+#else
+PrintBtree(btree)
+INFO * btree ;
+#endif
{
printf ("BTREE Info\n") ;
printf (" compare = %s\n",
static I32
+#ifdef CAN_PROTOTYPE
GetArrayLength(pTHX_ DB_File db)
+#else
+GetArrayLength(db)
+DB_File db ;
+#endif
{
DBT key ;
DBT value ;
}
static recno_t
+#ifdef CAN_PROTOTYPE
GetRecnoKey(pTHX_ DB_File db, I32 value)
+#else
+GetRecnoKey(db, value)
+DB_File db ;
+I32 value ;
+#endif
{
if (value < 0) {
/* Get the length of the array */
}
static DB_File
+#ifdef CAN_PROTOTYPE
ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
+#else
+ParseOpenInfo(isHASH, name, flags, mode, sv)
+int isHASH ;
+char * name ;
+int flags ;
+int mode ;
+SV * sv ;
+#endif
{
SV ** svp;
HV * action ;
static double
+#ifdef CAN_PROTOTYPE
constant(char *name, int arg)
+#else
+constant(name, arg)
+char *name;
+int arg;
+#endif
{
errno = 0;
switch (*name) {
-/* dl_cygwin32.xs
+/* dl_cygwin.xs
*
* Platform: Win32 (Windows NT/Windows 95)
* Author: Wei-Yuen Tan (wyt@hip.com)
* August 23rd 1995 - rewritten after losing everything when I
* wiped off my NT partition (eek!)
*/
-/* Modified from the original dl_win32.xs to work with cygwin32
+/* Modified from the original dl_win32.xs to work with cygwin
-John Cerney 3/26/97
*/
/* Porting notes:
#define WIN32_LEAN_AND_MEAN
// Defines from windows needed for this function only. Can't include full
-// Cygwin32 windows headers because of problems with CONTEXT redefinition
+// Cygwin windows headers because of problems with CONTEXT redefinition
// Removed logic to tell not dynamically load static modules. It is assumed that all
// modules are dynamically built. This should be similar to the behavoir on sunOS.
// Leaving in the logic would have required changes to the standard perlmain.c code
}
# define times(t) vms_times(t)
#else
-#if defined (CYGWIN32)
+#if defined (CYGWIN)
# define tzname _tzname
# undef MB_CUR_MAX /* XXX: bug in b20.1 */
#endif
*/
#include "config.h"
-#ifdef CYGWIN32
+#ifdef CYGWIN
# define EXT extern
# define EXTCONST extern const
#else
Safefree(PL_reg_start_tmp);
SvREFCNT_dec(PL_lastscream);
SvREFCNT_dec(PL_defoutgv);
+ Safefree(PL_reg_poscache);
MUTEX_LOCK(&thr->mutex);
DEBUG_S(PerlIO_printf(PerlIO_stderr(),
#! /bin/sh
-# cygwin32.sh - hintsfile for building perl on Windows NT using the
-# Cygnus Win32 Development Kit.
+# cygwin.sh - hints for building perl using the Cygwin environment for Win32
#
_exe='.exe'
sharpbang='#!'
startsh='#!/bin/sh'
-archname='cygwin32'
+archname='cygwin'
cc='gcc'
libpth='/usr/i586-cygwin32/lib /usr/lib /usr/local/lib'
so='dll'
libs='-lcygwin -lm -lkernel32'
#optimize='-g'
-ccflags='-DCYGWIN32 -I/usr/include -I/usr/local/include'
+ccflags='-DCYGWIN -I/usr/include -I/usr/local/include'
ldflags='-L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib'
usemymalloc='n'
-dlsrc='dl_cygwin32.xs'
+dlsrc='dl_cygwin.xs'
cccdlflags=' '
ld='ld2'
lddlflags='-L/usr/local/lib'
man1dir=/usr/local/man/man1
man3dir=/usr/local/man/man3
-sitelib=/usr/local/lib/perl5/site_perl
case "$ldlibpthname" in
'') ldlibpthname=PATH ;;
# C-Flags:
ccflags='-DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED'
+# Flags on a RISC-Host (SUNRISE):
+if [ -n "`bs2cmd SHOW-SYSTEM-INFO | egrep 'HSI-ATT.*TYPE.*SR'`" ]; then
+ echo
+ echo "Congratulations, you are running a machine with Sunrise CPUs."
+ echo "Let's hope you have the matching RISC compiler as well."
+ ccflags='-K risc_4000 -DPOSIX_BC -DUSE_PURE_BISON -D_XOPEN_SOURCE_EXTENDED'
+ ldflags='-K risc_4000'
+fi
+
# Turning on optimization breaks perl (CORE-DUMP):
optimize='none'
# if we get called more than once, we want to initialize
# ourselves from the original query (which may be gone
# if it was read from STDIN originally.)
- if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ if (@QUERY_PARAM && !defined($initializer)) {
foreach (@QUERY_PARAM) {
$self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
}
sub keywords {
my($self,@values) = self_or_default(@_);
# If values is provided, then we set it.
- $self->{'keywords'}=[@values] if defined(@values);
+ $self->{'keywords'}=[@values] if @values;
my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
@result;
}
# rearrange into a pretty table
$result = "<TABLE>";
my($row,$column);
- unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
- $result .= "<TR>" if defined(@{$colheaders});
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<TR>" if @$colheaders;
foreach (@{$colheaders}) {
$result .= "<TH>$_</TH>";
}
for ($row=0;$row<$rows;$row++) {
$result .= "<TR>";
- $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
+ $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
for ($column=0;$column<$columns;$column++) {
$result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
if defined($elements[$column*$rows + $row]);
{ no strict 'refs';
$_ = &{'overload::StrVal'}($_)
if $self->{bareStringify} and ref $_
- and defined %overload:: and defined &{'overload::StrVal'};
+ and %overload:: and defined &{'overload::StrVal'};
}
if ($tick eq 'auto') {
my $val = $v;
{ no strict 'refs';
$val = &{'overload::StrVal'}($v)
- if defined %overload:: and defined &{'overload::StrVal'};
+ if %overload:: and defined &{'overload::StrVal'};
}
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$self->{dumpReused} && defined $address) {
print( (' ' x $off) . "\$", &unctrl($key), " = " );
$self->DumpElem($stab, 3+$off);
}
- if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined @stab) {
+ if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
print( (' ' x $off) . "\@$key = (\n" );
$self->unwrap(\@stab,3+$off) ;
print( (' ' x $off) . ")\n" );
}
- if ($key ne "main::" && $key ne "DB::" && defined %stab
+ if ($key ne "main::" && $key ne "DB::" && %stab
&& ($self->{dumpPackages} or $key !~ /::$/)
&& ($key !~ /^_</ or $self->{dumpDBFiles})
&& !($package eq "Dumpvalue" and $key eq "stab")) {
sub findsubs {
my $self = shift;
- return undef unless defined %DB::sub;
+ return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
local *stab = *{$_[0]};
my $total = 0;
$total += $self->scalarUsage($stab) if defined $stab;
- $total += $self->arrayUsage(\@stab, $_[1]) if defined @stab;
+ $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
$total += $self->hashUsage(\%stab, $_[1])
- if defined %stab and $_[1] ne "main::" and $_[1] ne "DB::";
+ if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
#and !($package eq "Dumpvalue" and $key eq "stab"));
$total;
}
/ *= */ and $self->{$`} = $';
};
$self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');
- $self->{CCFLAGS} .= " -DCYGWIN32" unless ($self->{CCFLAGS} =~ /\-DCYGWIN32/);
+ $self->{CCFLAGS} .= " -DCYGWIN" unless ($self->{CCFLAGS} =~ /\-DCYGWIN/);
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
$self->{BASEEXT}.def: Makefile.PL
",
' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
- Mksymlists("NAME" => "', $self->{NAME},
- '", "DLBASE" => "',$self->{DLBASE},
- '", "DL_FUNCS" => ',neatvalue($funcs),
+ Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ',
+ '"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ',
+ '"INSTALLDIRS" => "$(INSTALLDIRS)", ',
+ '"DL_FUNCS" => ',neatvalue($funcs),
', "FUNCLIST" => ',neatvalue($funclist),
', "IMPORTS" => ',neatvalue($imports),
- ', "VERSION" => "',$self->{VERSION},
- '", "DL_VARS" => ', neatvalue($vars), ');\'
+ ', "DL_VARS" => ', neatvalue($vars), ');\'
');
}
if (%{$self->{IMPORTS}}) {
($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
$data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
}
+ my $distname = $data->{DISTNAME} || $data->{NAME};
+ $distname = "Distribution $distname";
+ my $comment = "Perl (v$]$threaded) module $data->{NAME}";
+ if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
+ $distname = 'perl5-porters@perl.org';
+ $comment = "Core $comment";
+ }
rename "$data->{FILE}.def", "$data->{FILE}_def.old";
open(DEF,">$data->{FILE}.def")
or croak("Can't create $data->{FILE}.def: $!\n");
print DEF "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
- print DEF "DESCRIPTION 'Perl (v$]$threaded) module $data->{NAME} v$data->{VERSION}'\n";
+ print DEF "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n";
print DEF "CODE LOADONCALL\n";
print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n";
print DEF "EXPORTS\n ";
sub canonpath {
my ($self,$path,$reduce_ricochet) = @_;
- $path =~ s|/+|/|g; # xx////xx -> xx/xx
+ $path =~ s|/+|/|g unless($^O =~ /cygwin/); # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
$path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(\.\./)+|/|; # /../../xx -> xx
return $_ . "" if ref \$_ eq 'GLOB';
$_ = &{'overload::StrVal'}($_)
if $bareStringify and ref $_
- and defined %overload:: and defined &{'overload::StrVal'};
+ and %overload:: and defined &{'overload::StrVal'};
if ($tick eq 'auto') {
if (/[\000-\011\013-\037\177]/) {
if (ref $v) {
my $val = $v;
$val = &{'overload::StrVal'}($v)
- if defined %overload:: and defined &{'overload::StrVal'};
+ if %overload:: and defined &{'overload::StrVal'};
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$dumpReused && defined $address) {
$address{$address}++ ;
print( (' ' x $off) . "\$", &unctrl($key), " = " );
DumpElem $entry, 3+$off;
}
- if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
+ if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
print( (' ' x $off) . "\@$key = (\n" );
unwrap(\@entry,3+$off) ;
print( (' ' x $off) . ")\n" );
}
- if ($key ne "main::" && $key ne "DB::" && defined %entry
+ if ($key ne "main::" && $key ne "DB::" && %entry
&& ($dumpPackages or $key !~ /::$/)
&& ($key !~ /^_</ or $dumpDBFiles)
&& !($package eq "dumpvar" and $key eq "stab")) {
}
sub findsubs {
- return undef unless defined %DB::sub;
+ return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
local *name = *{$_[0]};
$total = 0;
$total += scalarUsage $name if defined $name;
- $total += arrayUsage \@name, $_[1] if defined @name;
- $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::"
+ $total += arrayUsage \@name, $_[1] if @name;
+ $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
$total;
}
#
# Create the export list for perl.
#
-# Needed by WIN32 for creating perl.dll and by AIX for creating libperl.a
-# when -Dusershrplib is in effect.
+# Needed by WIN32 and OS/2 for creating perl.dll
+# and by AIX for creating libperl.a when -Dusershrplib is in effect.
#
# reads global.sym, pp.sym, perlvars.h, intrpvar.h, thrdvar.h, config.h
+# On OS/2 reads miniperl.map as well
my $PLATFORM;
my $CCTYPE;
{
my $flag = shift;
$define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
+ $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
$CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
$PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
}
-my @PLATFORM = qw(aix win32);
+my @PLATFORM = qw(aix win32 os2);
my %PLATFORM;
@PLATFORM{@PLATFORM} = ();
$_ = $1;
$define{$1} = 1 while /-D(\w+)/g;
}
+ if ($PLATFORM eq 'os2') {
+ $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/;
+ $ARCHNAME = $1 if /^(?:archname)='(.+)'$/;
+ }
}
close(CFG);
}
}
print "EXPORTS\n";
}
+} elsif ($PLATFORM eq 'os2') {
+ ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
+ $v .= '-thread' if $ARCHNAME =~ /-thread/;
+ #$sum = 0;
+ #for (split //, $v) {
+ # $sum = ($sum * 33) + ord;
+ # $sum &= 0xffffff;
+ #}
+ #$sum += $sum >> 5;
+ #$sum &= 0xffff;
+ #$sum = printf '%X', $sum;
+ ($dll = $define{PERL_DLL}) =~ s/\.dll$//i;
+ # print STDERR "'$dll' <= '$define{PERL_DLL}'\n";
+ print <<"---EOP---";
+LIBRARY '$dll' INITINSTANCE TERMINSTANCE
+DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'
+STACKSIZE 32768
+CODE LOADONCALL
+DATA LOADONCALL NONSHARED MULTIPLE
+EXPORTS
+---EOP---
} elsif ($PLATFORM eq 'aix') {
print "#!\n";
}
)]);
}
+if ($PLATFORM eq 'os2') {
+ emit_symbols([qw(
+ctermid
+get_sysinfo
+Perl_OS2_init
+OS2_Perl_data
+dlopen
+dlsym
+dlerror
+my_tmpfile
+my_tmpnam
+my_flock
+malloc_mutex
+threads_mutex
+nthreads
+nthreads_cond
+os2_cond_wait
+pthread_join
+pthread_create
+pthread_detach
+XS_Cwd_change_drive
+XS_Cwd_current_drive
+XS_Cwd_extLibpath
+XS_Cwd_extLibpath_set
+XS_Cwd_sys_abspath
+XS_Cwd_sys_chdir
+XS_Cwd_sys_cwd
+XS_Cwd_sys_is_absolute
+XS_Cwd_sys_is_relative
+XS_Cwd_sys_is_rooted
+XS_DynaLoader_mod2fname
+XS_File__Copy_syscopy
+Perl_Register_MQ
+Perl_Deregister_MQ
+Perl_Serve_Messages
+Perl_Process_Messages
+init_PMWIN_entries
+PMWIN_entries
+Perl_hab_GET
+)]);
+}
+
if ($define{'PERL_OBJECT'}) {
skip_symbols [qw(
Perl_getenv_len
try_symbol($symbol);
}
}
+elsif ($PLATFORM eq 'os2') {
+ open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
+ /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>;
+ close MAP or die 'Cannot close miniperl.map';
+
+ @missing = grep { !exists $mapped{$_} } keys %export;
+ delete $export{$_} foreach @missing;
+}
# Now all symbols should be defined because
# next we are going to output them.
# print "\t$symbol\n";
# print "\t_$symbol = $symbol\n";
# }
+ } elsif ($PLATFORM eq 'os2') {
+ print qq( "$symbol"\n);
} elsif ($PLATFORM eq 'aix') {
print "$symbol\n";
}
if [ "$osname" = os2 ]; then
uwinfix="-e s,\\\\\\\\,/,g"
else
- if [ "$archname" = cygwin32 ]; then
+ if [ "$archname" = cygwin ]; then
uwinfix="-e s,\\\\\\\\,/,g"
else
uwinfix=
}
FreeEnvironmentStrings(envv);
# else
-# ifndef PERL_USE_SAFE_PUTENV
+# ifdef CYGWIN
+ I32 i;
+ for (i = 0; environ[i]; i++)
+ Safefree(environ[i]);
+# else
+# ifndef PERL_USE_SAFE_PUTENV
I32 i;
if (environ == PL_origenviron)
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
-# endif /* PERL_USE_SAFE_PUTENV */
+# endif /* PERL_USE_SAFE_PUTENV */
+# endif /* CYGWIN */
environ[0] = Nullch;
#define PL_reg_flags (*Perl_Treg_flags_ptr(aTHXo))
#undef PL_reg_ganch
#define PL_reg_ganch (*Perl_Treg_ganch_ptr(aTHXo))
+#undef PL_reg_leftiter
+#define PL_reg_leftiter (*Perl_Treg_leftiter_ptr(aTHXo))
#undef PL_reg_magic
#define PL_reg_magic (*Perl_Treg_magic_ptr(aTHXo))
+#undef PL_reg_maxiter
+#define PL_reg_maxiter (*Perl_Treg_maxiter_ptr(aTHXo))
#undef PL_reg_oldcurpm
#define PL_reg_oldcurpm (*Perl_Treg_oldcurpm_ptr(aTHXo))
#undef PL_reg_oldpos
#define PL_reg_oldsaved (*Perl_Treg_oldsaved_ptr(aTHXo))
#undef PL_reg_oldsavedlen
#define PL_reg_oldsavedlen (*Perl_Treg_oldsavedlen_ptr(aTHXo))
+#undef PL_reg_poscache
+#define PL_reg_poscache (*Perl_Treg_poscache_ptr(aTHXo))
+#undef PL_reg_poscache_size
+#define PL_reg_poscache_size (*Perl_Treg_poscache_size_ptr(aTHXo))
#undef PL_reg_re
#define PL_reg_re (*Perl_Treg_re_ptr(aTHXo))
#undef PL_reg_start_tmp
#define PL_reg_starttry (*Perl_Treg_starttry_ptr(aTHXo))
#undef PL_reg_sv
#define PL_reg_sv (*Perl_Treg_sv_ptr(aTHXo))
+#undef PL_reg_whilem_seen
+#define PL_reg_whilem_seen (*Perl_Treg_whilem_seen_ptr(aTHXo))
#undef PL_regbol
#define PL_regbol (*Perl_Tregbol_ptr(aTHXo))
#undef PL_regcc
OP *kkid = kid->op_sibling;
/* Can just relocate the target. */
- if (kkid && kkid->op_type == OP_PADSV) {
+ if (kkid && kkid->op_type == OP_PADSV
+ && !(kkid->op_private & OPpLVAL_INTRO))
+ {
/* Concat has problems if target is equal to right arg. */
if (kid->op_type == OP_CONCAT
&& kLISTOP->op_first->op_sibling->op_type == OP_PADSV
goto ignore_optimization;
} else {
o->op_targ = o->op_next->op_targ;
+ o->op_private |= OPpTARGET_MY;
}
}
null(o->op_next);
case OP_GREPWHILE:
case OP_AND:
case OP_OR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
o->op_seq = PL_op_seqmax++;
0x00000200, /* flop */
0x00000600, /* and */
0x00000600, /* or */
- 0x00022606, /* xor */
+ 0x00022406, /* xor */
0x00000640, /* cond_expr */
0x00000604, /* andassign */
0x00000604, /* orassign */
and logical and ck_null |
or logical or ck_null |
-xor logical xor ck_null fs| S S
+xor logical xor ck_null fs2 S S
cond_expr conditional expression ck_null d|
andassign logical and assignment ck_null s|
orassign logical or assignment ck_null s|
*-thread*) perl_fullversion="${perl_fullversion}-threaded";;
esac
-dll_post="`echo $perl_fullversion | sum | awk '{print $1}'`"
+dll_post="`echo $perl_fullversion | sum | sed -e 's/^0*//' | awk '{print $1}'`"
dll_post="`printf '%x' $dll_post | tr '[a-z]' '[A-Z]'`"
$spitshell >>Makefile <<!GROK!THIS!
$(LNS) $(PERL_DLL) t/$(PERL_DLL)
$(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT)
- $(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def
+ $(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def || ( rm $(PERL_DLL) && sh -c false )
-perl5.def: perl.linkexp
+perl5.olddef: perl.linkexp
echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE" > $@
echo DESCRIPTION "'Perl interpreter v$(PERL_FULLVERSION), export autogenerated, built with $(CONFIG_ARGS)'" >>$@
echo STACKSIZE 32768 >>$@
# We link miniperl statically, since .DLL depends on $(DYNALOADER)
-perl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT)
+miniperl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT)
$(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map
- awk '{if ($$3 == "") print $$2}' <miniperl.map | sort | uniq > perl.map
- rm miniperl.map
@./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
depend: os2ish.h dlfcn.h os2thread.h os2.c
---- Configure Wed Feb 25 16:52:55 1998
-+++ Configure.os2 Wed Feb 25 16:52:58 1998
-@@ -1602,7 +1602,7 @@
+--- Configure-pre Sun Jul 25 19:18:02 1999
++++ Configure Wed Jul 28 17:50:14 1999
+@@ -1528,6 +1528,11 @@ if test X"$trnl" = X; then
+ esac
+ fi
+ if test X"$trnl" = X; then
++ case "`echo foo|tr '\r' x 2>/dev/null`" in
++ foox) trnl='\r' ;;
++ esac
++fi
++if test X"$trnl" = X; then
+ cat <<EOM >&2
+
+ $me: Fatal Error: cannot figure out how to translate newlines with 'tr'.
+@@ -1844,7 +1849,7 @@ for file in $loclist; do
*)
echo "I don't know where '$file' is, and my life depends on it." >&4
echo "Go find a public domain implementation or fix your PATH setting!" >&4
;;
esac
done
-@@ -3637,7 +3637,7 @@
+@@ -3688,7 +3693,7 @@ int main() {
exit(0);
}
EOM
--if $cc -o gccvers gccvers.c >/dev/null 2>&1; then
-+if $cc -o gccvers gccvers.c $ldflags >/dev/null 2>&1; then
+-if $cc -o gccvers gccvers.c; then
++if $cc -o gccvers gccvers.c $ldflags; then
gccversion=`./gccvers`
case "$gccversion" in
'') echo "You are not using GNU cc." ;;
-@@ -4434,7 +4434,7 @@
+@@ -4892,7 +4897,7 @@ case "$libc" in
esac
;;
esac
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
+ Safefree(PL_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
#define VOIDUSED 1
#include "config.h"
+/* See L<perlguts/"The Perl API"> for detailed notes on
+ * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
+
/* XXXXXX testing threads via implicit pointer */
#ifdef USE_THREADS
# ifndef PERL_IMPLICIT_CONTEXT
# undef IV_IS_QUAD
# undef UV_IS_QUAD
# endif
+# define UV_SIZEOF LONGSIZE
+# define IV_SIZEOF LONGSIZE
#endif
#ifdef USE_LONG_DOUBLE
# endif
#endif
+#if defined(OS2)
+# include "iperlsys.h"
+#endif
+
#if defined(__OPEN_VM)
# include "vmesa/vmesaish.h"
#endif
# endif
#endif
-#if defined(CYGWIN32)
+#if defined(CYGWIN)
/* USEMYBINMODE
* This symbol, if defined, indicates that the program should
* use the routine my_binmode(FILE *fp, char iotype) to insure
*/
# define USEMYBINMODE / **/
# define my_binmode(fp, iotype) \
- (PerlLIO_setmode(PerlIO_fileno(fp), O_BINARY) != -1 ? TRUE : NULL)
+ (PerlLIO_setmode(PerlIO_fileno(fp), O_BINARY) != -1 ? TRUE : FALSE)
#endif
#ifdef UNION_ANY_DEFINITION
#define ARGSproto
#endif /* USE_THREADS */
-#if defined(CYGWIN32)
-/* USEMYBINMODE
- * This symbol, if defined, indicates that the program should
- * use the routine my_binmode(FILE *fp, char iotype) to insure
- * that a file is in "binary" mode -- that is, that no translation
- * of bytes occurs on read or write operations.
- */
-#define USEMYBINMODE / **/
-#define my_binmode(fp, iotype) \
- (PerlLIO_setmode(PerlIO_fileno(fp), O_BINARY) != -1 ? TRUE : FALSE)
-#endif
-
typedef I32 (*filter_t) (pTHXo_ int, SV *, int);
#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx])
#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters))
-#include "iperlsys.h"
+#if !defined(OS2)
+# include "iperlsys.h"
+#endif
#include "regexp.h"
#include "sv.h"
#include "util.h"
typedef struct magic_state MGS; /* struct magic_state defined in mg.c */
-/* Length of a variant. */
-
-typedef struct {
- I32 len_min;
- I32 len_delta;
- I32 pos_min;
- I32 pos_delta;
- SV *last_found;
- I32 last_end; /* min value, <0 unless valid. */
- I32 last_start_min;
- I32 last_start_max;
- SV **longest; /* Either &l_fixed, or &l_float. */
- SV *longest_fixed;
- I32 offset_fixed;
- SV *longest_float;
- I32 offset_float_min;
- I32 offset_float_max;
- I32 flags;
-} scan_data_t;
+struct scan_data_t; /* Used in S_* functions in regcomp.c */
typedef I32 CHECKPOINT;
EXT struct perl_vars PL_Vars;
EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
#else /* PERL_CORE */
-#if !defined(__GNUC__) || !(defined(WIN32) || defined(CYGWIN32))
+#if !defined(__GNUC__) || !(defined(WIN32) || defined(CYGWIN))
EXT
#endif /* WIN32 */
struct perl_vars *PL_VarsPtr;
#ifdef HAS_SETLINEBUF
#define PerlIO_setlinebuf(f) setlinebuf(f);
#else
-#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0);
+# ifdef CYGWIN
+# define PerlIO_setlinebuf(f)
+# else
+# define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0);
+# endif
#endif
/* Now our interface to Configure's FILE_xxx macros */
1) in DOS mode either the DOS or OS/2 ports can be used
2) formerly known as MVS
3) formerly known as Digital UNIX and before that DEC OSF/1
- 4) compilers: Borland, Cygwin32, Mingw32 EGCS/GCC, VC++
+ 4) compilers: Borland, Cygwin, Mingw32 EGCS/GCC, VC++
The following platforms have been known to build Perl from source,
but we haven't been able to verify their status for the current release,
This new build option provides a set of macros for all API functions
such that an implicit interpreter/thread context argument is passed to
every API function. As a result of this, something like C<sv_setsv(foo,bar)>
-amounts to a macro invocation that actually translates to
+amounts to a macro invocation that actually translates to something like
C<Perl_sv_setsv(my_perl,foo,bar)>. While this is generally expected
to not have any significant source compatibility issues, the difference
between a macro and a real function call will need to be considered.
+This means that there B<is> a source compatibility issue as a result of
+this if your extensions attempt to use pointers to any of the Perl API
+functions.
+
Note that the above issue is not relevant to the default build of
Perl, whose interfaces continue to match those of prior versions
(but subject to the other options described here).
PERL_IMPLICIT_CONTEXT whenever Perl is built with -Dusethreads or
-Dusemultiplicity.
+See L<perlguts/"The Perl API"> for detailed information on the
+ramifications of building Perl using this option.
+
=item C<PERL_POLLUTE_MALLOC>
Enabling Perl's malloc in release 5.005 and earlier caused
done in the subroutine peep(). Optimizations performed at this stage
are subject to the same restrictions as in the pass 2.
+=head1 The Perl API
+
+WARNING: This information is subject to radical changes prior to
+the Perl 5.6 release. Use with caution.
+
+=head2 Background and PERL_IMPLICIT_CONTEXT
+
+The Perl interpreter can be regarded as a closed box: it has an API
+for feeding it code or otherwise making it do things, but it also has
+functions for its own use. This smells a lot like an object, and
+there are ways for you to build Perl so that you can have multiple
+interpreters, with one interpreter represented either as a C++ object,
+a C structure, or inside a thread. The thread, the C structure, or
+the C++ object will contain all the context, the state of that
+interpreter.
+
+Four macros control the way Perl is built: PERL_IMPLICIT_CONTEXT
+(build for multiple interpreters?), MULTIPLICITY (we pass around an
+C interpreter structure as the first argument), USE_THREADS (we pass
+around a thread as the first argument), and PERL_OBJECT (we build a
+C++ class for the interpreter so the Perl API implementation has a
+C<this> object). If PERL_IMPLICIT_CONTEXT is not defined, then
+subroutines take no first argument.
+
+This obviously requires a way for the Perl internal functions to be
+C++ methods, subroutines taking some kind of structure as the first
+argument, or subroutines taking nothing as the first argument. To
+enable these three very different ways of building the interpreter,
+the Perl source (as it does in so many other situations) makes heavy
+use of macros and subroutine naming conventions.
+
+First problem: deciding which functions will be C++ public methods and
+which will be private. Those functions whose names begin C<Perl_> are
+public, and those whose names begin C<S_> are protected (think "S" for
+"Secret"). You can't call them from C++, and should not call them
+from C. If you find yourself calling an C<S_> function, consider your
+code broken (even though it works, it may not do so forever).
+
+Some functions have no prefix (e.g., restore_rsfp in toke.c). These
+are not parts of the object or pseudo-structure because you need to
+pass pointers to them to other subroutines.
+
+Second problem: there must be a syntax so that the same subroutine
+declarations and calls can pass a structure as their first argument,
+or pass nothing. To solve this, the subroutines are named and
+declared in a particular way. Here's a typical start of a static
+function used within the Perl guts:
+
+ STATIC void
+ S_incline(pTHX_ char *s)
+
+STATIC becomes "static" in C, and is #define'd to nothing in C++.
+
+A public function (i.e. part of the API) begins like this:
+
+ void
+ Perl_sv_setsv(pTHX_ SV* dsv, SV* ssv)
+
+C<pTHX_> is one of a number of macros (in perl.h) that hide the
+details of the interpreter's context. THX stands for "thread", "this",
+or "thingy", as the case may be. (And no, George Lucas is not involved. :-)
+The first character could be 'p' for a B<p>rototype, 'a' for B<a>rgument,
+or 'd' for B<d>eclaration.
+
+When Perl is built without PERL_IMPLICIT_CONTEXT, there is no first
+argument containing the interpreter's context. The trailing underscore
+in the pTHX_ macro indicates that the macro expansion needs a comma
+after the context argument because other arguments follow it. If
+PERL_IMPLICIT_CONTEXT is not defined, pTHX_ will be ignored, and the
+subroutine is not prototyped to take an argument. The form of the
+macro without the trailing underscore is used when there are no
+explicit arguments.
+
+When an core function calls another, it must pass the context. This
+is normally hidden via macros. Consider C<sv_setsv>. It expands
+something like this:
+
+ ifdef PERL_IMPLICIT_CONTEXT
+ define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a, b)
+ /* can't do this for vararg functions, see below */
+ else
+ define sv_setsv Perl_sv_setsv
+ endif
+
+This works well, and means that XS authors can gleefully write:
+
+ sv_setsv(foo, bar);
+
+and still have it work under all the modes Perl could have been
+compiled with.
+
+Under PERL_OBJECT in the core, that will translate to either:
+
+ CPerlObj::Perl_sv_setsv(foo,bar); # in CPerlObj functions,
+ # C++ takes care of 'this'
+ or
+
+ pPerl->Perl_sv_setsv(foo,bar); # in truly static functions,
+ # see objXSUB.h
+
+Under PERL_OBJECT in extensions (aka PERL_CAPI), or under
+MULTIPLICITY/USE_THREADS w/ PERL_IMPLICIT_CONTEXT in both core
+and extensions, it will be:
+
+ Perl_sv_setsv(aTHX_ foo, bar); # the canonical Perl "API"
+ # for all build flavors
+
+This doesn't work so cleanly for varargs functions, though, as macros
+imply that the number of arguments is known in advance. Instead we
+either need to spell them out fully, passing C<aTHX_> as the first
+argument (the Perl core tends to do this with functions like
+Perl_warner), or use a context-free version.
+
+The context-free version of Perl_warner is called
+Perl_warner_nocontext, and does not take the extra argument. Instead
+it does dTHX; to get the context from thread-local storage. We
+C<#define warner Perl_warner_nocontext> so that extensions get source
+compatibility at the expense of performance. (Passing an arg is
+cheaper than grabbing it from thread-local storage.)
+
+You can ignore [pad]THX[xo] when browsing the Perl headers/sources.
+Those are strictly for use within the core. Extensions and embedders
+need only be aware of [pad]THX.
+
+=head2 How do I use all this in extensions?
+
+When Perl is built with PERL_IMPLICIT_CONTEXT, extensions that call
+any functions in the Perl API will need to pass the initial context
+argument somehow. The kicker is that you will need to write it in
+such a way that the extension still compiles when Perl hasn't been
+built with PERL_IMPLICIT_CONTEXT enabled.
+
+There are three ways to do this. First, the easy but inefficient way,
+which is also the default, in order to maintain source compatibility
+with extensions: whenever XSUB.h is #included, it redefines the aTHX
+and aTHX_ macros to call a function that will return the context.
+Thus, something like:
+
+ sv_setsv(asv, bsv);
+
+in your extesion will translate to this:
+
+ Perl_sv_setsv(GetPerlInterpreter(), asv, bsv);
+
+when PERL_IMPLICIT_CONTEXT is in effect, or to this otherwise:
+
+ Perl_sv_setsv(asv, bsv);
+
+You have to do nothing new in your extension to get this; since
+the Perl library provides GetPerlInterpreter(), it will all just
+work.
+
+The second, more efficient way is to use the following template for
+your Foo.xs:
+
+ #define PERL_NO_GET_CONTEXT /* we want efficiency */
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ static my_private_function(int arg1, int arg2);
+
+ static SV *
+ my_private_function(pTHX_ int arg1, int arg2)
+ {
+ dTHX; /* fetch context */
+ ... call many Perl API functions ...
+ }
+
+ [... etc ...]
+
+ MODULE = Foo PACKAGE = Foo
+
+ /* typical XSUB */
+
+ void
+ my_xsub(arg)
+ int arg
+ CODE:
+ my_private_function(arg, 10);
+
+Note that the only two changes from the normal way of writing an
+extension is the addition of a C<#define PERL_NO_GET_CONTEXT> before
+including the Perl headers, followed by a C<dTHX;> declaration at
+the start of every function that will call the Perl API. (You'll
+know which functions need this, because the C compiler will complain
+that there's an undeclared identifier in those functions.) No changes
+are needed for the XSUBs themselves, because the XS() macro is
+correctly defined to pass in the implicit context if needed.
+
+The third, even more efficient way is to ape how it is done within
+the Perl guts:
+
+
+ #define PERL_NO_GET_CONTEXT /* we want efficiency */
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ /* pTHX_ only needed for functions that call Perl API */
+ static my_private_function(pTHX_ int arg1, int arg2);
+
+ static SV *
+ my_private_function(pTHX_ int arg1, int arg2)
+ {
+ /* dTHX; not needed here, because THX is an argument */
+ ... call Perl API functions ...
+ }
+
+ [... etc ...]
+
+ MODULE = Foo PACKAGE = Foo
+
+ /* typical XSUB */
+
+ void
+ my_xsub(arg)
+ int arg
+ CODE:
+ my_private_function(aTHX_ arg, 10);
+
+This implementation never has to fetch the context using a function
+call, since it is always passed as an extra argument. Depending on
+your needs for simplicity or efficiency, you may mix the previous
+two approaches freely.
+
+Never say C<pTHX,> yourself--always use the form of the macro with the
+underscore for functions that take explicit arguments, or the form
+without the argument for functions with no explicit arguments.
+
+=head2 Future Plans and PERL_IMPLICIT_SYS
+
+Just as PERL_IMPLICIT_CONTEXT provides a way to bundle up everything
+that the interpreter knows about itself and pass it around, so too are
+there plans to allow the interpreter to bundle up everything it knows
+about the environment it's running on. This is enabled with the
+PERL_IMPLICIT_SYS macro. Currently it only works with PERL_OBJECT,
+but is mostly there for MULTIPLICITY and USE_THREADS (see inside
+iperlsys.h).
+
+This allows the ability to provide an extra pointer (called the "host"
+environment) for all the system calls. This makes it possible for
+all the system stuff to maintain their own state, broken down into
+seven C structures. These are thin wrappers around the usual system
+calls (see win32/perllib.c) for the default perl executable, but for a
+more ambitious host (like the one that would do fork() emulation) all
+the extra work needed to pretend that different interpreters are
+actually different "processes", would be done here.
+
+The Perl engine/interpreter and the host are orthogonal entities.
+There could be one or more interpreters in a process, and one or
+more "hosts", with free association between them.
+
=head1 API LISTING
This is a listing of functions, macros, flags, and variables that may be
Note that all Perl API global variables must be referenced with the C<PL_>
prefix. Some macros are provided for compatibility with the older,
-unadorned names, but this support will be removed in a future release.
-
-It is strongly recommended that all Perl API functions that don't begin
-with C<perl> be referenced with an explicit C<Perl_> prefix.
+unadorned names, but this support may be disabled in a future release.
The sort order of the listing is case insensitive, with any
occurrences of '_' ignored for the purpose of sorting.
=item The ActiveState Pages, C<http://www.activestate.com/>
-=item The Cygwin32 environment for Win32; L<README.cygwin32>,
-C<http://www.cygnus.com/misc/gnu-win32/>
+=item The Cygwin environment for Win32; L<README.cygwin>,
+C<http://sourceware.cygnus.com/cygwin/>
=item The U/WIN environment for Win32,
C<http://www.research.att.com/sw/tools/uwin/>
# perl4 prints:
# perl5 dies: hash %h defined
+Perl will now generate a warning when it sees defined(@a) and
+defined(%h).
+
=item * (Globs)
glob assignment from variable to variable will fail if the assigned
PP(pp_wait)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
djSP; dTARGET;
Pid_t childpid;
int argflags;
PP(pp_waitpid)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
djSP; dTARGET;
Pid_t childpid;
int optype;
PP(pp_spwent)
{
djSP;
-#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
+#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN)
setpwent();
# ifdef HAS_SETSPENT
setspent();
STATIC char* S_regwhite(pTHX_ char *, char *);
STATIC char* S_nextchar(pTHX);
STATIC regnode* S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l);
-STATIC void S_scan_commit(pTHX_ scan_data_t *data);
-STATIC I32 S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags);
+STATIC void S_scan_commit(pTHX_ struct scan_data_t *data);
+STATIC I32 S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, struct scan_data_t *data, U32 flags);
STATIC I32 S_add_data(pTHX_ I32 n, char *s);
STATIC void S_re_croak2(pTHX_ const char* pat1, const char* pat2, ...) __attribute__((noreturn));
STATIC I32 S_regpposixcc(pTHX_ I32 value);
#define SPSTART 0x4 /* Starts with * or +. */
#define TRYAGAIN 0x8 /* Weeded out a declaration. */
+/* Length of a variant. */
+
+typedef struct scan_data_t {
+ I32 len_min;
+ I32 len_delta;
+ I32 pos_min;
+ I32 pos_delta;
+ SV *last_found;
+ I32 last_end; /* min value, <0 unless valid. */
+ I32 last_start_min;
+ I32 last_start_max;
+ SV **longest; /* Either &l_fixed, or &l_float. */
+ SV *longest_fixed;
+ I32 offset_fixed;
+ SV *longest_float;
+ I32 offset_float_min;
+ I32 offset_float_max;
+ I32 flags;
+ I32 whilem_c;
+} scan_data_t;
+
/*
* Forward declarations for pregcomp()'s friends.
*/
static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0 };
+ 0, 0, 0, 0 };
#define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
#define SF_BEFORE_SEOL 0x1
num++;
data_fake.flags = 0;
+ if (data)
+ data_fake.whilem_c = data->whilem_c;
next = regnext(scan);
scan = NEXTOPER(scan);
if (code != BRANCH)
pars++;
if (data && (data_fake.flags & SF_HAS_EVAL))
data->flags |= SF_HAS_EVAL;
+ if (data)
+ data->whilem_c = data_fake.whilem_c;
if (code == SUSPEND)
break;
}
else
oscan->flags = 0;
}
+ else if (OP(oscan) == CURLYX && data && ++data->whilem_c < 16) {
+ /* This stays as CURLYX, and can put the count/of pair. */
+ /* Find WHILEM (as in regexec.c) */
+ regnode *nxt = oscan + NEXT_OFF(oscan);
+
+ if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
+ nxt += ARG(nxt);
+ PREVOPER(nxt)->flags = data->whilem_c
+ | (PL_reg_whilem_seen << 4); /* On WHILEM */
+ }
if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
pars++;
if (flags & SCF_DO_SUBSTR) {
regnode *nscan;
data_fake.flags = 0;
+ if (data)
+ data_fake.whilem_c = data->whilem_c;
next = regnext(scan);
nscan = NEXTOPER(NEXTOPER(scan));
minnext = study_chunk(&nscan, &deltanext, last, &data_fake, 0);
pars++;
if (data && (data_fake.flags & SF_HAS_EVAL))
data->flags |= SF_HAS_EVAL;
+ if (data)
+ data->whilem_c = data_fake.whilem_c;
}
else if (OP(scan) == OPEN) {
pars++;
I32 minlen = 0;
I32 sawplus = 0;
I32 sawopen = 0;
+ scan_data_t data;
if (exp == NULL)
FAIL("NULL regexp argument");
PL_regprecomp = savepvn(exp, xend - exp);
DEBUG_r(if (!PL_colorset) reginitcolors());
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling%s RE `%s%*s%s'\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
PL_colors[4],PL_colors[5],PL_colors[0],
xend - exp, PL_regprecomp, PL_colors[1]));
PL_regflags = pm->op_pmflags;
PL_regnpar = 1;
PL_regsize = 0L;
PL_regcode = &PL_regdummy;
+ PL_reg_whilem_seen = 0;
regc((U8)REG_MAGIC, (char*)PL_regcode);
if (reg(0, &flags) == NULL) {
Safefree(PL_regprecomp);
PL_regsize += PL_extralen;
else
PL_extralen = 0;
+ if (PL_reg_whilem_seen > 15)
+ PL_reg_whilem_seen = 15;
/* Allocate space and initialize. */
Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode),
3-units-long substrs field. */
Newz(1004, r->substrs, 1, struct reg_substr_data);
+ StructCopy(&zero_scan_data, &data, scan_data_t);
if (OP(scan) != BRANCH) { /* Only one top-level choice. */
- scan_data_t data;
I32 fake;
STRLEN longest_float_length, longest_fixed_length;
- StructCopy(&zero_scan_data, &data, scan_data_t);
first = scan;
/* Skip introductions and multiplicators >= 1. */
while ((OP(first) == OPEN && (sawopen = 1)) ||
DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
scan = r->program + 1;
- minlen = study_chunk(&scan, &fake, scan + PL_regsize, NULL, 0);
+ minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, 0);
r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
}
reginsert(CURLY, ret);
}
else {
- PL_regnaughty += 4 + PL_regnaughty; /* compound interest */
- regtail(ret, reg_node(WHILEM));
+ regnode *w = reg_node(WHILEM);
+
+ w->flags = 0;
+ regtail(ret, w);
if (!SIZE_ONLY && PL_extralen) {
reginsert(LONGJMP,ret);
reginsert(NOTHING,ret);
NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
regtail(ret, reg_node(NOTHING));
if (SIZE_ONLY)
- PL_extralen += 3;
+ PL_reg_whilem_seen++, PL_extralen += 3;
+ PL_regnaughty += 4 + PL_regnaughty; /* compound interest */
}
ret->flags = 0;
/* Header fields of interest. */
if (r->anchored_substr)
- PerlIO_printf(Perl_debug_log, "anchored `%s%s%s'%s at %d ",
+ PerlIO_printf(Perl_debug_log, "anchored `%s%.*s%s'%s at %d ",
PL_colors[0],
+ SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0),
SvPVX(r->anchored_substr),
PL_colors[1],
SvTAIL(r->anchored_substr) ? "$" : "",
r->anchored_offset);
if (r->float_substr)
- PerlIO_printf(Perl_debug_log, "floating `%s%s%s'%s at %d..%u ",
+ PerlIO_printf(Perl_debug_log, "floating `%s%.*s%s'%s at %d..%u ",
PL_colors[0],
- SvPVX(r->float_substr),
+ SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0),
+ SvPVX(r->float_substr),
PL_colors[1],
SvTAIL(r->float_substr) ? "$" : "",
r->float_min_offset, r->float_max_offset);
Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
}
+ else if (k == WHILEM && o->flags) /* Ordinal/of */
+ Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
Perl_sv_catpvf(aTHX_ sv, "%d", ARG(o)); /* Parenth number */
else if (k == LOGICAL)
/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
-/* If SCREAM, then sv should be compatible with strpos and strend.
+/* If SCREAM, then SvPVX(sv) should be compatible with strpos and strend.
Otherwise, only SvCUR(sv) is used to get strbeg. */
/* XXXX We assume that strpos is strbeg unless sv. */
+/* A failure to find a constant substring means that there is no need to make
+ an expensive call to REx engine, thus we celebrate a failure. Similarly,
+ finding a substring too deep into the string means that less calls to
+ regtry() should be needed. */
+
char *
Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
char *strend, U32 flags, re_scream_pos_data *data)
{
- I32 start_shift;
+ register I32 start_shift;
/* Should be nonnegative! */
- I32 end_shift;
- char *s;
+ register I32 end_shift;
+ register char *s;
+ register SV *check;
char *t;
I32 ml_anch;
+ char *tmp;
+ register char *other_last = Nullch;
DEBUG_r( if (!PL_colorset) reginitcolors() );
DEBUG_r(PerlIO_printf(Perl_debug_log,
- "%sGuessing start of match:%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
+ "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
PL_colors[4],PL_colors[5],PL_colors[0],
prog->precomp,
PL_colors[1],
(strend - strpos > 60 ? "..." : ""))
);
- if (prog->minlen > strend - strpos)
+ if (prog->minlen > strend - strpos) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
goto fail;
-
- /* XXXX Move further down? */
- start_shift = prog->check_offset_min; /* okay to underestimate on CC */
- /* Should be nonnegative! */
- end_shift = prog->minlen - start_shift -
- CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
-
- if (prog->reganch & ROPT_ANCH) {
+ }
+ if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
|| ( (prog->reganch & ROPT_ANCH_BOL)
- && !PL_multiline ) );
+ && !PL_multiline ) ); /* Check after \n? */
if ((prog->check_offset_min == prog->check_offset_max) && !ml_anch) {
- /* Anchored... */
+ /* Substring at constant offset from beg-of-str... */
I32 slen;
if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
- && (sv && (strpos + SvCUR(sv) != strend)) )
+ && (sv && (strpos + SvCUR(sv) != strend)) ) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
goto fail;
-
+ }
PL_regeol = strend; /* Used in HOP() */
- s = (char*)HOP((U8*)strpos, prog->check_offset_min);
+ s = HOPc(strpos, prog->check_offset_min);
if (SvTAIL(prog->check_substr)) {
slen = SvCUR(prog->check_substr); /* >= 1 */
- if ( strend - s > slen || strend - s < slen - 1 ) {
- s = Nullch;
- goto finish;
- }
- if ( strend - s == slen && strend[-1] != '\n') {
- s = Nullch;
- goto finish;
+ if ( strend - s > slen || strend - s < slen - 1
+ || (strend - s == slen && strend[-1] != '\n')) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
+ goto fail_finish;
}
/* Now should match s[0..slen-2] */
slen--;
if (slen && (*SvPVX(prog->check_substr) != *s
|| (slen > 1
- && memNE(SvPVX(prog->check_substr), s, slen))))
- s = Nullch;
+ && memNE(SvPVX(prog->check_substr), s, slen)))) {
+ report_neq:
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
+ goto fail_finish;
+ }
}
else if (*SvPVX(prog->check_substr) != *s
|| ((slen = SvCUR(prog->check_substr)) > 1
&& memNE(SvPVX(prog->check_substr), s, slen)))
- s = Nullch;
- else
- s = strpos;
- goto finish;
+ goto report_neq;
+ goto success_at_start;
}
+ /* Match is anchored, but substr is not anchored wrt beg-of-str. */
s = strpos;
- if (!ml_anch && (s + prog->check_offset_max < strend - prog->minlen))
- end_shift += strend - s - prog->minlen - prog->check_offset_max;
+ start_shift = prog->check_offset_min; /* okay to underestimate on CC */
+ /* Should be nonnegative! */
+ end_shift = prog->minlen - start_shift -
+ CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
+ if (!ml_anch) {
+ I32 end = prog->check_offset_max + CHR_SVLEN(prog->check_substr)
+ - (SvTAIL(prog->check_substr) != 0);
+ I32 eshift = strend - s - end;
+
+ if (end_shift < eshift)
+ end_shift = eshift;
+ }
}
- else {
+ else { /* Can match at random position */
ml_anch = 0;
s = strpos;
+ start_shift = prog->check_offset_min; /* okay to underestimate on CC */
+ /* Should be nonnegative! */
+ end_shift = prog->minlen - start_shift -
+ CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
}
- restart:
+#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
- end_shift = 0; /* can happen when strend == strpos */
+ croak("panic: end_shift");
+#endif
+
+ check = prog->check_substr;
+ restart:
+ /* Find a possible match in the region s..strend by looking for
+ the "check" substring in the region corrected by start/end_shift. */
if (flags & REXEC_SCREAM) {
- SV *c = prog->check_substr;
char *strbeg = SvPVX(sv); /* XXXX Assume PV_force() on SCREAM! */
I32 p = -1; /* Internal iterator of scream. */
I32 *pp = data ? data->scream_pos : &p;
- if (PL_screamfirst[BmRARE(c)] >= 0
- || ( BmRARE(c) == '\n'
- && (BmPREVIOUS(c) == SvCUR(c) - 1)
- && SvTAIL(c) ))
- s = screaminstr(sv, prog->check_substr,
- start_shift + (strpos - strbeg), end_shift, pp, 0);
+ if (PL_screamfirst[BmRARE(check)] >= 0
+ || ( BmRARE(check) == '\n'
+ && (BmPREVIOUS(check) == SvCUR(check) - 1)
+ && SvTAIL(check) ))
+ s = screaminstr(sv, check,
+ start_shift + (s - strbeg), end_shift, pp, 0);
else
- s = Nullch;
+ goto fail_finish;
if (data)
*data->scream_olds = s;
}
else
s = fbm_instr((unsigned char*)s + start_shift,
(unsigned char*)strend - end_shift,
- prog->check_substr, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, PL_multiline ? FBMrf_MULTILINE : 0);
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
- finish:
- if (!s) {
- ++BmUSEFUL(prog->check_substr); /* hooray */
- goto fail; /* not present */
+
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
+ (s ? "Found" : "Did not find"),
+ ((check == prog->anchored_substr) ? "anchored" : "floating"),
+ PL_colors[0],
+ SvCUR(check) - (SvTAIL(check)!=0), SvPVX(check),
+ PL_colors[1], (SvTAIL(check) ? "$" : ""),
+ (s ? " at offset " : "...\n") ) );
+
+ if (!s)
+ goto fail_finish;
+
+ /* Finish the diagnostic message */
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - strpos)) );
+
+ /* Got a candidate. Check MBOL anchoring, and the *other* substr.
+ Start with the other substr.
+ XXXX no SCREAM optimization yet - and a very coarse implementation
+ XXXX /ttx+/ results in anchored=`ttx', floating=`x'. floating will
+ *always* match. Probably should be marked during compile...
+ Probably it is right to do no SCREAM here...
+ */
+
+ if (prog->float_substr && prog->anchored_substr) {
+ /* Take into account the anchored substring. */
+ /* XXXX May be hopelessly wrong for UTF... */
+ if (!other_last)
+ other_last = strpos - 1;
+ if (check == prog->float_substr) {
+ char *last = s - start_shift, *last1, *last2;
+ char *s1 = s;
+
+ tmp = PL_bostr;
+ t = s - prog->check_offset_max;
+ if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
+ && (!(prog->reganch & ROPT_UTF8)
+ || (PL_bostr = strpos, /* Used in regcopmaybe() */
+ (t = reghopmaybe_c(s, -(prog->check_offset_max)))
+ && t > strpos)))
+ ;
+ else
+ t = strpos;
+ t += prog->anchored_offset;
+ if (t <= other_last)
+ t = other_last + 1;
+ PL_bostr = tmp;
+ last2 = last1 = strend - prog->minlen;
+ if (last < last1)
+ last1 = last;
+ /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
+ /* On end-of-str: see comment below. */
+ s = fbm_instr((unsigned char*)t,
+ (unsigned char*)last1 + prog->anchored_offset
+ + SvCUR(prog->anchored_substr)
+ - (SvTAIL(prog->anchored_substr)!=0),
+ prog->anchored_substr, PL_multiline ? FBMrf_MULTILINE : 0);
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s anchored substr `%s%.*s%s'%s",
+ (s ? "Found" : "Contradicts"),
+ PL_colors[0],
+ SvCUR(prog->anchored_substr)
+ - (SvTAIL(prog->anchored_substr)!=0),
+ SvPVX(prog->anchored_substr),
+ PL_colors[1], (SvTAIL(prog->anchored_substr) ? "$" : "")));
+ if (!s) {
+ if (last1 >= last2) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ ", giving up...\n"));
+ goto fail_finish;
+ }
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ ", trying floating at offset %ld...\n",
+ (long)(s1 + 1 - strpos)));
+ PL_regeol = strend; /* Used in HOP() */
+ other_last = last1 + prog->anchored_offset;
+ s = HOPc(last, 1);
+ goto restart;
+ }
+ else {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
+ (long)(s - strpos)));
+ t = s - prog->anchored_offset;
+ other_last = s - 1;
+ if (t == strpos)
+ goto try_at_start;
+ s = s1;
+ goto try_at_offset;
+ }
+ }
+ else { /* Take into account the floating substring. */
+ char *last, *last1;
+ char *s1 = s;
+
+ t = s - start_shift;
+ last1 = last = strend - prog->minlen + prog->float_min_offset;
+ if (last - t > prog->float_max_offset)
+ last = t + prog->float_max_offset;
+ s = t + prog->float_min_offset;
+ if (s <= other_last)
+ s = other_last + 1;
+ /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
+ /* fbm_instr() takes into account exact value of end-of-str
+ if the check is SvTAIL(ed). Since false positives are OK,
+ and end-of-str is not later than strend we are OK. */
+ s = fbm_instr((unsigned char*)s,
+ (unsigned char*)last + SvCUR(prog->float_substr)
+ - (SvTAIL(prog->float_substr)!=0),
+ prog->float_substr, PL_multiline ? FBMrf_MULTILINE : 0);
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
+ (s ? "Found" : "Contradicts"),
+ PL_colors[0],
+ SvCUR(prog->float_substr)
+ - (SvTAIL(prog->float_substr)!=0),
+ SvPVX(prog->float_substr),
+ PL_colors[1], (SvTAIL(prog->float_substr) ? "$" : "")));
+ if (!s) {
+ if (last1 == last) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ ", giving up...\n"));
+ goto fail_finish;
+ }
+ DEBUG_r(PerlIO_printf(Perl_debug_log,
+ ", trying anchored starting at offset %ld...\n",
+ (long)(s1 + 1 - strpos)));
+ other_last = last;
+ PL_regeol = strend; /* Used in HOP() */
+ s = HOPc(t, 1);
+ goto restart;
+ }
+ else {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
+ (long)(s - strpos)));
+ other_last = s - 1;
+ if (t == strpos)
+ goto try_at_start;
+ s = s1;
+ goto try_at_offset;
+ }
+ }
}
- else if (s - strpos > prog->check_offset_max &&
- ((prog->reganch & ROPT_UTF8)
- ? ((t = reghopmaybe_c(s, -(prog->check_offset_max)))
- && t >= strpos)
- : (t = s - prog->check_offset_max) != 0) ) {
+
+ t = s - prog->check_offset_max;
+ tmp = PL_bostr;
+ if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
+ && (!(prog->reganch & ROPT_UTF8)
+ || (PL_bostr = strpos, /* Used in regcopmaybe() */
+ ((t = reghopmaybe_c(s, -(prog->check_offset_max)))
+ && t > strpos)))) {
+ PL_bostr = tmp;
+ /* Fixed substring is found far enough so that the match
+ cannot start at strpos. */
+ try_at_offset:
if (ml_anch && t[-1] != '\n') {
- find_anchor:
- while (t < strend - end_shift - prog->minlen) {
+ find_anchor: /* Eventually fbm_*() should handle this */
+ while (t < strend - prog->minlen) {
if (*t == '\n') {
if (t < s - prog->check_offset_min) {
s = t + 1;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
+ PL_colors[0],PL_colors[1], (long)(s - strpos)));
goto set_useful;
}
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n",
+ PL_colors[0],PL_colors[1], (long)(t + 1 - strpos)));
s = t + 1;
goto restart;
}
t++;
}
- s = Nullch;
- goto finish;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
+ PL_colors[0],PL_colors[1]));
+ goto fail_finish;
}
s = t;
set_useful:
- ++BmUSEFUL(prog->check_substr); /* hooray/2 */
+ ++BmUSEFUL(prog->check_substr); /* hooray/5 */
}
else {
- if (ml_anch && sv
+ PL_bostr = tmp;
+ /* The found string does not prohibit matching at beg-of-str
+ - no optimization of calling REx engine can be performed,
+ unless it was an MBOL and we are not after MBOL. */
+ try_at_start:
+ /* Even in this situation we may use MBOL flag if strpos is offset
+ wrt the start of the string. */
+ if (ml_anch && sv
&& (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n') {
t = strpos;
goto find_anchor;
}
+ success_at_start:
if (!(prog->reganch & ROPT_NAUGHTY)
&& --BmUSEFUL(prog->check_substr) < 0
&& prog->check_substr == prog->float_substr) { /* boo */
s = strpos;
}
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sFound%s at offset %ld\n",
- PL_colors[4],PL_colors[5], (long)(s - strpos)) );
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n",
+ PL_colors[4], PL_colors[5], (long)(s - strpos)) );
return s;
+
+ fail_finish: /* Substring not found */
+ BmUSEFUL(prog->check_substr) += 5; /* hooray */
fail:
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sNot found...%s\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
PL_colors[4],PL_colors[5]));
return Nullch;
}
PL_reg_flags = 0;
PL_reg_eval_set = 0;
+ PL_reg_maxiter = 0;
if (prog->reganch & ROPT_UTF8)
PL_reg_flags |= RF_utf8;
DEBUG_r( if (!PL_colorset) reginitcolors() );
DEBUG_r(PerlIO_printf(Perl_debug_log,
- "%sMatching%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
+ "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
PL_colors[4],PL_colors[5],PL_colors[0],
prog->precomp,
PL_colors[1],
case REFF:
n = ARG(scan); /* which paren pair */
ln = PL_regstartp[n];
+ PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
if (*PL_reglastparen < n || ln == -1)
sayNO; /* Do not match unless seen CLOSEn. */
if (ln == PL_regendp[n])
*PL_reglastparen = 0;
PL_reg_call_cc = &state;
PL_reginput = locinput;
+
+ /* XXXX This is too dramatic a measure... */
+ PL_reg_maxiter = 0;
+
if (regmatch(re->program + 1)) {
ReREFCNT_dec(re);
regcpblow(cp);
PL_regcc = state.cc;
PL_reg_re = state.re;
cache_re(PL_reg_re);
+
+ /* XXXX This is too dramatic a measure... */
+ PL_reg_maxiter = 0;
+
sayNO;
}
sw = SvTRUE(ret);
sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
break;
case IFTHEN:
+ PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
if (sw)
next = NEXTOPER(NEXTOPER(scan));
else {
/*
* This is really hard to understand, because after we match
* what we're trying to match, we must make sure the rest of
- * the RE is going to match for sure, and to do that we have
+ * the REx is going to match for sure, and to do that we have
* to go back UP the parse tree by recursing ever deeper. And
* if it fails, we have to reset our parent's current state
* that we can try again after backing off.
sayNO;
}
+ if (scan->flags) {
+ /* Check whether we already were at this position.
+ Postpone detection until we know the match is not
+ *that* much linear. */
+ if (!PL_reg_maxiter) {
+ PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
+ PL_reg_leftiter = PL_reg_maxiter;
+ }
+ if (PL_reg_leftiter-- == 0) {
+ I32 size = (PL_reg_maxiter + 7)/8;
+ if (PL_reg_poscache) {
+ if (PL_reg_poscache_size < size) {
+ Renew(PL_reg_poscache, size, char);
+ PL_reg_poscache_size = size;
+ }
+ Zero(PL_reg_poscache, size, char);
+ }
+ else {
+ PL_reg_poscache_size = size;
+ Newz(29, PL_reg_poscache, size, char);
+ }
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%sDetected a super-linear match, switching on caching%s...\n",
+ PL_colors[4], PL_colors[5])
+ );
+ }
+ if (PL_reg_leftiter < 0) {
+ I32 o = locinput - PL_bostr, b;
+
+ o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
+ b = o % 8;
+ o /= 8;
+ if (PL_reg_poscache[o] & (1<<b)) {
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s already tried at this position...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ sayNO;
+ }
+ PL_reg_poscache[o] |= (1<<b);
+ }
+ }
+
/* Prefer next over scan for minimal matching. */
if (cc->minmod) {
#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
-#if !defined(DOSISH) || defined(WIN32)
+#if !defined(DOSISH) || defined(WIN32) || defined(OS2)
# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
# define Sv_Grow sv_grow
#else
use DB_File;
use Fcntl;
-print "1..148\n";
+print "1..155\n";
sub ok
{
return @a - @b ;
}
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ wantarray ? @result : join("", @result) ;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ wantarray ? @result : join("", @result) ;
+}
+
+
my $Dfile = "dbbtree.tmp";
unlink $Dfile;
}
+{
+ # Examples from the POD
+
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 1
+ ###
+
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # 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" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+ unlink "tree" ;
+ }
+
+ delete $DB_BTREE->{'compare'} ;
+
+ ok(149, docat_del($file) eq <<'EOM') ;
+mouse
+Smith
+Wall
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 2
+ ###
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename %h ) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the associative array
+ # and print each key/value pair.
+ foreach (keys %h)
+ { print "$_ -> $h{$_}\n" }
+
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(150, docat_del($file) eq ($DB_File::db_version == 1 ? <<'EOM' : <<'EOM') ) ;
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
+EOM
+Smith -> John
+Wall -> Larry
+Wall -> Larry
+Wall -> Larry
+mouse -> mickey
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 3
+ ###
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $status $key $value) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # 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";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the btree using seq
+ # and print each key/value pair.
+ $key = $value = 0 ;
+ for ($status = $x->seq($key, $value, R_FIRST) ;
+ $status == 0 ;
+ $status = $x->seq($key, $value, R_NEXT) )
+ { print "$key -> $value\n" }
+
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(151, docat_del($file) eq ($DB_File::db_version == 1 ? <<'EOM' : <<'EOM') ) ;
+Smith -> John
+Wall -> Brick
+Wall -> Brick
+Wall -> Larry
+mouse -> mickey
+EOM
+Smith -> John
+Wall -> Larry
+Wall -> Brick
+Wall -> Brick
+mouse -> mickey
+EOM
+
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 4
+ ###
+
+ 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" ;
+
+ my %hash = $x->get_dup("Wall", 1) ;
+ print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
+
+ my @list = sort $x->get_dup("Wall") ;
+ print "Wall => [@list]\n" ;
+
+ @list = $x->get_dup("Smith") ;
+ print "Smith => [@list]\n" ;
+
+ @list = $x->get_dup("Dog") ;
+ print "Dog => [@list]\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(152, docat_del($file) eq <<'EOM') ;
+Wall occurred 3 times
+Larry is there
+There are 2 Brick Walls
+Wall => [Brick Brick Larry]
+Smith => [John]
+Dog => []
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 5
+ ###
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $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";
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ print "Harry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+ }
+
+ ok(153, docat_del($file) eq <<'EOM') ;
+Larry Wall is there
+Harry Wall is not there
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 6
+ ###
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $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";
+
+ $x->del_dup("Wall", "Larry") ;
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+ }
+
+ ok(154, docat_del($file) eq <<'EOM') ;
+Larry Wall is not there
+EOM
+
+ {
+ my $redirect = new Redirect $file ;
+
+ # BTREE example 7
+ ###
+
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ use vars qw($filename $x %h $st $key $value) ;
+
+ sub match
+ {
+ my $key = shift ;
+ my $value = 0;
+ my $orig_key = $key ;
+ $x->seq($key, $value, R_CURSOR) ;
+ print "$orig_key\t-> $key\t-> $value\n" ;
+ }
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'mouse'} = 'mickey' ;
+ $h{'Wall'} = 'Larry' ;
+ $h{'Walls'} = 'Brick' ;
+ $h{'Smith'} = 'John' ;
+
+
+ $key = $value = 0 ;
+ print "IN ORDER\n" ;
+ for ($st = $x->seq($key, $value, R_FIRST) ;
+ $st == 0 ;
+ $st = $x->seq($key, $value, R_NEXT) )
+
+ { print "$key -> $value\n" }
+
+ print "\nPARTIAL MATCH\n" ;
+
+ match "Wa" ;
+ match "A" ;
+ match "a" ;
+
+ undef $x ;
+ untie %h ;
+
+ unlink $filename ;
+
+ }
+
+ ok(155, docat_del($file) eq <<'EOM') ;
+IN ORDER
+Smith -> John
+Wall -> Larry
+Walls -> Brick
+mouse -> mickey
+
+PARTIAL MATCH
+Wa -> Wall -> Larry
+A -> Smith -> John
+a -> mouse -> mickey
+EOM
+
+}
+
exit ;
use DB_File;
use Fcntl;
-print "1..108\n";
+print "1..109\n";
sub ok
{
print "ok $no\n" ;
}
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+}
+
my $Dfile = "dbhash.tmp";
unlink $Dfile;
unlink $Dfile;
}
+
+{
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use strict ;
+ 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";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+ unlink "fruit" ;
+ }
+
+ ok(109, docat_del($file) eq <<'EOM') ;
+Banana Exists
+
+orange -> orange
+tomato -> red
+banana -> yellow
+EOM
+
+}
+
exit ;
return $result ;
}
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+}
+
sub bad_one
{
print STDERR <<EOM unless $bad_ones++ ;
EOM
}
-print "1..124\n";
+print "1..126\n";
my $Dfile = "recno.tmp";
unlink $Dfile ;
unlink $Dfile;
-sub docat
-{
- my $file = shift;
- local $/ = undef;
- open(CAT,$file) || die "Cannot open $file:$!";
- my $result = <CAT>;
- close(CAT);
- return $result;
-}
-
{
# Check bval defaults to \n
unlink $Dfile;
}
+
+{
+ # Examples from the POD
+
+ my $file = "xyzt" ;
+ {
+ my $redirect = new Redirect $file ;
+
+ use strict ;
+ use DB_File ;
+
+ my $filename = "text" ;
+ unlink $filename ;
+
+ my @h ;
+ my $x = 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
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ $FA ? push @h, "green", "black"
+ : $x->push("green", "black") ;
+
+ my $elements = $FA ? scalar @h : $x->length ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = $FA ? pop @h : $x->pop ;
+ print "popped $last\n" ;
+
+ $FA ? unshift @h, "white"
+ : $x->unshift("white") ;
+ my $first = $FA ? shift @h : $x->shift ;
+ print "shifted $first\n" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ # use a negative index
+ print "The last element is $h[-1]\n" ;
+ print "The 2nd last element is $h[-2]\n" ;
+
+ undef $x ;
+ untie @h ;
+
+ unlink $filename ;
+ }
+
+ ok(125, docat_del($file) eq <<'EOM') ;
+The array contains 5 entries
+popped black
+shifted white
+Element 1 Exists with value blue
+The last element is green
+The 2nd last element is yellow
+EOM
+
+ my $save_output = "xyzt" ;
+ {
+ my $redirect = new Redirect $save_output ;
+
+ use strict ;
+ use vars qw(@h $H $file $i) ;
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+ unlink $file ;
+ }
+
+ ok(126, docat_del($save_output) eq <<'EOM') ;
+
+ORIGINAL
+0: zero
+1: one
+2: two
+3: three
+4: four
+
+The last record was [four]
+The first record was [zero]
+
+REVERSE
+5: last
+4: three
+3: Newbie
+2: one
+1: New One
+0: first
+
+REVERSE again
+5: last
+4: three
+3: Newbie
+2: one
+1: New One
+0: first
+EOM
+
+}
+
exit ;
'((?x:.) )' x y $1- x -
'((?-x:.) )'x x y $1- x-
foo.bart foo.bart y - -
+'^d[x][x][x]'m abcd\ndxxx y - -
+.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
+.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
+tt+$ xxxtt y - -
PERLVAR(Textralen, I32) /* from regcomp.c */
PERLVAR(Tcolorset, int) /* from regcomp.c */
PERLVARA(Tcolors,6, char *) /* from regcomp.c */
+PERLVAR(Treg_whilem_seen, I32) /* number of WHILEM in this expr */
PERLVAR(Treginput, char *) /* String-input pointer. */
PERLVAR(Tregbol, char *) /* Beginning of input, for ^ check. */
PERLVAR(Tregeol, char *) /* End of input, for $ check. */
PERLVARI(Treg_curpm, PMOP*, NULL) /* curpm during match */
PERLVAR(Treg_oldsaved, char*) /* old saved substr during match */
PERLVAR(Treg_oldsavedlen, STRLEN) /* old length of saved substr during match */
+PERLVAR(Treg_maxiter, I32) /* max wait until caching pos */
+PERLVAR(Treg_leftiter, I32) /* wait until caching pos */
+PERLVARI(Treg_poscache, char *, Nullch) /* cache of pos of WHILEM */
+PERLVAR(Treg_poscache_size, STRLEN) /* size of pos cache of WHILEM */
PERLVARI(Tregcompp, regcomp_t, MEMBER_TO_FPTR(Perl_pregcomp))
/* Pointer to REx compiler */
# ifdef POSIX_BC
# define PERL_SYS_INIT(c,v) sigignore(SIGFPE); MALLOC_INIT
# else
-# define PERL_SYS_INIT(c,v) MALLOC_INIT
+# ifdef CYGWIN
+# define PERL_SYS_INIT(c,v) Perl_my_setenv_init(&environ); MALLOC_INIT
+# else
+# define PERL_SYS_INIT(c,v) MALLOC_INIT
+# endif
# endif
#endif
#endif
}
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
-#if !defined(WIN32) && !defined(CYGWIN32)
+#if !defined(WIN32) && !defined(CYGWIN)
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
#endif /* PERL_USE_SAFE_PUTENV */
}
-#else /* WIN32 || CYGWIN32 */
-#if defined(CYGWIN32)
+#else /* WIN32 || CYGWIN */
+#if defined(CYGWIN)
/*
* Save environ of perl.exe, currently Cygwin links in separate environ's
* for each exe/dll. Probably should be a member of impure_ptr.
}
#endif /* !DOSISH */
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
I32
Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
{
* right amount of 16-tuples. */
rnv += (NV)((hexdigit - PL_hexdigit) & 15);
}
+ if (!overflowed) {
+ register UV xuv = ruv << 4;
+
+ if ((xuv >> 4) != ruv) {
+ dTHR;
+ overflowed = TRUE;
+ rnv = (NV) ruv;
+ if (ckWARN_d(WARN_UNSAFE))
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "Integer overflow in hexadecimal number");
+ } else
+ ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
+ }
+ if (overflowed) {
+ rnv *= 16.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent an UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply rnv by the
+ * right amount of 16-tuples. */
+ rnv += (NV)((hexdigit - PL_hexdigit) & 15);
+ }
}
if (!overflowed)
rnv = (NV) ruv;
projects / p5sagit/p5-mst-13.2.git / commitdiff