Integrate with Sarathy. perl.h and util.c required manual resolving.
Jarkko Hietaniemi [Sun, 1 Aug 1999 22:41:41 +0000 (22:41 +0000)]
p4raw-id: //depot/cfgperl@3864

71 files changed:
AUTHORS
Changes
EXTERN.h
INSTALL
MAINTAIN
MANIFEST
Makefile.SH
Porting/patchls
README.cygwin [moved from README.cygwin32 with 98% similarity]
README.win32
XSUB.h
cygwin/Makefile.SHs [moved from cygwin32/Makefile.SHs with 95% similarity]
cygwin/ld2.in [moved from cygwin32/ld2.in with 100% similarity]
cygwin/perlld.in [moved from cygwin32/perlld.in with 100% similarity]
cygwin32/build-instructions.READFIRST [deleted file]
cygwin32/build-instructions.charles-wilson [deleted file]
cygwin32/build-instructions.sebastien-barre [deleted file]
cygwin32/build-instructions.steven-morlock [deleted file]
cygwin32/build-instructions.steven-morlock2 [deleted file]
doio.c
dosish.h
embed.pl
embedvar.h
ext/B/B/C.pm
ext/B/B/Deparse.pm
ext/B/B/Disassembler.pm
ext/DB_File/Changes
ext/DB_File/DB_File.pm
ext/DB_File/DB_File.xs
ext/DynaLoader/dl_cygwin.xs [moved from ext/DynaLoader/dl_cygwin32.xs with 95% similarity]
ext/POSIX/POSIX.xs
ext/SDBM_File/sdbm/pair.c
ext/Thread/Thread.xs
hints/cygwin.sh [moved from hints/cygwin32.sh with 69% similarity]
hints/posix-bc.sh
lib/CGI.pm
lib/Dumpvalue.pm
lib/ExtUtils/MM_Cygwin.pm
lib/ExtUtils/MM_OS2.pm
lib/ExtUtils/Mksymlists.pm
lib/File/Spec/Unix.pm
lib/dumpvar.pl
makedef.pl
makedepend.SH
mg.c
objXSUB.h
op.c
opcode.h
opcode.pl
os2/Makefile.SHs
os2/diff.configure
perl.c
perl.h
perlsdio.h
pod/perl.pod
pod/perldelta.pod
pod/perlguts.pod
pod/perlport.pod
pod/perltrap.pod
pp_sys.c
proto.h
regcomp.c
regexec.c
sv.h
t/lib/db-btree.t
t/lib/db-hash.t
t/lib/db-recno.t
t/op/re_tests
thrdvar.h
unixish.h
util.c

diff --git a/AUTHORS b/AUTHORS
index 47669ed..ed52400 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -82,7 +82,7 @@ cgi           lstein
 complex                jhi,raphael
 cpan           k
 cxux           tom.horsley
-cygwin32       win32
+cygwin         win32
 dec_osf                jhi,spider
 dgux           roderick
 doc            tchrist
diff --git a/Changes b/Changes
index ead206b..8b6bbbe 100644 (file)
--- a/Changes
+++ b/Changes
@@ -75,7 +75,427 @@ indicator:
 
 
 ----------------
-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
 ----------------
 
 ____________________________________________________________________________
index 1aa89e6..9d31124 100644 (file)
--- a/EXTERN.h
+++ b/EXTERN.h
@@ -40,7 +40,7 @@
 #      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
diff --git a/INSTALL b/INSTALL
index bfdf273..c2953b8 100644 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -678,7 +678,7 @@ You can elect to build a shared libperl by
 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.
index 82efa5d..12f987d 100644 (file)
--- a/MAINTAIN
+++ b/MAINTAIN
@@ -51,7 +51,7 @@ Porting/pumpkin.pod
 README 
 README.amiga                   amiga
 README.beos                    beos
-README.cygwin32                        cygwin32
+README.cygwin                  cygwin
 README.dos                     dos
 README.hpux                    hpux
 README.lexwarn                 lexwarn
@@ -85,7 +85,7 @@ configure.com                 vms
 configure.gnu  
 cop.h  
 cv.h   
-cygwin32/*                     cygwin32
+cygwin/*                       cygwin
 deb.c  
 djgpp/*                                dos
 doio.c 
@@ -154,7 +154,7 @@ ext/DynaLoader/DynaLoader_pm.PL
 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
@@ -310,7 +310,7 @@ hints/broken-db.msg
 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
index 36b6924..6dacdd6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -35,7 +35,7 @@ README                        The Instructions
 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
@@ -68,14 +68,9 @@ configure.com                Configure-equivalent for VMS
 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
@@ -231,7 +226,7 @@ ext/DynaLoader/Makefile.PL  Dynamic Loader makefile writer
 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
@@ -419,7 +414,7 @@ hints/broken-db.msg Warning message for systems with broken DB library
 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
index a20a6bc..cd7cd60 100644 (file)
@@ -303,7 +303,7 @@ ext.libs: $(static_ext)
 # 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"
@@ -357,6 +357,16 @@ perl.exp: $(MINIPERLEXP) makedef.pl config.sh $(SYM) $(SYMH)
 
 !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
index 8808c20..2e4a0ac 100644 (file)
@@ -499,7 +499,7 @@ sub categorize_files {
        $c{UTIL} += 10,next  if m:^(utils|x2p|h2pl)/:;
        $c{PORT1}+= 15,next  if m:^win32:;
        $c{PORT2} += 15,next
-           if m:^(cygwin32|os2|plan9|qnx|vms)/:
+           if m:^(cygwin|os2|plan9|qnx|vms)/:
            or m:^(hints|Porting|ext/DynaLoader)/:
            or m:^README\.:;
        $c{EXT}  += 10,next
similarity index 98%
rename from README.cygwin32
rename to README.cygwin
index 9ca078f..fb93ac5 100644 (file)
@@ -4,13 +4,13 @@ specially designed to be readable as is.
 
 =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
@@ -20,7 +20,7 @@ http://sourceware.cygnus.com/cygwin/
 
 =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
@@ -209,7 +209,7 @@ kill 'CONT', $$ if($^O =~ /cygwin/); # XXX: Cygwin bug INT signal gets stuck
 
 =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.
 
@@ -228,7 +228,7 @@ When confronted with this prompt:
 
 =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. 
index 6f7af54..3d37330 100644 (file)
@@ -32,7 +32,7 @@ particular, you can safely ignore any information that talks about
 "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
diff --git a/XSUB.h b/XSUB.h
index 15f2b41..0389201 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -1,6 +1,6 @@
 #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)
similarity index 95%
rename from cygwin32/Makefile.SHs
rename to cygwin/Makefile.SHs
index e4beabe..e6a604d 100644 (file)
@@ -26,18 +26,18 @@ addtopath=`pwd`
 $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" ; \
@@ -67,14 +67,14 @@ EXPORT_ALL = 1
 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!
 
similarity index 100%
rename from cygwin32/ld2.in
rename to cygwin/ld2.in
similarity index 100%
rename from cygwin32/perlld.in
rename to cygwin/perlld.in
diff --git a/cygwin32/build-instructions.READFIRST b/cygwin32/build-instructions.READFIRST
deleted file mode 100644 (file)
index efbc760..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-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.
-
diff --git a/cygwin32/build-instructions.charles-wilson b/cygwin32/build-instructions.charles-wilson
deleted file mode 100644 (file)
index 93c718f..0000000
+++ /dev/null
@@ -1,113 +0,0 @@
-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.
diff --git a/cygwin32/build-instructions.sebastien-barre b/cygwin32/build-instructions.sebastien-barre
deleted file mode 100644 (file)
index 70e0b15..0000000
+++ /dev/null
@@ -1,74 +0,0 @@
-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
-
-
diff --git a/cygwin32/build-instructions.steven-morlock b/cygwin32/build-instructions.steven-morlock
deleted file mode 100644 (file)
index 70b7a55..0000000
+++ /dev/null
@@ -1,247 +0,0 @@
-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
diff --git a/cygwin32/build-instructions.steven-morlock2 b/cygwin32/build-instructions.steven-morlock2
deleted file mode 100644 (file)
index 82ff387..0000000
+++ /dev/null
@@ -1,81 +0,0 @@
-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
diff --git a/doio.c b/doio.c
index 47d70cd..f13d09f 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -548,7 +548,7 @@ Perl_nextargv(pTHX_ register GV *gv)
                    }
 #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, 
index c936250..822182d 100644 (file)
--- a/dosish.h
+++ b/dosish.h
@@ -23,7 +23,7 @@
 #    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 */
index 781addb..ec13498 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1932,9 +1932,10 @@ s        |char*|regwhite |char *|char *
 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
index 42d96de..39bf22b 100644 (file)
 #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)
index dd4db03..39a78c9 100644 (file)
@@ -1207,7 +1207,7 @@ sub mark_package
   {    
    no strict 'refs';
    $unused_sub_packages{$package} = 1;
-   if (defined(@{$package.'::ISA'}))
+   if (@{$package.'::ISA'})
     {
      foreach my $isa (@{$package.'::ISA'}) 
       {
index b983d12..ede68f5 100644 (file)
@@ -1,5 +1,5 @@
 # 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.
 
@@ -12,11 +12,11 @@ use B qw(class main_root main_start main_cv svref_2object opnumber
         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:
@@ -75,6 +75,13 @@ use strict;
 # - 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
@@ -86,7 +93,7 @@ use strict;
 # - 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?)
@@ -94,6 +101,7 @@ use strict;
 # - 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?
@@ -219,8 +227,7 @@ sub next_todo {
        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);
     }
 }
 
@@ -550,6 +557,18 @@ sub maybe_local {
     }
 }
 
+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;
@@ -777,9 +796,9 @@ sub baseop {
 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") }
@@ -813,15 +832,16 @@ sub pfixop {
 
 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$/) {
@@ -855,31 +875,31 @@ sub unop {
     }
 }
 
-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") }
@@ -905,19 +925,19 @@ sub pp_tell { unop(@_, "tell") }
 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") }
@@ -1060,7 +1080,7 @@ sub pp_ucfirst { dq_unop(@_, "ucfirst") }
 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;
@@ -1234,23 +1254,23 @@ sub binop {
     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) }
@@ -1281,7 +1301,8 @@ sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
 # `.' 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;
@@ -1370,6 +1391,9 @@ sub logop {
 
 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 {
@@ -1407,20 +1431,20 @@ sub listop {
 }
 
 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") }
@@ -1443,7 +1467,7 @@ sub pp_recv { listop(@_, "recv") }
 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") }
@@ -1453,23 +1477,23 @@ sub pp_accept { listop(@_, "accept") }
 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") }
@@ -1547,8 +1571,7 @@ sub indirop {
        $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);
 }
 
@@ -1911,6 +1934,24 @@ sub pp_rv2av {
     }
  }
 
+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;
@@ -1927,8 +1968,7 @@ sub elem {
        $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;
     }
@@ -1985,10 +2025,8 @@ sub slice {
     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;
@@ -2028,7 +2066,7 @@ sub method {
        # 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;
@@ -2041,13 +2079,20 @@ sub method {
        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;
@@ -2168,7 +2213,8 @@ sub pp_entersub {
        $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) {
@@ -2345,13 +2391,14 @@ sub pp_backtick {
 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)
index 4a008a3..d054a2d 100644 (file)
@@ -52,6 +52,20 @@ sub GET_objindex {
     return unpack("N", $str);
 }
 
+sub GET_opindex { 
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading opindex" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
+sub GET_svindex { 
+    my $fh = shift;
+    my $str = $fh->readn(4);
+    croak "reached EOF while reading svindex" unless length($str) == 4;
+    return unpack("N", $str);
+}
+
 sub GET_strconst {
     my $fh = shift;
     my ($str, $c);
index 236af0f..c5cf329 100644 (file)
 
    * 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.
index 7df8518..6c78098 100644 (file)
@@ -1,8 +1,8 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 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
@@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver
 use Carp;
 
 
-$VERSION = "1.67" ;
+$VERSION = "1.68" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -670,6 +670,7 @@ contents of the database.
     use DB_File ;
     use vars qw( %h $k $v ) ;
 
+    unlink "fruit" ;
     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
         or die "Cannot open file 'fruit': $!\n";
 
@@ -729,6 +730,7 @@ insensitive compare function will be used.
     # specify the Perl sub that will do the comparison
     $DB_BTREE->{'compare'} = \&Compare ;
 
+    unlink "tree" ;
     tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE 
         or die "Cannot open file 'tree': $!\n" ;
 
@@ -805,7 +807,7 @@ code:
 
     # iterate through the associative array
     # and print each key/value pair.
-    foreach (keys %h)
+    foreach (sort keys %h)
       { print "$_  -> $h{$_}\n" }
 
     untie %h ;
@@ -907,6 +909,19 @@ particular value occurred in the BTREE.
 So assuming the database created above, we can use C<get_dup> like
 this:
 
+    use strict ;
+    use DB_File ;
+    use vars qw($filename $x %h ) ;
+
+    $filename = "tree" ;
+    # Enable duplicate records
+    $DB_BTREE->{'flags'} = R_DUP ;
+    $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
+       or die "Cannot open $filename: $!\n";
+
     my $cnt  = $x->get_dup("Wall") ;
     print "Wall occurred $cnt times\n" ;
 
@@ -914,7 +929,7 @@ this:
     print "Larry is there\n" if $hash{'Larry'} ;
     print "There are $hash{'Brick'} Brick Walls\n" ;
 
-    my @list = $x->get_dup("Wall") ;
+    my @list = sort $x->get_dup("Wall") ;
     print "Wall =>     [@list]\n" ;
 
     @list = $x->get_dup("Smith") ;
@@ -967,7 +982,7 @@ Assuming the database from the previous example:
 
 prints this
 
-    Larry Wall is there
+    Larry Wall is  there
     Harry Wall is not there
 
 
@@ -1059,7 +1074,7 @@ and print the first matching key/value pair given a partial key.
         $st == 0 ;
          $st = $x->seq($key, $value, R_NEXT) )
        
-      {  print "$key -> $value\n" }
+      {  print "$key   -> $value\n" }
  
     print "\nPARTIAL MATCH\n" ;
 
@@ -1132,8 +1147,11 @@ L<Extra RECNO Methods> for a workaround).
     use strict ;
     use DB_File ;
 
+    my $filename = "text" ;
+    unlink $filename ;
+
     my @h ;
-    tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO 
+    tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO 
         or die "Cannot open file 'text': $!\n" ;
 
     # Add a few key/value pairs to the file
@@ -1166,7 +1184,7 @@ Here is the output from the script:
 
     The array contains 5 entries
     popped black
-    unshifted white
+    shifted white
     Element 1 Exists with value blue
     The last element is green
     The 2nd last element is yellow
index ed3a7fa..b8c820a 100644 (file)
@@ -3,8 +3,8 @@
  DB_File.xs -- Perl 5 interface to Berkeley DB 
 
  written by Paul Marquess <Paul.Marquess@btinternet.com>
- last modified 6th June 1999
- version 1.67
+ last modified 22nd July 1999
+ version 1.68
 
  All comments/suggestions/problems are welcome
 
@@ -69,6 +69,8 @@
         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 ))
@@ -94,7 +96,7 @@
 
 /* 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
 
@@ -148,7 +161,7 @@ typedef db_recno_t  recno_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
@@ -357,21 +370,57 @@ static DBTKEY empty ;
 #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) ;
@@ -412,9 +461,17 @@ GetVersionInfo(pTHX)
 
 
 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 ;
@@ -423,6 +480,7 @@ btree_compare(const DBT *key1, const DBT *key2)
     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
@@ -431,14 +489,15 @@ btree_compare(const DBT *key1, const DBT *key2)
         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); 
@@ -458,9 +517,17 @@ btree_compare(const DBT *key1, const DBT *key2)
 }
 
 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 ;
@@ -469,6 +536,7 @@ btree_prefix(const DBT *key1, const DBT *key2)
     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
@@ -477,14 +545,15 @@ btree_prefix(const DBT *key1, const DBT *key2)
         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); 
@@ -504,15 +573,25 @@ btree_prefix(const DBT *key1, const DBT *key2)
 }
 
 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 ;
@@ -520,7 +599,7 @@ hash_cb(const void *data, size_t size)
 
     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); 
@@ -543,7 +622,12 @@ hash_cb(const void *data, size_t size)
 #ifdef TRACE
 
 static void
+#ifdef CAN_PROTOTYPE
 PrintHash(INFO *hash)
+#else
+PrintHash(hash)
+INFO * hash ;
+#endif
 {
     printf ("HASH Info\n") ;
     printf ("  hash      = %s\n", 
@@ -557,7 +641,12 @@ PrintHash(INFO *hash)
 }
 
 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) ;
@@ -570,7 +659,12 @@ PrintRecno(INFO *recno)
 }
 
 static void
+#ifdef CAN_PROTOTYPE
 PrintBtree(INFO *btree)
+#else
+PrintBtree(btree)
+INFO * btree ;
+#endif
 {
     printf ("BTREE Info\n") ;
     printf ("  compare    = %s\n", 
@@ -597,7 +691,12 @@ PrintBtree(INFO *btree)
 
 
 static I32
+#ifdef CAN_PROTOTYPE
 GetArrayLength(pTHX_ DB_File db)
+#else
+GetArrayLength(db)
+DB_File db ;
+#endif
 {
     DBT                key ;
     DBT                value ;
@@ -615,7 +714,13 @@ GetArrayLength(pTHX_ DB_File db)
 }
 
 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 */
@@ -634,7 +739,16 @@ GetRecnoKey(pTHX_ DB_File db, I32 value)
 }
 
 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 ;
@@ -904,7 +1018,13 @@ ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv)
 
 
 static double 
+#ifdef CAN_PROTOTYPE
 constant(char *name, int arg)
+#else
+constant(name, arg)
+char *name;
+int arg;
+#endif
 {
     errno = 0;
     switch (*name) {
similarity index 95%
rename from ext/DynaLoader/dl_cygwin32.xs
rename to ext/DynaLoader/dl_cygwin.xs
index 6a2b0fe..0054afa 100644 (file)
@@ -1,4 +1,4 @@
-/* dl_cygwin32.xs
+/* dl_cygwin.xs
  * 
  * Platform:   Win32 (Windows NT/Windows 95)
  * Author:     Wei-Yuen Tan (wyt@hip.com)
@@ -8,7 +8,7 @@
  *    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:
@@ -21,7 +21,7 @@ calls.
 
 #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
index 8f0c3b7..9cca0e3 100644 (file)
    }
 #  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
index 24deb77..a30894b 100644 (file)
@@ -8,7 +8,7 @@
  */
 
 #include "config.h"
-#ifdef CYGWIN32
+#ifdef CYGWIN
 # define EXT extern
 # define EXTCONST extern const
 #else
index 4043a02..ad99e2c 100644 (file)
@@ -180,6 +180,7 @@ threadstart(void *arg)
     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(),
similarity index 69%
rename from hints/cygwin32.sh
rename to hints/cygwin.sh
index 7d68892..e6d466b 100644 (file)
@@ -1,6 +1,5 @@
 #! /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'
@@ -10,16 +9,16 @@ firstmakefile='GNUmakefile'
 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'
@@ -29,7 +28,6 @@ dlext='dll'
 
 man1dir=/usr/local/man/man1
 man3dir=/usr/local/man/man3
-sitelib=/usr/local/lib/perl5/site_perl
 
 case "$ldlibpthname" in
 '') ldlibpthname=PATH ;;
index 9c1ead5..ec21bc3 100644 (file)
@@ -13,6 +13,15 @@ ld='c89'
 # 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'
 
index b131926..c0cb5fd 100644 (file)
@@ -355,7 +355,7 @@ sub init {
     # 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{$_});
        }
@@ -841,7 +841,7 @@ END_OF_FUNC
 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;
 }
@@ -1906,14 +1906,14 @@ sub _tableize {
     # 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]);
index 9c596ff..22a10af 100644 (file)
@@ -91,7 +91,7 @@ sub stringify {
   { 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') {
@@ -162,7 +162,7 @@ sub unwrap {
     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) {
@@ -324,12 +324,12 @@ sub dumpglob {
     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")) {
@@ -361,7 +361,7 @@ sub dumpsub {
 
 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;
@@ -444,9 +444,9 @@ sub globUsage {                     # glob ref, 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;
 }
index df4ae59..7a92290 100644 (file)
@@ -24,7 +24,7 @@ sub cflags {
       / *= */ 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}
index 5d6034c..430235a 100644 (file)
@@ -25,13 +25,13 @@ sub dlsyms {
 $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}}) {
index 76535d9..cfc1e7d 100644 (file)
@@ -76,12 +76,19 @@ sub _write_os2 {
         ($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  ";
index e33ecb7..87ad643 100644 (file)
@@ -41,7 +41,7 @@ ricochet (some scripts depend on it).
 
 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
index fb0bb23..f473c45 100644 (file)
@@ -53,7 +53,7 @@ sub stringify {
        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]/) {
@@ -125,7 +125,7 @@ sub unwrap {
     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}++ ;
@@ -289,12 +289,12 @@ sub dumpglob {
       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")) {
@@ -323,7 +323,7 @@ sub dumpsub {
 }
 
 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;
@@ -395,8 +395,8 @@ sub globUsage {                     # glob ref, 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;
 }
index 8a79bae..a5e7f21 100644 (file)
@@ -1,10 +1,11 @@
 #
 # 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;
@@ -13,11 +14,12 @@ while (@ARGV)
  {
   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} = ();
 
@@ -51,6 +53,10 @@ unless ($PLATFORM eq 'win32') {
            $_ = $1;
            $define{$1} = 1 while /-D(\w+)/g;
        }
+       if ($PLATFORM eq 'os2') {
+           $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/;
+           $ARCHNAME = $1 if /^(?:archname)='(.+)'$/;
+       }
     }
     close(CFG);
 }
@@ -93,6 +99,27 @@ if ($PLATFORM eq 'win32') {
        }
        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";
 }
@@ -190,6 +217,48 @@ PL_sys_intern
 )]);
 }
 
+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
@@ -554,6 +623,14 @@ win32_os_id
        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.
@@ -595,6 +672,8 @@ sub output_symbol {
 #          print "\t$symbol\n";
 #          print "\t_$symbol = $symbol\n";
 #      }
+    } elsif ($PLATFORM eq 'os2') {
+       print qq(    "$symbol"\n);
     } elsif ($PLATFORM eq 'aix') {
        print "$symbol\n";
     }
index e1c2846..f03f68b 100755 (executable)
@@ -105,7 +105,7 @@ for file in `$cat .clist`; do
                if [ "$osname" = os2 ]; then
                        uwinfix="-e s,\\\\\\\\,/,g"
                else
-                       if [ "$archname" = cygwin32 ]; then
+                       if [ "$archname" = cygwin ]; then
                                uwinfix="-e s,\\\\\\\\,/,g"
                        else
                                uwinfix=
diff --git a/mg.c b/mg.c
index 9127137..19479db 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -828,7 +828,12 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     }
     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)
@@ -836,7 +841,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     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;
 
index 7ae62f3..c3faf68 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #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
diff --git a/op.c b/op.c
index d5a343d..d847e3d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5135,7 +5135,9 @@ Perl_ck_sassign(pTHX_ OP *o)
        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
@@ -5707,6 +5709,7 @@ Perl_peep(pTHX_ register OP *o)
                        goto ignore_optimization;
                    } else {
                        o->op_targ = o->op_next->op_targ;
+                       o->op_private |= OPpTARGET_MY;
                    }
                }
                null(o->op_next);
@@ -5791,6 +5794,8 @@ Perl_peep(pTHX_ register OP *o)
        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++;
index 7d9bd81..d9ec0d5 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1965,7 +1965,7 @@ EXT U32 PL_opargs[] = {
        0x00000200,     /* flop */
        0x00000600,     /* and */
        0x00000600,     /* or */
-       0x00022606,     /* xor */
+       0x00022406,     /* xor */
        0x00000640,     /* cond_expr */
        0x00000604,     /* andassign */
        0x00000604,     /* orassign */
index 62683d7..6e56a10 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -530,7 +530,7 @@ flop                range (or flop)         ck_null         1
 
 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|      
index c732ace..f7f8402 100644 (file)
@@ -11,7 +11,7 @@ case "$archname" in
  *-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!
@@ -62,9 +62,9 @@ t/$(PERL_DLL): $(PERL_DLL)
        $(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                            >>$@
@@ -96,10 +96,8 @@ perl.linkexp: perl.exports perl.map  os2/os2.sym
 
 # 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
index 62cf1d2..c8f3b58 100644 (file)
@@ -1,6 +1,18 @@
---- 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
diff --git a/perl.c b/perl.c
index 3a3505d..d811879 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -507,6 +507,7 @@ perl_destruct(pTHXx)
     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();
diff --git a/perl.h b/perl.h
index 1e4b2e0..3febd71 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -23,6 +23,9 @@
 #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
@@ -1049,6 +1052,8 @@ Free_t   Perl_mfree (Malloc_t where);
 #    undef IV_IS_QUAD
 #    undef UV_IS_QUAD
 #  endif
+#  define UV_SIZEOF LONGSIZE
+#  define IV_SIZEOF LONGSIZE
 #endif
 
 #ifdef USE_LONG_DOUBLE
@@ -1457,6 +1462,10 @@ typedef union any ANY;
 #   endif
 #endif
 
+#if defined(OS2)
+#  include "iperlsys.h"
+#endif
+
 #if defined(__OPEN_VM)
 # include "vmesa/vmesaish.h"
 #endif
@@ -1656,7 +1665,7 @@ typedef pthread_key_t     perl_key;
 #   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
@@ -1665,7 +1674,7 @@ typedef pthread_key_t     perl_key;
  */
 #  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
@@ -1686,25 +1695,15 @@ union any {
 #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"
@@ -1745,25 +1744,7 @@ struct _sublex_info {
 
 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;
 
@@ -2509,7 +2490,7 @@ struct perl_vars {
 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;
index efc52e1..46a15de 100644 (file)
 #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 */
index 87696fe..0275543 100644 (file)
@@ -226,7 +226,7 @@ http://www.perl.com/CPAN/src/index.html
         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,
index 624b152..ad0abcc 100644 (file)
@@ -37,11 +37,15 @@ specified via MakeMaker:
 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).
@@ -50,6 +54,9 @@ For testing purposes, the 5.005_58 release automatically enables
 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
index f297560..74b5ff9 100644 (file)
@@ -1506,6 +1506,259 @@ additional complications for conditionals).  These optimizations are
 done in the subroutine peep().  Optimizations performed at this stage
 are subject to the same restrictions as in the pass 2.
 
+=head1 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
@@ -1514,10 +1767,7 @@ extensions.
 
 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.
index 5c0c71c..6b532f3 100644 (file)
@@ -663,8 +663,8 @@ C<ftp://hobbes.nmsu.edu/pub/os2/dev/emx>
 
 =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/>
index 321c86d..50987cb 100644 (file)
@@ -761,6 +761,9 @@ Hashes get defined before use
     # 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
index 82dfa36..c07b18d 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3549,7 +3549,7 @@ PP(pp_fork)
 
 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;
@@ -3565,7 +3565,7 @@ PP(pp_wait)
 
 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;
@@ -4738,7 +4738,7 @@ PP(pp_gpwent)
 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();
diff --git a/proto.h b/proto.h
index 9f63491..bdb0ea0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -868,8 +868,8 @@ STATIC void S_regtail(pTHX_ regnode *, regnode *);
 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);
index 2d81da1..fac31e6 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
 #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
@@ -328,6 +349,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
 
                    num++;
                    data_fake.flags = 0;
+                   if (data)
+                       data_fake.whilem_c = data->whilem_c;
                    next = regnext(scan);
                    scan = NEXTOPER(scan);
                    if (code != BRANCH)
@@ -346,6 +369,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                        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;
                }
@@ -562,6 +587,16 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                    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) {
@@ -653,6 +688,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
            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);
@@ -669,6 +706,8 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                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++;
@@ -787,6 +826,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     I32 minlen = 0;
     I32 sawplus = 0;
     I32 sawopen = 0;
+    scan_data_t data;
 
     if (exp == NULL)
        FAIL("NULL regexp argument");
@@ -798,7 +838,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
 
     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;
@@ -816,6 +856,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     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);
@@ -830,6 +871,8 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
         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),
@@ -876,12 +919,11 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        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)) ||
@@ -1042,7 +1084,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
        
        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;
     }
 
@@ -1520,8 +1562,10 @@ S_regpiece(pTHX_ I32 *flagp)
                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);
@@ -1532,7 +1576,8 @@ S_regpiece(pTHX_ I32 *flagp)
                    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;
 
@@ -3115,16 +3160,18 @@ Perl_regdump(pTHX_ regexp *r)
 
     /* 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);
@@ -3192,6 +3239,8 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
            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)
index f6ed328..9a7e91b 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -270,25 +270,33 @@ S_cache_re(pTHX_ regexp *prog)
 
 /* 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],
@@ -299,128 +307,296 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                      (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 */
@@ -435,11 +611,14 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
            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;
 }
@@ -504,6 +683,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 
     PL_reg_flags = 0;
     PL_reg_eval_set = 0;
+    PL_reg_maxiter = 0;
 
     if (prog->reganch & ROPT_UTF8)
        PL_reg_flags |= RF_utf8;
@@ -552,7 +732,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 
     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],
@@ -1838,6 +2018,7 @@ S_regmatch(pTHX_ regnode *prog)
        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])
@@ -1982,6 +2163,10 @@ S_regmatch(pTHX_ regnode *prog)
                    *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);
@@ -1999,6 +2184,10 @@ S_regmatch(pTHX_ regnode *prog)
                    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);
@@ -2026,6 +2215,7 @@ S_regmatch(pTHX_ regnode *prog)
            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 {
@@ -2064,7 +2254,7 @@ S_regmatch(pTHX_ regnode *prog)
                /*
                 * 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.
@@ -2124,6 +2314,51 @@ S_regmatch(pTHX_ regnode *prog)
                    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) {
diff --git a/sv.h b/sv.h
index 4ba33ed..476c941 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -692,7 +692,7 @@ struct xpvio {
 
 #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
index 2729048..7263a90 100755 (executable)
@@ -12,7 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..148\n";
+print "1..155\n";
 
 sub ok
 {
@@ -38,6 +38,50 @@ sub lexical
     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;
 
@@ -796,4 +840,353 @@ EOM
 }
 
 
+{
+   # 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 ;
index ecf3886..2293a42 100755 (executable)
@@ -12,7 +12,7 @@ BEGIN {
 use DB_File; 
 use Fcntl;
 
-print "1..108\n";
+print "1..109\n";
 
 sub ok
 {
@@ -23,6 +23,39 @@ 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;
 
@@ -600,4 +633,51 @@ EOM
    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 ;
index ce33313..276f38b 100755 (executable)
@@ -38,6 +38,49 @@ sub ok
     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++ ;
@@ -56,7 +99,7 @@ sub bad_one
 EOM
 }
 
-print "1..124\n";
+print "1..126\n";
 
 my $Dfile = "recno.tmp";
 unlink $Dfile ;
@@ -209,16 +252,6 @@ untie(@h);
 
 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
@@ -638,4 +671,169 @@ EOM
    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 ;
index 34b6e29..899b35e 100644 (file)
@@ -715,3 +715,23 @@ round\(((?>[^()]+))\)      _I(round(xs * sz),1)    y       $1      xs * sz
 '((?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       -       -
index 32a0c7f..4434b5d 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -143,6 +143,7 @@ PERLVAR(Tregcomp_rx,        regexp *)       /* from regcomp.c */
 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. */
@@ -172,6 +173,10 @@ PERLVARI(Treg_oldcurpm,    PMOP*, NULL)    /* curpm before match */
 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 */
index eab2de1..2d37fbe 100644 (file)
--- a/unixish.h
+++ b/unixish.h
 #  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
diff --git a/util.c b/util.c
index 45d6a6f..5cdedef 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1795,7 +1795,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 }
 
 #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)
 {
@@ -1860,8 +1860,8 @@ 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.
@@ -2559,7 +2559,7 @@ Perl_my_pclose(pTHX_ PerlIO *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)
 {
@@ -2970,6 +2970,29 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
             * 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;