This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate with Sarathy.
authorJarkko Hietaniemi <jhi@iki.fi>
Tue, 6 Jul 1999 09:28:48 +0000 (09:28 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Tue, 6 Jul 1999 09:28:48 +0000 (09:28 +0000)
p4raw-id: //depot/cfgperl@3609

49 files changed:
Changes
av.h
bytecode.pl
cv.h
doio.c
dump.c
embed.h
embed.pl
embedvar.h
ext/ByteLoader/bytecode.h
ext/ByteLoader/byterun.c
ext/DB_File/Changes
ext/DB_File/DB_File.pm
ext/DB_File/DB_File.xs
ext/DB_File/typemap
ext/GDBM_File/GDBM_File.pm
ext/GDBM_File/GDBM_File.xs
ext/NDBM_File/NDBM_File.pm
ext/NDBM_File/NDBM_File.xs
ext/ODBM_File/ODBM_File.pm
ext/ODBM_File/ODBM_File.xs
ext/SDBM_File/SDBM_File.pm
ext/SDBM_File/SDBM_File.xs
ext/re/Makefile.PL
ext/re/re.xs
global.sym
hv.h
intrpvar.h
mg.c
objXSUB.h
op.c
perl.c
perl.h
pp.c
pp.h
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regcomp.c
regcomp.h
regexec.c
regexp.h
sv.c
sv.h
thrdvar.h
toke.c
universal.c
util.c

diff --git a/Changes b/Changes
index c1b80ca..87d97f4 100644 (file)
--- a/Changes
+++ b/Changes
@@ -79,6 +79,99 @@ Version 5.005_58        Development release working toward 5.006
 ----------------
 
 ____________________________________________________________________________
+[  3604] By: gsar                                  on 1999/07/06  07:08:30
+        Log: From: paul.marquess@bt.com
+             Date: Tue, 8 Jun 1999 22:37:58 +0100 
+             Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB29C6C3C@mbtlipnt02.btlabs.bt.co.uk>
+             Subject: [PATCH 5.005_57] DB_File 1.67
+     Branch: perl
+          ! ext/DB_File/Changes ext/DB_File/DB_File.pm
+           ! ext/DB_File/DB_File.xs ext/DB_File/typemap
+____________________________________________________________________________
+[  3603] By: gsar                                  on 1999/07/06  07:04:50
+        Log: From: paul.marquess@bt.com
+             Date: Tue, 8 Jun 1999 22:34:01 +0100 
+             Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB29C6C3B@mbtlipnt02.btlabs.bt.co.uk>
+             Subject: [PATCH 5.005_57] DBM Filters
+     Branch: perl
+          ! ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs
+          ! ext/NDBM_File/NDBM_File.pm ext/NDBM_File/NDBM_File.xs
+          ! ext/ODBM_File/ODBM_File.pm ext/ODBM_File/ODBM_File.xs
+           ! ext/SDBM_File/SDBM_File.pm ext/SDBM_File/SDBM_File.xs
+____________________________________________________________________________
+[  3602] By: gsar                                  on 1999/07/06  07:00:01
+        Log: slightly tweaked version of suggested patch
+             From: Dan Sugalski <sugalskd@ous.edu>
+             Date: Tue, 08 Jun 1999 14:09:38 -0700
+             Message-Id: <3.0.6.32.19990608140938.030f12e0@ous.edu>
+             Subject: [PATCH 5.005_57]Use NV instead of double in the core
+     Branch: perl
+          ! av.h bytecode.pl cv.h doio.c dump.c embed.pl
+          ! ext/ByteLoader/bytecode.h ext/ByteLoader/byterun.c hv.h
+          ! intrpvar.h mg.c op.c perl.h pp.c pp.h pp_ctl.c pp_sys.c
+           ! proto.h sv.c sv.h toke.c universal.c util.c
+____________________________________________________________________________
+[  3601] By: gsar                                  on 1999/07/06  06:52:57
+        Log: integrate cfgperl contents into mainline
+     Branch: perl
+         +> README.epoc epoc/config.h epoc/epoc.c epoc/epocish.h
+          +> epoc/perl.mmp epoc/perl.pkg
+          !> (integrate 30 files)
+____________________________________________________________________________
+[  3598] By: jhi                                   on 1999/07/05  20:02:55
+        Log: Integrate with mainperl.
+     Branch: cfgperl
+          +> lib/CGI/Pretty.pm
+         !> Changes ext/B/B/Bblock.pm ext/B/B/C.pm ext/B/B/CC.pm
+         !> ext/B/B/Stackobj.pm ext/GDBM_File/GDBM_File.xs mg.c op.c
+         !> opcode.h opcode.pl pp_sys.c t/lib/io_udp.t thread.h toke.c
+         !> vms/descrip_mms.template vms/subconfigure.com vms/vms.c
+          !> vms/vmsish.h
+____________________________________________________________________________
+[  3597] By: jhi                                   on 1999/07/05  19:59:48
+        Log: Hack SOCKS support some more plus a patch from Andy Dougherty
+             that addresses the notorious "Additional libraries" question.
+     Branch: cfgperl
+          ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+          ! config_h.SH doio.c ext/Socket/Socket.xs hints/aix.sh perl.c
+           ! pp_sys.c
+____________________________________________________________________________
+[  3596] By: gsar                                  on 1999/07/05  18:30:51
+        Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+             Date: Tue, 8 Jun 1999 04:47:58 -0400 (EDT)
+             Message-Id: <199906080847.EAA03810@monk.mps.ohio-state.edu>
+             Subject: [PATCH 5.00557] Long-standing UDP sockets bug on OS/2
+     Branch: perl
+           ! pp_sys.c t/lib/io_udp.t
+____________________________________________________________________________
+[  3595] By: gsar                                  on 1999/07/05  18:29:08
+        Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+             Date: Tue, 8 Jun 1999 04:44:58 -0400 (EDT)
+             Message-Id: <199906080844.EAA03784@monk.mps.ohio-state.edu>
+             Subject: [PATCH 5.00557] Setting $^E wipes out $!
+     Branch: perl
+           ! mg.c
+____________________________________________________________________________
+[  3594] By: gsar                                  on 1999/07/05  18:24:53
+        Log: hand-apply whitespace mutiliated patch
+             From: Dan Sugalski <sugalskd@osshe.edu>
+             Date: Mon, 07 Jun 1999 14:46:42 -0700
+             Message-Id: <3.0.6.32.19990607144642.03079100@ous.edu>
+             Subject: [PATCH 5.005_57]Updated VMS patch
+     Branch: perl
+          ! thread.h vms/descrip_mms.template vms/subconfigure.com
+           ! vms/vms.c vms/vmsish.h
+____________________________________________________________________________
+[  3593] By: gsar                                  on 1999/07/05  17:53:04
+        Log: applied parts not duplicated by previous patches
+             From: "Vishal Bhatia" <vishalb@my-deja.com>
+             Date: Sat, 05 Jun 1999 08:42:17 -0700
+             Message-ID: <JAMCAJKJEJDPAAAA@my-deja.com>
+             Subject: Fwd: [PATCH 5.005_57] consolidated compiler changes
+     Branch: perl
+          ! Changes ext/B/B/Bblock.pm ext/B/B/C.pm ext/B/B/CC.pm
+           ! ext/B/B/Stackobj.pm
+____________________________________________________________________________
 [  3592] By: jhi                                   on 1999/07/05  17:17:22
         Log: AIX threaded build, plus few more on the side.
      Branch: cfgperl
diff --git a/av.h b/av.h
index bef763d..bacf614 100644 (file)
--- a/av.h
+++ b/av.h
@@ -12,7 +12,7 @@ struct xpvav {
     SSize_t    xav_fill;       /* Index of last element present */
     SSize_t    xav_max;        /* Number of elements for which array has space */
     IV         xof_off;        /* ptr is incremented by offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* magic for scalar array */
     HV*                xmg_stash;      /* class package */
 
index 1e18d55..4d318ff 100644 (file)
@@ -312,7 +312,7 @@ xrv         SvRV(bytecode_sv)                       svindex
 xpv            bytecode_sv                             none            x
 xiv32          SvIVX(bytecode_sv)                      I32
 xiv64          SvIVX(bytecode_sv)                      IV64
-xnv            SvNVX(bytecode_sv)                      double
+xnv            SvNVX(bytecode_sv)                      NV
 xlv_targoff    LvTARGOFF(bytecode_sv)                  STRLEN
 xlv_targlen    LvTARGLEN(bytecode_sv)                  STRLEN
 xlv_targ       LvTARG(bytecode_sv)                     svindex
diff --git a/cv.h b/cv.h
index e060dc8..7042708 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -14,7 +14,7 @@ struct xpvcv {
     STRLEN     xpv_cur;        /* length of xp_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xof_off;        /* integer value */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* magic for scalar array */
     HV*                xmg_stash;      /* class package */
 
diff --git a/doio.c b/doio.c
index 0fc139c..39e2e9f 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -898,7 +898,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        if (SvGMAGICAL(sv))
            mg_get(sv);
         if (SvIOK(sv) && SvIVX(sv) != 0) {
-           PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv));
+           PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
            return !PerlIO_error(fp);
        }
        if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
diff --git a/dump.c b/dump.c
index 3d3a55c..12d318d 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -15,6 +15,7 @@
 #include "EXTERN.h"
 #define PERL_IN_DUMP_C
 #include "perl.h"
+#include "regcomp.h"
 
 #ifndef DBL_DIG
 #define DBL_DIG        15   /* A guess that works lots of places */
@@ -972,7 +973,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
            int i;
            int max = 0;
            U32 pow2 = 2, keys = HvKEYS(sv);
-           double theoret, sum = 0;
+           NV theoret, sum = 0;
 
            PerlIO_printf(file, "  (");
            Zero(freq, FREQ_MAX + 1, int);
diff --git a/embed.h b/embed.h
index d0ede0b..0871c6f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define pregexec               Perl_pregexec
 #define pregfree               Perl_pregfree
 #define pregcomp               Perl_pregcomp
+#define re_intuit_start                Perl_re_intuit_start
+#define re_intuit_string       Perl_re_intuit_string
 #define regexec_flags          Perl_regexec_flags
 #define regnext                        Perl_regnext
 #define regprop                        Perl_regprop
 #define pregexec(a,b,c,d,e,f,g)        Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
 #define pregfree(a)            Perl_pregfree(aTHX_ a)
 #define pregcomp(a,b,c)                Perl_pregcomp(aTHX_ a,b,c)
+#define re_intuit_start(a,b,c,d,e,f)   Perl_re_intuit_start(aTHX_ a,b,c,d,e,f)
+#define re_intuit_string(a)    Perl_re_intuit_string(aTHX_ a)
 #define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
 #define regnext(a)             Perl_regnext(aTHX_ a)
 #define regprop(a,b)           Perl_regprop(aTHX_ a,b)
 #define pregfree               Perl_pregfree
 #define Perl_pregcomp          CPerlObj::Perl_pregcomp
 #define pregcomp               Perl_pregcomp
+#define Perl_re_intuit_start   CPerlObj::Perl_re_intuit_start
+#define re_intuit_start                Perl_re_intuit_start
+#define Perl_re_intuit_string  CPerlObj::Perl_re_intuit_string
+#define re_intuit_string       Perl_re_intuit_string
 #define Perl_regexec_flags     CPerlObj::Perl_regexec_flags
 #define regexec_flags          Perl_regexec_flags
 #define Perl_regnext           CPerlObj::Perl_regnext
index d7c5a87..ed7f3e4 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -781,10 +781,10 @@ p |int    |block_start    |int full
 p      |void   |boot_core_UNIVERSAL
 p      |void   |call_list      |I32 oldscope|AV* av_list
 p      |I32    |cando          |I32 bit|I32 effective|Stat_t* statbufp
-p      |U32    |cast_ulong     |double f
-p      |I32    |cast_i32       |double f
-p      |IV     |cast_iv        |double f
-p      |UV     |cast_uv        |double f
+p      |U32    |cast_ulong     |NV f
+p      |I32    |cast_i32       |NV f
+p      |IV     |cast_iv        |NV f
+p      |UV     |cast_uv        |NV f
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 p      |I32    |my_chsize      |int fd|Off_t length
 #endif
@@ -1058,7 +1058,7 @@ p |I32    |mg_size        |SV* sv
 p      |OP*    |mod            |OP* o|I32 type
 p      |char*  |moreswitches   |char* s
 p      |OP*    |my             |OP* o
-p      |double |my_atof        |const char *s
+p      |NV     |my_atof        |const char *s
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 p      |char*  |my_bcopy       |const char* from|char* to|I32 len
 #endif
@@ -1127,7 +1127,7 @@ p |SV*    |newSV          |STRLEN len
 p      |OP*    |newSVREF       |OP* o
 p      |OP*    |newSVOP        |I32 type|I32 flags|SV* sv
 p      |SV*    |newSViv        |IV i
-p      |SV*    |newSVnv        |double n
+p      |SV*    |newSVnv        |NV n
 p      |SV*    |newSVpv        |const char* s|STRLEN len
 p      |SV*    |newSVpvn       |const char* s|STRLEN len
 p      |SV*    |newSVpvf       |const char* pat|...
@@ -1210,6 +1210,10 @@ p        |I32    |pregexec       |regexp* prog|char* stringarg \
                                |SV* screamer|U32 nosave
 p      |void   |pregfree       |struct regexp* r
 p      |regexp*|pregcomp       |char* exp|char* xend|PMOP* pm
+p      |char*  |re_intuit_start|regexp* prog|SV* sv|char* strpos \
+                               |char* strend|U32 flags \
+                               |struct re_scream_pos_data_s *data
+p      |SV*    |re_intuit_string|regexp* prog
 p      |I32    |regexec_flags  |regexp* prog|char* stringarg \
                                |char* strend|char* strbeg|I32 minend \
                                |SV* screamer|void* data|U32 flags
@@ -1289,12 +1293,12 @@ p       |CV*    |sv_2cv         |SV* sv|HV** st|GV** gvp|I32 lref
 p      |IO*    |sv_2io         |SV* sv
 p      |IV     |sv_2iv         |SV* sv
 p      |SV*    |sv_2mortal     |SV* sv
-p      |double |sv_2nv         |SV* sv
+p      |NV     |sv_2nv         |SV* sv
 p      |char*  |sv_2pv         |SV* sv|STRLEN* lp
 p      |UV     |sv_2uv         |SV* sv
 p      |IV     |sv_iv          |SV* sv
 p      |UV     |sv_uv          |SV* sv
-p      |double |sv_nv          |SV* sv
+p      |NV     |sv_nv          |SV* sv
 p      |char*  |sv_pvn         |SV *sv|STRLEN *len
 p      |I32    |sv_true        |SV *sv
 p      |void   |sv_add_arena   |char* ptr|U32 size|U32 flags
@@ -1346,9 +1350,9 @@ p |void   |sv_setpvf      |SV* sv|const char* pat|...
 p      |void   |sv_setiv       |SV* sv|IV num
 p      |void   |sv_setpviv     |SV* sv|IV num
 p      |void   |sv_setuv       |SV* sv|UV num
-p      |void   |sv_setnv       |SV* sv|double num
+p      |void   |sv_setnv       |SV* sv|NV num
 p      |SV*    |sv_setref_iv   |SV* rv|const char* classname|IV iv
-p      |SV*    |sv_setref_nv   |SV* rv|const char* classname|double nv
+p      |SV*    |sv_setref_nv   |SV* rv|const char* classname|NV nv
 p      |SV*    |sv_setref_pv   |SV* rv|const char* classname|void* pv
 p      |SV*    |sv_setref_pvn  |SV* rv|const char* classname|char* pv \
                                |STRLEN n
@@ -1445,7 +1449,7 @@ p |void   |sv_setpvf_mg   |SV *sv|const char* pat|...
 p      |void   |sv_setiv_mg    |SV *sv|IV i
 p      |void   |sv_setpviv_mg  |SV *sv|IV iv
 p      |void   |sv_setuv_mg    |SV *sv|UV u
-p      |void   |sv_setnv_mg    |SV *sv|double num
+p      |void   |sv_setnv_mg    |SV *sv|NV num
 p      |void   |sv_setpv_mg    |SV *sv|const char *ptr
 p      |void   |sv_setpvn_mg   |SV *sv|const char *ptr|STRLEN len
 p      |void   |sv_setsv_mg    |SV *dstr|SV *sstr
index dbd94e9..f759b63 100644 (file)
 #define PL_regeol              (my_perl->Tregeol)
 #define PL_regexecp            (my_perl->Tregexecp)
 #define PL_regflags            (my_perl->Tregflags)
+#define PL_regfree             (my_perl->Tregfree)
 #define PL_regindent           (my_perl->Tregindent)
 #define PL_reginput            (my_perl->Treginput)
+#define PL_regint_start                (my_perl->Tregint_start)
+#define PL_regint_string       (my_perl->Tregint_string)
 #define PL_reginterp_cnt       (my_perl->Treginterp_cnt)
 #define PL_reglastparen                (my_perl->Treglastparen)
 #define PL_regnarrate          (my_perl->Tregnarrate)
 #define PL_regeol              (PL_curinterp->Tregeol)
 #define PL_regexecp            (PL_curinterp->Tregexecp)
 #define PL_regflags            (PL_curinterp->Tregflags)
+#define PL_regfree             (PL_curinterp->Tregfree)
 #define PL_regindent           (PL_curinterp->Tregindent)
 #define PL_reginput            (PL_curinterp->Treginput)
+#define PL_regint_start                (PL_curinterp->Tregint_start)
+#define PL_regint_string       (PL_curinterp->Tregint_string)
 #define PL_reginterp_cnt       (PL_curinterp->Treginterp_cnt)
 #define PL_reglastparen                (PL_curinterp->Treglastparen)
 #define PL_regnarrate          (PL_curinterp->Tregnarrate)
 #define PL_Tregeol             PL_regeol
 #define PL_Tregexecp           PL_regexecp
 #define PL_Tregflags           PL_regflags
+#define PL_Tregfree            PL_regfree
 #define PL_Tregindent          PL_regindent
 #define PL_Treginput           PL_reginput
+#define PL_Tregint_start       PL_regint_start
+#define PL_Tregint_string      PL_regint_string
 #define PL_Treginterp_cnt      PL_reginterp_cnt
 #define PL_Treglastparen       PL_reglastparen
 #define PL_Tregnarrate         PL_regnarrate
 #define PL_regeol              (thr->Tregeol)
 #define PL_regexecp            (thr->Tregexecp)
 #define PL_regflags            (thr->Tregflags)
+#define PL_regfree             (thr->Tregfree)
 #define PL_regindent           (thr->Tregindent)
 #define PL_reginput            (thr->Treginput)
+#define PL_regint_start                (thr->Tregint_start)
+#define PL_regint_string       (thr->Tregint_string)
 #define PL_reginterp_cnt       (thr->Treginterp_cnt)
 #define PL_reglastparen                (thr->Treglastparen)
 #define PL_regnarrate          (thr->Tregnarrate)
index 9d597fb..04a05e4 100644 (file)
@@ -70,10 +70,10 @@ typedef IV IV64;
        arg = PL_tokenbuf;                      \
     } STMT_END
 
-#define BGET_double(arg) STMT_START {  \
+#define BGET_NV(arg) STMT_START {      \
        char *str;                      \
        BGET_strconst(str);             \
-       arg = atof(str);                \
+       arg = Perl_atonv(str);          \
     } STMT_END
 
 #define BGET_objindex(arg, type) STMT_START {  \
index 544a59f..035578f 100644 (file)
@@ -221,8 +221,8 @@ byterun(pTHXo_ struct bytestream bs)
            }
          case INSN_XNV:                /* 21 */
            {
-               double arg;
-               BGET_double(arg);
+               NV arg;
+               BGET_NV(arg);
                SvNVX(bytecode_sv) = arg;
                break;
            }
index 82d9af5..236af0f 100644 (file)
 1.66 15th March 1999
 
    * Added DBM Filter code
+
+1.67 6th June 1999
+
+   * Added DBM Filter documentation to DB_File.pm
+
+   * Fixed DBM Filter code to work with 5.004
+
+   * A few instances of newSVpvn were used in 1.66. This isn't available in
+     Perl 5.004_04 or earlier. Replaced with newSVpv.
index 7e6c907..7dd1d26 100644 (file)
@@ -1,10 +1,10 @@
 # DB_File.pm -- Perl 5 interface to Berkeley DB 
 #
 # written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 6th March 1999
-# version 1.66
+# last modified 6th June 1999
+# version 1.67
 #
-#     Copyright (c) 1995-9 Paul Marquess. All rights reserved.
+#     Copyright (c) 1995-1999 Paul Marquess. All rights reserved.
 #     This program is free software; you can redistribute it and/or
 #     modify it under the same terms as Perl itself.
 
@@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver
 use Carp;
 
 
-$VERSION = "1.66" ;
+$VERSION = "1.67" ;
 
 #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
 $DB_BTREE = new DB_File::BTREEINFO ;
@@ -408,6 +408,12 @@ DB_File - Perl5 access to Berkeley DB version 1.x
  $a = $X->shift;
  $X->unshift(list);
 
+ # DBM Filters
+ $old_filter = $db->filter_store_key  ( sub { ... } ) ;
+ $old_filter = $db->filter_store_value( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;
+ $old_filter = $db->filter_fetch_value( sub { ... } ) ;
+
  untie %hash ;
  untie @array ;
 
@@ -1488,6 +1494,141 @@ R_RECNOSYNC is the only valid flag at present.
 
 =back
 
+=head1 DBM FILTERS
+
+A DBM Filter is a piece of code that is be used when you I<always>
+want to make the same transformation to all keys and/or values in a
+DBM database.
+
+There are four methods associated with DBM Filters. All work identically,
+and each is used to install (or uninstall) a single DBM Filter. Each
+expects a single parameter, namely a reference to a sub. The only
+difference between them is the place that the filter is installed.
+
+To summarise:
+
+=over 5
+
+=item B<filter_store_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a key to a DBM database.
+
+=item B<filter_store_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you write a value to a DBM database.
+
+
+=item B<filter_fetch_key>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a key from a DBM database.
+
+=item B<filter_fetch_value>
+
+If a filter has been installed with this method, it will be invoked
+every time you read a value from a DBM database.
+
+=back
+
+You can use any combination of the methods, from none, to all four.
+
+All filter methods return the existing filter, if present, or C<undef>
+in not.
+
+To delete a filter pass C<undef> to it.
+
+=head2 The Filter
+
+When each filter is called by Perl, a local copy of C<$_> will contain
+the key or value to be filtered. Filtering is achieved by modifying
+the contents of C<$_>. The return code from the filter is ignored.
+
+=head2 An Example -- the NULL termination problem.
+
+Consider the following scenario. You have a DBM database
+that you need to share with a third-party C application. The C application
+assumes that I<all> keys and values are NULL terminated. Unfortunately
+when Perl writes to DBM databases it doesn't use NULL termination, so
+your Perl application will have to manage NULL termination itself. When
+you write to the database you will have to use something like this:
+
+    $hash{"$key\0"} = "$value\0" ;
+
+Similarly the NULL needs to be taken into account when you are considering
+the length of existing keys/values.
+
+It would be much better if you could ignore the NULL terminations issue
+in the main application code and have a mechanism that automatically
+added the terminating NULL to all keys and values whenever you write to
+the database and have them removed when you read from the database. As I'm
+sure you have already guessed, this is a problem that DBM Filters can
+fix very easily.
+
+    use strict ;
+    use DB_File ;
+
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
+      or die "Cannot open $filename: $!\n" ;
+
+    # Install DBM Filters
+    $db->filter_fetch_key  ( sub { s/\0$//    } ) ;
+    $db->filter_store_key  ( sub { $_ .= "\0" } ) ;
+    $db->filter_fetch_value( sub { s/\0$//    } ) ;
+    $db->filter_store_value( sub { $_ .= "\0" } ) ;
+
+    $hash{"abc"} = "def" ;
+    my $a = $hash{"ABC"} ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+Hopefully the contents of each of the filters should be
+self-explanatory. Both "fetch" filters remove the terminating NULL,
+and both "store" filters add a terminating NULL.
+
+
+=head2 Another Example -- Key is a C int.
+
+Here is another real-life example. By default, whenever Perl writes to
+a DBM database it always writes the key and value as strings. So when
+you use this:
+
+    $hash{12345} = "soemthing" ;
+
+the key 12345 will get stored in the DBM database as the 5 byte string
+"12345". If you actually want the key to be stored in the DBM database
+as a C int, you will have to use C<pack> when writing, and C<unpack>
+when reading.
+
+Here is a DBM Filter that does it:
+
+    use strict ;
+    use DB_File ;
+    my %hash ;
+    my $filename = "/tmp/filt" ;
+    unlink $filename ;
+
+
+    my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH 
+      or die "Cannot open $filename: $!\n" ;
+
+    $db->filter_fetch_key  ( sub { $_ = unpack("i", $_) } ) ;
+    $db->filter_store_key  ( sub { $_ = pack ("i", $_) } ) ;
+    $hash{123} = "def" ;
+    # ...
+    undef $db ;
+    untie %hash ;
+
+This time only two filters have been used -- we only need to manipulate
+the contents of the key, so it wasn't necessary to install any value
+filters.
+
 =head1 HINTS AND TIPS 
 
 
@@ -1557,7 +1698,7 @@ shared by both a Perl and a C application.
 
 The vast majority of problems that are reported in this area boil down
 to the fact that C strings are NULL terminated, whilst Perl strings are
-not. 
+not. See L<DBM FILTERS> for a generic way to work around this problem.
 
 Here is a real example. Netscape 2.0 keeps a record of the locations you
 visit along with the time you last visited them in a DB_HASH database.
@@ -1746,6 +1887,19 @@ double quotes, like this:
 Although it might seem like a real pain, it is really worth the effort
 of having a C<use strict> in all your scripts.
 
+=head1 REFERENCES
+
+Articles that are either about B<DB_File> or make use of it.
+
+=over 5
+
+=item 1.
+
+I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com),
+Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41
+
+=back
+
 =head1 HISTORY
 
 Moved to the Changes file.
@@ -1771,10 +1925,8 @@ F<modules/by-module/DB_File>.
 This version of B<DB_File> will work with either version 1.x or 2.x of
 Berkeley DB, but is limited to the functionality provided by version 1.
 
-The official web site for Berkeley DB is
-F<http://www.sleepycat.com/db>. The ftp equivalent is
-F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are
-available there.
+The official web site for Berkeley DB is F<http://www.sleepycat.com>.
+Both versions 1 and 2 of Berkeley DB are available there.
 
 Alternatively, Berkeley DB version 1 is available at your nearest CPAN
 archive in F<src/misc/db.1.85.tar.gz>.
@@ -1785,7 +1937,7 @@ compile properly on IRIX 5.3.
 
 =head1 COPYRIGHT
 
-Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program
 is free software; you can redistribute it and/or modify it under the
 same terms as Perl itself.
 
index be584a2..ed3a7fa 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 March 1999
- version 1.66
+ last modified 6th June 1999
+ version 1.67
 
  All comments/suggestions/problems are welcome
 
@@ -66,6 +66,9 @@
         1.65 -  Fixed a bug in the PUSH logic.
                Added BOOT check that using 2.3.4 or greater
         1.66 -  Added DBM filter code
+        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.
 
 
 
 
 #endif
 
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+#define DEFSV          GvSV(defgv)
+#endif
+
 /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
  * shortly #included by the <db.h>) __attribute__ to the possibly
  * already defined __attribute__, for example by GNUC or by Perl. */
@@ -301,16 +309,13 @@ typedef DBT DBTKEY ;
            if (db->filtering)                                  \
                croak("recursion detected in %s", name) ;       \
            db->filtering = TRUE ;                              \
-           /* SAVE_DEFSV ;*/   /* save $_ */                   \
            save_defsv = newSVsv(DEFSV) ;                       \
            sv_setsv(DEFSV, arg) ;                              \
            PUSHMARK(sp) ;                                      \
            (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           /* SPAGAIN ; */                                             \
            sv_setsv(arg, DEFSV) ;                              \
-           sv_setsv(DEFSV, save_defsv) ;                               \
+           sv_setsv(DEFSV, save_defsv) ;                       \
            SvREFCNT_dec(save_defsv) ;                          \
-           /* PUTBACK ; */                                             \
            db->filtering = FALSE ;                             \
            /*printf("end of filtering %s\n", name) ;*/         \
        }
@@ -417,7 +422,7 @@ btree_compare(const DBT *key1, const DBT *key2)
     
     data1 = key1->data ;
     data2 = key2->data ;
-#if 0
+
     /* 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
@@ -426,14 +431,14 @@ 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(newSVpvn(data1,key1->size)));
-    PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+    PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
+    PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
     PUTBACK ;
 
     count = perl_call_sv(CurrentDB->compare, G_SCALAR); 
@@ -463,7 +468,7 @@ btree_prefix(const DBT *key1, const DBT *key2)
     
     data1 = key1->data ;
     data2 = key2->data ;
-#if 0
+
     /* 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
@@ -472,14 +477,14 @@ 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(newSVpvn(data1,key1->size)));
-    PUSHs(sv_2mortal(newSVpvn(data2,key2->size)));
+    PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
+    PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
     PUTBACK ;
 
     count = perl_call_sv(CurrentDB->prefix, G_SCALAR); 
@@ -505,17 +510,17 @@ hash_cb(const void *data, size_t size)
     dSP ;
     int retval ;
     int count ;
-#if 0
+
     if (size == 0)
         data = "" ;
-#endif
+
      /* DGH - Next two lines added to fix corrupted stack problem */
     ENTER ;
     SAVETMPS;
 
     PUSHMARK(SP) ;
 
-    XPUSHs(sv_2mortal(newSVpvn((char*)data,size)));
+    XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
     PUTBACK ;
 
     count = perl_call_sv(CurrentDB->hash, G_SCALAR); 
@@ -1564,7 +1569,8 @@ db_seq(db, key, value, flags)
 #define setFilter(type)                                        \
        {                                               \
            if (db->type)                               \
-               RETVAL = newSVsv(db->type) ;            \
+               RETVAL = sv_mortalcopy(db->type) ;      \
+           ST(0) = RETVAL ;                            \
            if (db->type && (code == &PL_sv_undef)) {   \
                 SvREFCNT_dec(db->type) ;               \
                db->type = NULL ;                       \
@@ -1585,8 +1591,6 @@ filter_fetch_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_key(db, code)
@@ -1595,8 +1599,6 @@ filter_store_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_store_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_fetch_value(db, code)
@@ -1605,8 +1607,6 @@ filter_fetch_value(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_value) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_value(db, code)
@@ -1615,7 +1615,5 @@ filter_store_value(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_store_value) ;
-       OUTPUT:
-           RETVAL
 
 #endif /* DBM_FILTERING */
index 8e4dacb..a614cc4 100644 (file)
@@ -1,8 +1,8 @@
 # typemap for Perl 5 interface to Berkeley 
 #
 # written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 20th March 1999
-# version 1.66
+# last modified 6th June 1999
+# version 1.67
 #
 #################################### DB SECTION
 #
@@ -33,6 +33,7 @@ T_dbtdatum
        $var.size = (int)PL_na;
        DBT_flags($var);
 
+
 OUTPUT
 
 T_dbtkeydatum
index 42bb6d2..aff0152 100644 (file)
@@ -59,7 +59,7 @@ require DynaLoader;
        GDBM_WRITER
 );
 
-$VERSION = "1.02";
+$VERSION = "1.03";
 
 sub AUTOLOAD {
     my($constname);
index db28891..be1817b 100644 (file)
@@ -304,7 +304,8 @@ gdbm_setopt (db, optflag, optval, optlen)
 #define setFilter(type)                                        \
        {                                               \
            if (db->type)                               \
-               RETVAL = newSVsv(db->type) ;            \
+               RETVAL = sv_mortalcopy(db->type) ;      \
+           ST(0) = RETVAL ;                            \
            if (db->type && (code == &PL_sv_undef)) {   \
                 SvREFCNT_dec(db->type) ;               \
                db->type = NULL ;                       \
@@ -326,8 +327,6 @@ filter_fetch_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_key(db, code)
@@ -336,8 +335,6 @@ filter_store_key(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_fetch_value(db, code)
@@ -346,8 +343,6 @@ filter_fetch_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_value) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_value(db, code)
@@ -356,6 +351,4 @@ filter_store_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_value) ;
-       OUTPUT:
-           RETVAL
 
index cad800a..8db59ee 100644 (file)
@@ -12,7 +12,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.02";
+$VERSION = "1.03";
 
 bootstrap NDBM_File $VERSION;
 
index 60b141e..29cc288 100644 (file)
@@ -117,7 +117,8 @@ ndbm_clearerr(db)
 #define setFilter(type)                                        \
        {                                               \
            if (db->type)                               \
-               RETVAL = newSVsv(db->type) ;            \
+               RETVAL = sv_mortalcopy(db->type) ;      \
+           ST(0) = RETVAL ;                            \
            if (db->type && (code == &PL_sv_undef)) {   \
                 SvREFCNT_dec(db->type) ;               \
                db->type = NULL ;                       \
@@ -139,8 +140,6 @@ filter_fetch_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_key(db, code)
@@ -149,8 +148,6 @@ filter_store_key(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_fetch_value(db, code)
@@ -159,8 +156,6 @@ filter_fetch_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_value) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_value(db, code)
@@ -169,6 +164,4 @@ filter_store_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_value) ;
-       OUTPUT:
-           RETVAL
 
index 572318b..0af875d 100644 (file)
@@ -8,7 +8,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.01";
+$VERSION = "1.02";
 
 bootstrap ODBM_File $VERSION;
 
index 9ad794d..7601c34 100644 (file)
@@ -158,7 +158,8 @@ odbm_NEXTKEY(db, key)
 #define setFilter(type)                                        \
        {                                               \
            if (db->type)                               \
-               RETVAL = newSVsv(db->type) ;            \
+               RETVAL = sv_mortalcopy(db->type) ;      \
+           ST(0) = RETVAL ;                            \
            if (db->type && (code == &PL_sv_undef)) {   \
                 SvREFCNT_dec(db->type) ;               \
                db->type = Nullsv ;                     \
@@ -180,8 +181,6 @@ filter_fetch_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_key(db, code)
@@ -190,8 +189,6 @@ filter_store_key(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_fetch_value(db, code)
@@ -200,8 +197,6 @@ filter_fetch_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_value) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_value(db, code)
@@ -210,6 +205,4 @@ filter_store_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_value) ;
-       OUTPUT:
-           RETVAL
 
index 006bbbd..34c9717 100644 (file)
@@ -8,7 +8,7 @@ require DynaLoader;
 
 @ISA = qw(Tie::Hash DynaLoader);
 
-$VERSION = "1.01" ;
+$VERSION = "1.02" ;
 
 bootstrap SDBM_File $VERSION;
 
index e8711f4..c2e940b 100644 (file)
@@ -23,16 +23,13 @@ typedef datum datum_value ;
            if (db->filtering)                                  \
                croak("recursion detected in %s", name) ;       \
            db->filtering = TRUE ;                              \
-           /* SAVE_DEFSV ;*/   /* save $_ */                   \
            save_defsv = newSVsv(DEFSV) ;                       \
            sv_setsv(DEFSV, arg) ;                              \
            PUSHMARK(sp) ;                                      \
            (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS);  \
-           /* SPAGAIN ; */                                             \
            sv_setsv(arg, DEFSV) ;                              \
            sv_setsv(DEFSV, save_defsv) ;                               \
            SvREFCNT_dec(save_defsv) ;                          \
-           /* PUTBACK ; */                                             \
            db->filtering = FALSE ;                             \
            /*printf("end of filtering %s\n", name) ;*/         \
        }
@@ -143,7 +140,8 @@ sdbm_clearerr(db)
 #define setFilter(type)                                        \
        {                                               \
            if (db->type)                               \
-               RETVAL = newSVsv(db->type) ;            \
+               RETVAL = sv_mortalcopy(db->type) ;      \
+           ST(0) = RETVAL ;                            \
            if (db->type && (code == &PL_sv_undef)) {   \
                 SvREFCNT_dec(db->type) ;               \
                db->type = NULL ;                       \
@@ -165,8 +163,6 @@ filter_fetch_key(db, code)
        SV *            RETVAL = &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_key(db, code)
@@ -175,8 +171,6 @@ filter_store_key(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_key) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_fetch_value(db, code)
@@ -185,8 +179,6 @@ filter_fetch_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_fetch_value) ;
-       OUTPUT:
-           RETVAL
 
 SV *
 filter_store_value(db, code)
@@ -195,6 +187,4 @@ filter_store_value(db, code)
        SV *            RETVAL =  &PL_sv_undef ;
        CODE:
            setFilter(filter_store_value) ;
-       OUTPUT:
-           RETVAL
 
index 040b085..bd0f1f7 100644 (file)
@@ -5,7 +5,7 @@ WriteMakefile(
     MAN3PODS           => {},  # Pods will be built by installman.
     XSPROTOARG         => '-noprototypes',
     OBJECT             => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)',
-    DEFINE             => '-DPERL_EXT_RE_BUILD',
+    DEFINE             => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG',
     clean              => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' },
 );
 
index b49a110..10e44f7 100644 (file)
@@ -11,6 +11,11 @@ extern regexp*       my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm);
 extern I32     my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend,
                            char* strbeg, I32 minend, SV* screamer,
                            void* data, U32 flags);
+extern void    my_regfree (pTHX_ struct regexp* r);
+extern char*   my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos,
+                                   char *strend, U32 flags,
+                                   struct re_scream_pos_data_s *data);
+extern SV*     my_re_intuit_string (pTHX_ regexp *prog);
 
 static int oldfl;
 
@@ -20,8 +25,12 @@ static void
 deinstall(pTHX)
 {
     dTHR;
-    PL_regexecp = &Perl_regexec_flags;
-    PL_regcompp = &Perl_pregcomp;
+    PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
+    PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
+    PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
+    PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
+    PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
+
     if (!oldfl)
        PL_debug &= ~R_DB;
 }
@@ -33,6 +42,9 @@ install(pTHX)
     PL_colorset = 0;                   /* Allow reinspection of ENV. */
     PL_regexecp = &my_regexec;
     PL_regcompp = &my_regcomp;
+    PL_regint_start = &my_re_intuit_start;
+    PL_regint_string = &my_re_intuit_string;
+    PL_regfree = &my_regfree;
     oldfl = PL_debug & R_DB;
     PL_debug |= R_DB;
 }
index efbca1d..87ece3c 100644 (file)
@@ -408,6 +408,8 @@ Perl_regdump
 Perl_pregexec
 Perl_pregfree
 Perl_pregcomp
+Perl_re_intuit_start
+Perl_re_intuit_string
 Perl_regexec_flags
 Perl_regnext
 Perl_regprop
diff --git a/hv.h b/hv.h
index e9772d4..3977b1c 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -28,7 +28,7 @@ struct xpvhv {
     STRLEN     xhv_fill;       /* how full xhv_array currently is */
     STRLEN     xhv_max;        /* subscript of last element of xhv_array */
     IV         xhv_keys;       /* how many elements in the array */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* magic for scalar array */
     HV*                xmg_stash;      /* class package */
 
index 0bf826e..5cff858 100644 (file)
@@ -219,7 +219,7 @@ PERLVAR(Isighandlerp,       Sighandler_t)
 
 PERLVAR(Ixiv_arenaroot,        XPV*)           /* list of allocated xiv areas */
 PERLVAR(Ixiv_root,     IV *)           /* free xiv list--shared by interpreters */
-PERLVAR(Ixnv_root,     double *)       /* free xnv list--shared by interpreters */
+PERLVAR(Ixnv_root,     NV *)           /* free xnv list--shared by interpreters */
 PERLVAR(Ixrv_root,     XRV *)          /* free xrv list--shared by interpreters */
 PERLVAR(Ixpv_root,     XPV *)          /* free xpv list--shared by interpreters */
 PERLVAR(Ihe_root,      HE *)           /* free he list--shared by interpreters */
diff --git a/mg.c b/mg.c
index a21ea57..0e9ca19 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -498,7 +498,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #          include <starlet.h>
            char msg[255];
            $DESCRIPTOR(msgdsc,msg);
-           sv_setnv(sv,(double) vaxc$errno);
+           sv_setnv(sv,(NV) vaxc$errno);
            if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
                sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
            else
@@ -507,7 +507,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #else
 #ifdef OS2
        if (!(_emx_env & 0x200)) {      /* Under DOS */
-           sv_setnv(sv, (double)errno);
+           sv_setnv(sv, (NV)errno);
            sv_setpv(sv, errno ? Strerror(errno) : "");
        } else {
            if (errno != errno_isOS2) {
@@ -515,14 +515,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                if (tmp)        /* 2nd call to _syserrno() makes it 0 */
                    Perl_rc = tmp;
            }
-           sv_setnv(sv, (double)Perl_rc);
+           sv_setnv(sv, (NV)Perl_rc);
            sv_setpv(sv, os2error(Perl_rc));
        }
 #else
 #ifdef WIN32
        {
            DWORD dwErr = GetLastError();
-           sv_setnv(sv, (double)dwErr);
+           sv_setnv(sv, (NV)dwErr);
            if (dwErr)
            {
                PerlProc_GetOSError(sv, dwErr);
@@ -532,7 +532,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            SetLastError(dwErr);
        }
 #else
-       sv_setnv(sv, (double)errno);
+       sv_setnv(sv, (NV)errno);
        sv_setpv(sv, errno ? Strerror(errno) : "");
 #endif
 #endif
@@ -701,12 +701,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        break;
     case '!':
 #ifdef VMS
-       sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
+       sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
        sv_setpv(sv, errno ? Strerror(errno) : "");
 #else
        {
        int saveerrno = errno;
-       sv_setnv(sv, (double)errno);
+       sv_setnv(sv, (NV)errno);
 #ifdef OS2
        if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
        else
index d14de86..d91f84d 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define PL_regexecp            pPerl->PL_regexecp
 #undef  PL_regflags
 #define PL_regflags            pPerl->PL_regflags
+#undef  PL_regfree
+#define PL_regfree             pPerl->PL_regfree
 #undef  PL_regindent
 #define PL_regindent           pPerl->PL_regindent
 #undef  PL_reginput
 #define PL_reginput            pPerl->PL_reginput
+#undef  PL_regint_start
+#define PL_regint_start                pPerl->PL_regint_start
+#undef  PL_regint_string
+#define PL_regint_string       pPerl->PL_regint_string
 #undef  PL_reginterp_cnt
 #define PL_reginterp_cnt       pPerl->PL_reginterp_cnt
 #undef  PL_reglastparen
 #define Perl_pregcomp          pPerl->Perl_pregcomp
 #undef  pregcomp
 #define pregcomp               Perl_pregcomp
+#undef  Perl_re_intuit_start
+#define Perl_re_intuit_start   pPerl->Perl_re_intuit_start
+#undef  re_intuit_start
+#define re_intuit_start                Perl_re_intuit_start
+#undef  Perl_re_intuit_string
+#define Perl_re_intuit_string  pPerl->Perl_re_intuit_string
+#undef  re_intuit_string
+#define re_intuit_string       Perl_re_intuit_string
 #undef  Perl_regexec_flags
 #define Perl_regexec_flags     pPerl->Perl_regexec_flags
 #undef  regexec_flags
diff --git a/op.c b/op.c
index 25b17dc..091a768 100644 (file)
--- a/op.c
+++ b/op.c
@@ -192,7 +192,7 @@ Perl_pad_allocmy(pTHX_ char *name)
        PL_sv_objcount++;
     }
     av_store(PL_comppad_name, off, sv);
-    SvNVX(sv) = (double)PAD_MAX;
+    SvNVX(sv) = (NV)PAD_MAX;
     SvIVX(sv) = 0;                     /* Not yet introduced--see newSTATEOP */
     if (!PL_min_intro_pending)
        PL_min_intro_pending = off;
@@ -255,7 +255,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
                    sv_upgrade(namesv, SVt_PVNV);
                    sv_setpv(namesv, name);
                    av_store(PL_comppad_name, newoff, namesv);
-                   SvNVX(namesv) = (double)PL_curcop->cop_seq;
+                   SvNVX(namesv) = (NV)PL_curcop->cop_seq;
                    SvIVX(namesv) = PAD_MAX;    /* A ref, intro immediately */
                    SvFAKE_on(namesv);          /* A ref, not a real var */
                    if (SvOBJECT(sv)) {         /* A typed var */
@@ -1899,7 +1899,7 @@ Perl_fold_constants(pTHX_ register OP *o)
            type != OP_NEGATE)
        {
            IV iv = SvIV(sv);
-           if ((double)iv == SvNV(sv)) {
+           if ((NV)iv == SvNV(sv)) {
                SvREFCNT_dec(sv);
                sv = newSViv(iv);
            }
@@ -3083,7 +3083,7 @@ Perl_intro_my(pTHX)
     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
        if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
            SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
-           SvNVX(sv) = (double)PL_cop_seqmax;
+           SvNVX(sv) = (NV)PL_cop_seqmax;
        }
     }
     PL_min_intro_pending = 0;
diff --git a/perl.c b/perl.c
index 39eaf30..062b334 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2947,6 +2947,9 @@ S_init_main_thread(pTHX)
     PL_maxscream = -1;
     PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
     PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
+    PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
+    PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
+    PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
     PL_regindent = 0;
     PL_reginterp_cnt = 0;
 
diff --git a/perl.h b/perl.h
index 558d423..b09660a 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -145,6 +145,9 @@ class CPerlObj;
 #define CALLRUNOPS  CALL_FPTR(PL_runops)
 #define CALLREGCOMP CALL_FPTR(PL_regcompp)
 #define CALLREGEXEC CALL_FPTR(PL_regexecp)
+#define CALLREG_INTUIT_START CALL_FPTR(PL_regint_start)
+#define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string)
+#define CALLREGFREE CALL_FPTR(PL_regfree)
 #define CALLPROTECT CALL_FPTR(PL_protect)
 
 #define NOOP (void)0
@@ -997,6 +1000,43 @@ Free_t   Perl_mfree (Malloc_t where);
 #  endif
 #endif
 
+#ifdef USE_LONG_DOUBLE
+#  if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)
+#    define LDoub_t long double
+#  endif
+#endif
+
+#ifdef USE_LONG_DOUBLE
+#   define HAS_LDOUB
+    typedef LDoub_t NV;
+#   define Perl_modf modfl
+#   define Perl_frexp frexpl
+#   define Perl_cos cosl
+#   define Perl_sin sinl
+#   define Perl_sqrt sqrtl
+#   define Perl_exp expl
+#   define Perl_log logl
+#   define Perl_atan2 atan2l
+#   define Perl_pow powl
+#   define Perl_floor floorl
+#   define Perl_atof atof
+#   define Perl_fmod fmodl
+#else
+    typedef double NV;
+#   define Perl_modf modf
+#   define Perl_frexp frexp
+#   define Perl_cos cos
+#   define Perl_sin sin
+#   define Perl_sqrt sqrt
+#   define Perl_exp exp
+#   define Perl_log log
+#   define Perl_atan2 atan2
+#   define Perl_pow pow
+#   define Perl_floor floor
+#   define Perl_atof atof              /* At some point there may be an atolf */
+#   define Perl_fmod fmod
+#endif
+
 /* Previously these definitions used hardcoded figures. 
  * It is hoped these formula are more portable, although
  * no data one way or another is presently known to me.
@@ -1728,9 +1768,9 @@ typedef I32 CHECKPOINT;
 #define U_I(what) ((unsigned int)(what))
 #define U_L(what) ((U32)(what))
 #else
-#define U_S(what) ((U16)cast_ulong((double)(what)))
-#define U_I(what) ((unsigned int)cast_ulong((double)(what)))
-#define U_L(what) (cast_ulong((double)(what)))
+#define U_S(what) ((U16)cast_ulong((NV)(what)))
+#define U_I(what) ((unsigned int)cast_ulong((NV)(what)))
+#define U_L(what) (cast_ulong((NV)(what)))
 #endif
 
 #ifdef CASTI32
@@ -1738,9 +1778,9 @@ typedef I32 CHECKPOINT;
 #define I_V(what) ((IV)(what))
 #define U_V(what) ((UV)(what))
 #else
-#define I_32(what) (cast_i32((double)(what)))
-#define I_V(what) (cast_iv((double)(what)))
-#define U_V(what) (cast_uv((double)(what)))
+#define I_32(what) (cast_i32((NV)(what)))
+#define I_V(what) (cast_iv((NV)(what)))
+#define U_V(what) (cast_uv((NV)(what)))
 #endif
 
 /* Used with UV/IV arguments: */
@@ -2348,6 +2388,12 @@ typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm);
 typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg,
                                      char* strend, char* strbeg, I32 minend,
                                      SV* screamer, void* data, U32 flags);
+typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv,
+                                               char *strpos, char *strend,
+                                               U32 flags,
+                                               struct re_scream_pos_data_s *d);
+typedef SV*    (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog);
+typedef void   (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r);
 
 
 /* Set up PERLVAR macros for populating structs */
@@ -2879,7 +2925,7 @@ typedef struct am_table_short AMTS;
 #define IS_NUMERIC_RADIX(c)            (0)
 #define RESTORE_NUMERIC_LOCAL()                /**/
 #define RESTORE_NUMERIC_STANDARD()     /**/
-#define Atof                           atof
+#define Atof                           Perl_atof
 
 #endif /* !USE_LOCALE_NUMERIC */
 
diff --git a/pp.c b/pp.c
index 786733e..c112208 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -943,15 +943,15 @@ PP(pp_divide)
     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
     {
       dPOPPOPnnrl;
-      double value;
+      NV value;
       if (right == 0.0)
        DIE(aTHX_ "Illegal division by zero");
 #ifdef SLOPPYDIVIDE
       /* insure that 20./5. == 4. */
       {
        IV k;
-       if ((double)I_V(left)  == left &&
-           (double)I_V(right) == right &&
+       if ((NV)I_V(left)  == left &&
+           (NV)I_V(right) == right &&
            (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
            value = k;
        }
@@ -976,8 +976,8 @@ PP(pp_modulo)
        bool left_neg;
        bool right_neg;
        bool use_double = 0;
-       double dright;
-       double dleft;
+       NV dright;
+       NV dleft;
 
        if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
            IV i = SvIVX(POPs);
@@ -1007,7 +1007,7 @@ PP(pp_modulo)
        }
 
        if (use_double) {
-           double dans;
+           NV dans;
 
 #if 1
 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
@@ -1034,7 +1034,7 @@ PP(pp_modulo)
            if (!dright)
                DIE(aTHX_ "Illegal modulus zero");
 
-           dans = fmod(dleft, dright);
+           dans = Perl_fmod(dleft, dright);
            if ((left_neg != right_neg) && dans)
                dans = dright - dans;
            if (right_neg)
@@ -1057,7 +1057,7 @@ PP(pp_modulo)
                if (ans <= ~((UV)IV_MAX)+1)
                    sv_setiv(TARG, ~ans+1);
                else
-                   sv_setnv(TARG, -(double)ans);
+                   sv_setnv(TARG, -(NV)ans);
            }
            else
                sv_setuv(TARG, ans);
@@ -1624,7 +1624,7 @@ PP(pp_atan2)
     djSP; dTARGET; tryAMAGICbin(atan2,0);
     {
       dPOPTOPnnrl;
-      SETn(atan2(left, right));
+      SETn(Perl_atan2(left, right));
       RETURN;
     }
 }
@@ -1633,9 +1633,9 @@ PP(pp_sin)
 {
     djSP; dTARGET; tryAMAGICun(sin);
     {
-      double value;
+      NV value;
       value = POPn;
-      value = sin(value);
+      value = Perl_sin(value);
       XPUSHn(value);
       RETURN;
     }
@@ -1645,9 +1645,9 @@ PP(pp_cos)
 {
     djSP; dTARGET; tryAMAGICun(cos);
     {
-      double value;
+      NV value;
       value = POPn;
-      value = cos(value);
+      value = Perl_cos(value);
       XPUSHn(value);
       RETURN;
     }
@@ -1671,7 +1671,7 @@ extern double drand48 (void);
 PP(pp_rand)
 {
     djSP; dTARGET;
-    double value;
+    NV value;
     if (MAXARG < 1)
        value = 1.0;
     else
@@ -1787,9 +1787,9 @@ PP(pp_exp)
 {
     djSP; dTARGET; tryAMAGICun(exp);
     {
-      double value;
+      NV value;
       value = POPn;
-      value = exp(value);
+      value = Perl_exp(value);
       XPUSHn(value);
       RETURN;
     }
@@ -1799,13 +1799,13 @@ PP(pp_log)
 {
     djSP; dTARGET; tryAMAGICun(log);
     {
-      double value;
+      NV value;
       value = POPn;
       if (value <= 0.0) {
        RESTORE_NUMERIC_STANDARD();
        DIE(aTHX_ "Can't take log of %g", value);
       }
-      value = log(value);
+      value = Perl_log(value);
       XPUSHn(value);
       RETURN;
     }
@@ -1815,13 +1815,13 @@ PP(pp_sqrt)
 {
     djSP; dTARGET; tryAMAGICun(sqrt);
     {
-      double value;
+      NV value;
       value = POPn;
       if (value < 0.0) {
        RESTORE_NUMERIC_STANDARD();
        DIE(aTHX_ "Can't take sqrt of %g", value);
       }
-      value = sqrt(value);
+      value = Perl_sqrt(value);
       XPUSHn(value);
       RETURN;
     }
@@ -1831,7 +1831,7 @@ PP(pp_int)
 {
     djSP; dTARGET;
     {
-      double value = TOPn;
+      NV value = TOPn;
       IV iv;
 
       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
@@ -1840,9 +1840,9 @@ PP(pp_int)
       }
       else {
        if (value >= 0.0)
-         (void)modf(value, &value);
+         (void)Perl_modf(value, &value);
        else {
-         (void)modf(-value, &value);
+         (void)Perl_modf(-value, &value);
          value = -value;
        }
        iv = I_V(value);
@@ -1859,7 +1859,7 @@ PP(pp_abs)
 {
     djSP; dTARGET; tryAMAGICun(abs);
     {
-      double value = TOPn;
+      NV value = TOPn;
       IV iv;
 
       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
@@ -3295,7 +3295,7 @@ PP(pp_unpack)
     double adouble;
     I32 checksum = 0;
     register U32 culong;
-    double cdouble;
+    NV cdouble;
     int commas = 0;
 #ifdef PERL_NATINT_PACK
     int natint;                /* native integer */
@@ -3559,7 +3559,7 @@ PP(pp_unpack)
                    auint = utf8_to_uv((U8*)s, &along);
                    s += along;
                    if (checksum > 32)
-                       cdouble += (double)auint;
+                       cdouble += (NV)auint;
                    else
                        culong += auint;
                }
@@ -3719,7 +3719,7 @@ PP(pp_unpack)
                    Copy(s, &aint, 1, int);
                    s += sizeof(int);
                    if (checksum > 32)
-                       cdouble += (double)aint;
+                       cdouble += (NV)aint;
                    else
                        culong += aint;
                }
@@ -3770,7 +3770,7 @@ PP(pp_unpack)
                    Copy(s, &auint, 1, unsigned int);
                    s += sizeof(unsigned int);
                    if (checksum > 32)
-                       cdouble += (double)auint;
+                       cdouble += (NV)auint;
                    else
                        culong += auint;
                }
@@ -3809,7 +3809,7 @@ PP(pp_unpack)
                        COPYNN(s, &along, sizeof(long));
                        s += sizeof(long);
                        if (checksum > 32)
-                           cdouble += (double)along;
+                           cdouble += (NV)along;
                        else
                            culong += along;
                    }
@@ -3825,7 +3825,7 @@ PP(pp_unpack)
 #endif
                        s += SIZE32;
                        if (checksum > 32)
-                           cdouble += (double)along;
+                           cdouble += (NV)along;
                        else
                            culong += along;
                    }
@@ -3879,7 +3879,7 @@ PP(pp_unpack)
                        COPYNN(s, &aulong, sizeof(unsigned long));
                        s += sizeof(unsigned long);
                        if (checksum > 32)
-                           cdouble += (double)aulong;
+                           cdouble += (NV)aulong;
                        else
                            culong += aulong;
                    }
@@ -3899,7 +3899,7 @@ PP(pp_unpack)
                            aulong = vtohl(aulong);
 #endif
                        if (checksum > 32)
-                           cdouble += (double)aulong;
+                           cdouble += (NV)aulong;
                        else
                            culong += aulong;
                    }
@@ -4031,7 +4031,7 @@ PP(pp_unpack)
                if (aquad >= IV_MIN && aquad <= IV_MAX)
                    sv_setiv(sv, (IV)aquad);
                else
-                   sv_setnv(sv, (double)aquad);
+                   sv_setnv(sv, (NV)aquad);
                PUSHs(sv_2mortal(sv));
            }
            break;
@@ -4052,7 +4052,7 @@ PP(pp_unpack)
                if (auquad <= UV_MAX)
                    sv_setuv(sv, (UV)auquad);
                else
-                   sv_setnv(sv, (double)auquad);
+                   sv_setnv(sv, (NV)auquad);
                PUSHs(sv_2mortal(sv));
            }
            break;
@@ -4077,7 +4077,7 @@ PP(pp_unpack)
                    Copy(s, &afloat, 1, float);
                    s += sizeof(float);
                    sv = NEWSV(47, 0);
-                   sv_setnv(sv, (double)afloat);
+                   sv_setnv(sv, (NV)afloat);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -4101,7 +4101,7 @@ PP(pp_unpack)
                    Copy(s, &adouble, 1, double);
                    s += sizeof(double);
                    sv = NEWSV(48, 0);
-                   sv_setnv(sv, (double)adouble);
+                   sv_setnv(sv, (NV)adouble);
                    PUSHs(sv_2mortal(sv));
                }
            }
@@ -4169,7 +4169,7 @@ PP(pp_unpack)
            sv = NEWSV(42, 0);
            if (strchr("fFdD", datumtype) ||
              (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
-               double trouble;
+               NV trouble;
 
                adouble = 1.0;
                while (checksum >= 16) {
@@ -4185,7 +4185,7 @@ PP(pp_unpack)
                along = (1 << checksum) - 1;
                while (cdouble < 0.0)
                    cdouble += adouble;
-               cdouble = modf(cdouble / adouble, &trouble) * adouble;
+               cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
                sv_setnv(sv, cdouble);
            }
            else {
@@ -4662,7 +4662,7 @@ PP(pp_pack)
        case 'w':
             while (len-- > 0) {
                fromstr = NEXTFROM;
-               adouble = floor(SvNV(fromstr));
+               adouble = Perl_floor(SvNV(fromstr));
 
                if (adouble < 0)
                    Perl_croak(aTHX_ "Cannot compress negative numbers");
@@ -4992,17 +4992,19 @@ PP(pp_split)
            s = m;
        }
     }
-    else if (rx->check_substr && !rx->nparens
+    else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
             && (rx->reganch & ROPT_CHECK_ALL)
             && !(rx->reganch & ROPT_ANCH)) {
-       int tail = SvTAIL(rx->check_substr) != 0;
+       int tail = (rx->reganch & RE_INTUIT_TAIL);
+       SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
+       char c;
 
-       i = SvCUR(rx->check_substr);
+       i = rx->minlen;
        if (i == 1 && !tail) {
-           i = *SvPVX(rx->check_substr);
+           c = *SvPV(csv,i);
            while (--limit) {
                /*SUPPRESS 530*/
-               for (m = s; m < strend && *m != i; m++) ;
+               for (m = s; m < strend && *m != c; m++) ;
                if (m >= strend)
                    break;
                dstr = NEWSV(30, m-s);
@@ -5016,8 +5018,8 @@ PP(pp_split)
        else {
 #ifndef lint
            while (s < strend && --limit &&
-             (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
-                   rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
+             (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
+                            csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
 #endif
            {
                dstr = NEWSV(31, m-s);
@@ -5025,14 +5027,18 @@ PP(pp_split)
                if (make_mortal)
                    sv_2mortal(dstr);
                XPUSHs(dstr);
-               s = m + i - tail;       /* Fake \n at the end */
+               s = m + i;              /* Fake \n at the end */
            }
        }
     }
     else {
        maxiters += (strend - s) * rx->nparens;
-       while (s < strend && --limit &&
-              CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0))
+       while (s < strend && --limit
+/*            && (!rx->check_substr 
+                  || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
+                                                0, NULL))))
+*/            && CALLREGEXEC(aTHX_ rx, s, strend, orig,
+                             1 /* minend */, sv, NULL, 0))
        {
            TAINT_IF(RX_MATCH_TAINTED(rx));
            if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
diff --git a/pp.h b/pp.h
index ca8dc35..9fd3365 100644 (file)
--- a/pp.h
+++ b/pp.h
 #define PUSHs(s)       (*++sp = (s))
 #define PUSHTARG       STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END
 #define PUSHp(p,l)     STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END
-#define PUSHn(n)       STMT_START { sv_setnv(TARG, (double)(n)); PUSHTARG; } STMT_END
+#define PUSHn(n)       STMT_START { sv_setnv(TARG, (NV)(n)); PUSHTARG; } STMT_END
 #define PUSHi(i)       STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END
 #define PUSHu(u)       STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
 
 #define XPUSHs(s)      STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END
 #define XPUSHTARG      STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END
 #define XPUSHp(p,l)    STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END
-#define XPUSHn(n)      STMT_START { sv_setnv(TARG, (double)(n)); XPUSHTARG; } STMT_END
+#define XPUSHn(n)      STMT_START { sv_setnv(TARG, (NV)(n)); XPUSHTARG; } STMT_END
 #define XPUSHi(i)      STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END
 #define XPUSHu(u)      STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
 
 #define SETs(s)                (*sp = s)
 #define SETTARG                STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END
 #define SETp(p,l)      STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END
-#define SETn(n)                STMT_START { sv_setnv(TARG, (double)(n)); SETTARG; } STMT_END
+#define SETn(n)                STMT_START { sv_setnv(TARG, (NV)(n)); SETTARG; } STMT_END
 #define SETi(i)                STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END
 #define SETu(u)                STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END
 
 #define dTOPss         SV *sv = TOPs
 #define dPOPss         SV *sv = POPs
-#define dTOPnv         double value = TOPn
-#define dPOPnv         double value = POPn
+#define dTOPnv         NV value = TOPn
+#define dPOPnv         NV value = POPn
 #define dTOPiv         IV value = TOPi
 #define dPOPiv         IV value = POPi
 #define dTOPuv         UV value = TOPu
 #define dPOPuv         UV value = POPu
 
 #define dPOPXssrl(X)   SV *right = POPs; SV *left = CAT2(X,s)
-#define dPOPXnnrl(X)   double right = POPn; double left = CAT2(X,n)
+#define dPOPXnnrl(X)   NV right = POPn; NV left = CAT2(X,n)
 #define dPOPXiirl(X)   IV right = POPi; IV left = CAT2(X,i)
 
 #define USE_LEFT(sv) \
        (SvOK(sv) || SvGMAGICAL(sv) || !(PL_op->op_flags & OPf_STACKED))
 #define dPOPXnnrl_ul(X)        \
-    double right = POPn;                               \
+    NV right = POPn;                           \
     SV *leftsv = CAT2(X,s);                            \
-    double left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
+    NV left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
 #define dPOPXiirl_ul(X) \
     IV right = POPi;                                   \
     SV *leftsv = CAT2(X,s);                            \
index 64e695b..21d0335 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -276,7 +276,7 @@ PP(pp_formline)
     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
     char *chophere;
     char *linemark;
-    double value;
+    NV value;
     bool gotsome;
     STRLEN len;
     STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
@@ -569,6 +569,14 @@ PP(pp_formline)
            /* Formats aren't yet marked for locales, so assume "yes". */
            {
                RESTORE_NUMERIC_LOCAL();
+#if defined(USE_LONG_DOUBLE)
+               if (arg & 256) {
+                   sprintf(t, "%#*.*Lf",
+                           (int) fieldsize, (int) arg & 255, value);
+               } else {
+                   sprintf(t, "%*.0Lf", (int) fieldsize, value);
+               }
+#else
                if (arg & 256) {
                    sprintf(t, "%#*.*f",
                            (int) fieldsize, (int) arg & 255, value);
@@ -576,6 +584,7 @@ PP(pp_formline)
                    sprintf(t, "%*.0f",
                            (int) fieldsize, value);
                }
+#endif
                RESTORE_NUMERIC_STANDARD();
            }
            t += fieldsize;
@@ -749,8 +758,8 @@ PP(pp_mapwhile)
 STATIC I32
 S_sv_ncmp(pTHX_ SV *a, SV *b)
 {
-    double nv1 = SvNV(a);
-    double nv2 = SvNV(b);
+    NV nv1 = SvNV(a);
+    NV nv2 = SvNV(b);
     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
 }
 
@@ -778,7 +787,7 @@ S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
     SV *tmpsv;
     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
     if (tmpsv) {
-       double d;
+       NV d;
        
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -800,7 +809,7 @@ S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
     SV *tmpsv;
     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
     if (tmpsv) {
-       double d;
+       NV d;
        
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -822,7 +831,7 @@ S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
     SV *tmpsv;
     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
     if (tmpsv) {
-       double d;
+       NV d;
        
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -844,7 +853,7 @@ S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
     SV *tmpsv;
     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
     if (tmpsv) {
-       double d;
+       NV d;
        
         if (SvIOK(tmpsv)) {
             I32 i = SvIVX(tmpsv);
@@ -2464,11 +2473,11 @@ PP(pp_exit)
 PP(pp_nswitch)
 {
     djSP;
-    double value = SvNVx(GvSV(cCOP->cop_gv));
+    NV value = SvNVx(GvSV(cCOP->cop_gv));
     register I32 match = I_32(value);
 
     if (value < 0.0) {
-       if (((double)match) > value)
+       if (((NV)match) > value)
            --match;            /* was fractional--truncate other way */
     }
     match -= cCOP->uop.scop.scop_offset;
index d3a1f5c..697c306 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -846,10 +846,8 @@ PP(pp_match)
     register char *s;
     char *strend;
     I32 global;
-    I32 r_flags = 0;
-    char *truebase;                    /* Start of string, may be
-                                          relocated if REx engine
-                                          copies the string.  */
+    I32 r_flags = REXEC_CHECKED;
+    char *truebase;                    /* Start of string  */
     register REGEXP *rx = pm->op_pmregexp;
     bool rxtainted;
     I32 gimme = GIMME;
@@ -909,9 +907,7 @@ PP(pp_match)
     if ((gimme != G_ARRAY && !global && rx->nparens)
            || SvTEMP(TARG) || PL_sawampersand)
        r_flags |= REXEC_COPY_STR;
-    if (SvSCREAM(TARG) && rx->check_substr
-       && SvTYPE(rx->check_substr) == SVt_PVBM
-       && SvVALID(rx->check_substr)) 
+    if (SvSCREAM(TARG)) 
        r_flags |= REXEC_SCREAM;
 
     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
@@ -927,76 +923,17 @@ play_it_again:
        if (update_minmatch++)
            minmatch = had_zerolen;
     }
-    if (rx->check_substr) {
-       if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
-           SV *c = rx->check_substr;
+    if (rx->reganch & RE_USE_INTUIT) {
+       s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
 
-           if (r_flags & REXEC_SCREAM) {
-               I32 p = -1;
-               char *b;
-
-               if (PL_screamfirst[BmRARE(c)] < 0
-                   && !( BmRARE(c) == '\n' && (BmPREVIOUS(c) == SvCUR(c) - 1)
-                         && SvTAIL(c) ))
-                   goto nope;
-
-               b = (char*)HOP((U8*)s, rx->check_offset_min);
-               if (!(s = screaminstr(TARG, c, b - s, 0, &p, 0)))
-                   goto nope;
-
-               if ((rx->reganch & ROPT_CHECK_ALL)
-                        && !PL_sawampersand && !SvTAIL(c))
-                   goto yup;
-           }
-           else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min),
-                                    (unsigned char*)strend, c, 
-                                    PL_multiline ? FBMrf_MULTILINE : 0)))
-               goto nope;
-           else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
-               goto yup;
-           if (s && rx->check_offset_max < s - t) {
-               ++BmUSEFUL(c);
-               s = (char*)HOP((U8*)s, -rx->check_offset_max);
-           }
-           else
-               s = t;
-       }
-       /* Now checkstring is fixed, i.e. at fixed offset from the
-          beginning of match, and the match is anchored at s. */
-       else if (!PL_multiline) {       /* Anchored near beginning of string. */
-           I32 slen;
-           char *b = (char*)HOP((U8*)s, rx->check_offset_min);
-
-           if (SvTAIL(rx->check_substr)) {
-               slen = SvCUR(rx->check_substr); /* >= 1 */
-
-               if ( strend - b > slen || strend - b < slen - 1 )
-                   goto nope;
-               if ( strend - b == slen && strend[-1] != '\n')
-                   goto nope;
-               /* Now should match b[0..slen-2] */
-               slen--;
-               if (slen && (*SvPVX(rx->check_substr) != *b
-                            || (slen > 1
-                                && memNE(SvPVX(rx->check_substr), b, slen))))
-                   goto nope;
-               if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
-                   goto yup;
-           } else {                    /* Assume len > 0 */
-               if (*SvPVX(rx->check_substr) != *b
-                   || ((slen = SvCUR(rx->check_substr)) > 1
-                       && memNE(SvPVX(rx->check_substr), b, slen)))
-                   goto nope;
-               if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
-                   goto yup;
-           }
-       }
-       if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
-           && rx->check_substr == rx->float_substr) {
-           SvREFCNT_dec(rx->check_substr);
-           rx->check_substr = Nullsv;  /* opt is being useless */
-           rx->float_substr = Nullsv;
-       }
+       if (!s)
+           goto nope;
+       if ( (rx->reganch & ROPT_CHECK_ALL)
+            && !PL_sawampersand 
+            && ((rx->reganch & ROPT_NOSCAN)
+                || !((rx->reganch & RE_INTUIT_TAIL)
+                     && (r_flags & REXEC_SCREAM))))
+           goto yup;
     }
     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
     {
@@ -1066,11 +1003,10 @@ play_it_again:
        RETPUSHYES;
     }
 
-yup:                                   /* Confirmed by check_substr */
+yup:                                   /* Confirmed by INTUIT */
     if (rxtainted)
        RX_MATCH_TAINTED_on(rx);
     TAINT_IF(RX_MATCH_TAINTED(rx));
-    ++BmUSEFUL(rx->check_substr);
     PL_curpm = pm;
     if (pm->op_pmflags & PMf_ONCE)
        pm->op_pmdynflags |= PMdf_USED;
@@ -1081,7 +1017,7 @@ yup:                                      /* Confirmed by check_substr */
     if (global) {
        rx->subbeg = truebase;
        rx->startp[0] = s - truebase;
-       rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
+       rx->endp[0] = s - truebase + rx->minlen;
        rx->sublen = strend - truebase;
        goto gotcha;
     } 
@@ -1092,19 +1028,16 @@ yup:                                    /* Confirmed by check_substr */
        rx->sublen = strend - t;
        RX_MATCH_COPIED_on(rx);
        off = rx->startp[0] = s - t;
-       rx->endp[0] = off + SvCUR(rx->check_substr);
+       rx->endp[0] = off + rx->minlen;
     }
     else {                     /* startp/endp are used by @- @+. */
        rx->startp[0] = s - truebase;
-       rx->endp[0] = s - truebase + SvCUR(rx->check_substr);
+       rx->endp[0] = s - truebase + rx->minlen;
     }
     LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 
 nope:
-    if (rx->check_substr)
-       ++BmUSEFUL(rx->check_substr);
-
 ret_no:
     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
        if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
@@ -1717,56 +1650,26 @@ PP(pp_subst)
     }
     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
                ? REXEC_COPY_STR : 0;
-    if (SvSCREAM(TARG) && rx->check_substr
-                 && SvTYPE(rx->check_substr) == SVt_PVBM
-                 && SvVALID(rx->check_substr))
+    if (SvSCREAM(TARG))
        r_flags |= REXEC_SCREAM;
     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
        SAVEINT(PL_multiline);
        PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
     orig = m = s;
-    if (rx->check_substr) {
-       if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
-           if (r_flags & REXEC_SCREAM) {
-               I32 p = -1;
-               char *b;
-               
-               if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
-                   goto nope;
-
-               b = (char*)HOP((U8*)s, rx->check_offset_min);
-               if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0)))
-                   goto nope;
-           }
-           else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), 
-                                    (unsigned char*)strend,
-                                    rx->check_substr, 
-                                    PL_multiline ? FBMrf_MULTILINE : 0)))
-               goto nope;
-           if (s && rx->check_offset_max < s - m) {
-               ++BmUSEFUL(rx->check_substr);
-               s = (char*)HOP((U8*)s, -rx->check_offset_max);
-           }
-           else
-               s = m;
-       }
-       /* Now checkstring is fixed, i.e. at fixed offset from the
-          beginning of match, and the match is anchored at s. */
-       else if (!PL_multiline) { /* Anchored at beginning of string. */
-           I32 slen;
-           char *b = (char*)HOP((U8*)s, rx->check_offset_min);
-           if (*SvPVX(rx->check_substr) != *b
-               || ((slen = SvCUR(rx->check_substr)) > 1
-                   && memNE(SvPVX(rx->check_substr), b, slen)))
-               goto nope;
-       }
-       if (!(rx->reganch & ROPT_NAUGHTY) && --BmUSEFUL(rx->check_substr) < 0
-           && rx->check_substr == rx->float_substr) {
-           SvREFCNT_dec(rx->check_substr);
-           rx->check_substr = Nullsv;  /* opt is being useless */
-           rx->float_substr = Nullsv;
-       }
+    if (rx->reganch & RE_USE_INTUIT) {
+       s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
+
+       if (!s)
+           goto nope;
+       /* How to do it in subst? */
+/*     if ( (rx->reganch & ROPT_CHECK_ALL)
+            && !PL_sawampersand 
+            && ((rx->reganch & ROPT_NOSCAN)
+                || !((rx->reganch & RE_INTUIT_TAIL)
+                     && (r_flags & REXEC_SCREAM))))
+           goto yup;
+*/
     }
 
     /* only replace once? */
@@ -1778,7 +1681,9 @@ PP(pp_subst)
     /* can do inplace substitution? */
     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
        && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
-       if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+       if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
+                        r_flags | REXEC_CHECKED))
+       {
            SPAGAIN;
            PUSHs(&PL_sv_no);
            LEAVE_SCOPE(oldsave);
@@ -1851,7 +1756,9 @@ PP(pp_subst)
                }
                s = rx->endp[0] + orig;
            } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
-                                Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */
+                                TARG, NULL,
+                                /* don't match same null twice */
+                                REXEC_NOT_FIRST|REXEC_IGNOREPOS));
            if (s != d) {
                i = strend - s;
                SvCUR_set(TARG, d - SvPVX(TARG) + i);
@@ -1873,7 +1780,9 @@ PP(pp_subst)
        RETURN;
     }
 
-    if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+    if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
+                   r_flags | REXEC_CHECKED))
+    {
        if (force_on_match) {
            force_on_match = 0;
            s = SvPV_force(TARG, len);
@@ -1933,8 +1842,6 @@ PP(pp_subst)
     goto ret_no;
 
 nope:
-    ++BmUSEFUL(rx->check_substr);
-
 ret_no:         
     SPAGAIN;
     PUSHs(&PL_sv_no);
index 483ddce..ca4f464 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -906,7 +906,7 @@ PP(pp_sselect)
     register I32 j;
     register char *s;
     register SV *sv;
-    double value;
+    NV value;
     I32 maxlen = 0;
     I32 nfound;
     struct timeval timebuf;
@@ -969,7 +969,7 @@ PP(pp_sselect)
        if (value < 0.0)
            value = 0.0;
        timebuf.tv_sec = (long)value;
-       value -= (double)timebuf.tv_sec;
+       value -= (NV)timebuf.tv_sec;
        timebuf.tv_usec = (long)(value * 1000000.0);
     }
     else
@@ -1028,8 +1028,8 @@ PP(pp_sselect)
 
     PUSHi(nfound);
     if (GIMME == G_ARRAY && tbuf) {
-       value = (double)(timebuf.tv_sec) +
-               (double)(timebuf.tv_usec) / 1000000.0;
+       value = (NV)(timebuf.tv_sec) +
+               (NV)(timebuf.tv_usec) / 1000000.0;
        PUSHs(sv = sv_mortalcopy(&PL_sv_no));
        sv_setnv(sv, value);
     }
@@ -3822,11 +3822,11 @@ PP(pp_tms)
                                                    /* is returned.                   */
 #endif
 
-    PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
+    PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
     if (GIMME == G_ARRAY) {
-       PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
-       PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
-       PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
+       PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
+       PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
+       PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
     }
     RETURN;
 #endif /* HAS_TIMES */
diff --git a/proto.h b/proto.h
index 95ffda5..7fa6424 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -39,10 +39,10 @@ VIRTUAL int Perl_block_start(pTHX_ int full);
 VIRTUAL void   Perl_boot_core_UNIVERSAL(pTHX);
 VIRTUAL void   Perl_call_list(pTHX_ I32 oldscope, AV* av_list);
 VIRTUAL I32    Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t* statbufp);
-VIRTUAL U32    Perl_cast_ulong(pTHX_ double f);
-VIRTUAL I32    Perl_cast_i32(pTHX_ double f);
-VIRTUAL IV     Perl_cast_iv(pTHX_ double f);
-VIRTUAL UV     Perl_cast_uv(pTHX_ double f);
+VIRTUAL U32    Perl_cast_ulong(pTHX_ NV f);
+VIRTUAL I32    Perl_cast_i32(pTHX_ NV f);
+VIRTUAL IV     Perl_cast_iv(pTHX_ NV f);
+VIRTUAL UV     Perl_cast_uv(pTHX_ NV f);
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 VIRTUAL I32    Perl_my_chsize(pTHX_ int fd, Off_t length);
 #endif
@@ -307,7 +307,7 @@ VIRTUAL I32 Perl_mg_size(pTHX_ SV* sv);
 VIRTUAL OP*    Perl_mod(pTHX_ OP* o, I32 type);
 VIRTUAL char*  Perl_moreswitches(pTHX_ char* s);
 VIRTUAL OP*    Perl_my(pTHX_ OP* o);
-VIRTUAL double Perl_my_atof(pTHX_ const char *s);
+VIRTUAL NV     Perl_my_atof(pTHX_ const char *s);
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 VIRTUAL char*  Perl_my_bcopy(pTHX_ const char* from, char* to, I32 len);
 #endif
@@ -375,7 +375,7 @@ VIRTUAL SV* Perl_newSV(pTHX_ STRLEN len);
 VIRTUAL OP*    Perl_newSVREF(pTHX_ OP* o);
 VIRTUAL OP*    Perl_newSVOP(pTHX_ I32 type, I32 flags, SV* sv);
 VIRTUAL SV*    Perl_newSViv(pTHX_ IV i);
-VIRTUAL SV*    Perl_newSVnv(pTHX_ double n);
+VIRTUAL SV*    Perl_newSVnv(pTHX_ NV n);
 VIRTUAL SV*    Perl_newSVpv(pTHX_ const char* s, STRLEN len);
 VIRTUAL SV*    Perl_newSVpvn(pTHX_ const char* s, STRLEN len);
 VIRTUAL SV*    Perl_newSVpvf(pTHX_ const char* pat, ...);
@@ -452,6 +452,8 @@ VIRTUAL void        Perl_regdump(pTHX_ regexp* r);
 VIRTUAL I32    Perl_pregexec(pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave);
 VIRTUAL void   Perl_pregfree(pTHX_ struct regexp* r);
 VIRTUAL regexp*        Perl_pregcomp(pTHX_ char* exp, char* xend, PMOP* pm);
+VIRTUAL char*  Perl_re_intuit_start(pTHX_ regexp* prog, SV* sv, char* strpos, char* strend, U32 flags, struct re_scream_pos_data_s *data);
+VIRTUAL SV*    Perl_re_intuit_string(pTHX_ regexp* prog);
 VIRTUAL I32    Perl_regexec_flags(pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, void* data, U32 flags);
 VIRTUAL regnode*       Perl_regnext(pTHX_ regnode* p);
 VIRTUAL void   Perl_regprop(pTHX_ SV* sv, regnode* o);
@@ -527,12 +529,12 @@ VIRTUAL CV*       Perl_sv_2cv(pTHX_ SV* sv, HV** st, GV** gvp, I32 lref);
 VIRTUAL IO*    Perl_sv_2io(pTHX_ SV* sv);
 VIRTUAL IV     Perl_sv_2iv(pTHX_ SV* sv);
 VIRTUAL SV*    Perl_sv_2mortal(pTHX_ SV* sv);
-VIRTUAL double Perl_sv_2nv(pTHX_ SV* sv);
+VIRTUAL NV     Perl_sv_2nv(pTHX_ SV* sv);
 VIRTUAL char*  Perl_sv_2pv(pTHX_ SV* sv, STRLEN* lp);
 VIRTUAL UV     Perl_sv_2uv(pTHX_ SV* sv);
 VIRTUAL IV     Perl_sv_iv(pTHX_ SV* sv);
 VIRTUAL UV     Perl_sv_uv(pTHX_ SV* sv);
-VIRTUAL double Perl_sv_nv(pTHX_ SV* sv);
+VIRTUAL NV     Perl_sv_nv(pTHX_ SV* sv);
 VIRTUAL char*  Perl_sv_pvn(pTHX_ SV *sv, STRLEN *len);
 VIRTUAL I32    Perl_sv_true(pTHX_ SV *sv);
 VIRTUAL void   Perl_sv_add_arena(pTHX_ char* ptr, U32 size, U32 flags);
@@ -582,9 +584,9 @@ VIRTUAL void        Perl_sv_setpvf(pTHX_ SV* sv, const char* pat, ...);
 VIRTUAL void   Perl_sv_setiv(pTHX_ SV* sv, IV num);
 VIRTUAL void   Perl_sv_setpviv(pTHX_ SV* sv, IV num);
 VIRTUAL void   Perl_sv_setuv(pTHX_ SV* sv, UV num);
-VIRTUAL void   Perl_sv_setnv(pTHX_ SV* sv, double num);
+VIRTUAL void   Perl_sv_setnv(pTHX_ SV* sv, NV num);
 VIRTUAL SV*    Perl_sv_setref_iv(pTHX_ SV* rv, const char* classname, IV iv);
-VIRTUAL SV*    Perl_sv_setref_nv(pTHX_ SV* rv, const char* classname, double nv);
+VIRTUAL SV*    Perl_sv_setref_nv(pTHX_ SV* rv, const char* classname, NV nv);
 VIRTUAL SV*    Perl_sv_setref_pv(pTHX_ SV* rv, const char* classname, void* pv);
 VIRTUAL SV*    Perl_sv_setref_pvn(pTHX_ SV* rv, const char* classname, char* pv, STRLEN n);
 VIRTUAL void   Perl_sv_setpv(pTHX_ SV* sv, const char* ptr);
@@ -674,7 +676,7 @@ VIRTUAL void        Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...);
 VIRTUAL void   Perl_sv_setiv_mg(pTHX_ SV *sv, IV i);
 VIRTUAL void   Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv);
 VIRTUAL void   Perl_sv_setuv_mg(pTHX_ SV *sv, UV u);
-VIRTUAL void   Perl_sv_setnv_mg(pTHX_ SV *sv, double num);
+VIRTUAL void   Perl_sv_setnv_mg(pTHX_ SV *sv, NV num);
 VIRTUAL void   Perl_sv_setpv_mg(pTHX_ SV *sv, const char *ptr);
 VIRTUAL void   Perl_sv_setpvn_mg(pTHX_ SV *sv, const char *ptr, STRLEN len);
 VIRTUAL void   Perl_sv_setsv_mg(pTHX_ SV *dstr, SV *sstr);
index 76ae523..59fe5a7 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -25,7 +25,7 @@
 #    define PERL_IN_XSUB_RE
 #  endif
 /* need access to debugger hooks */
-#  ifndef DEBUGGING
+#  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
 #    define DEBUGGING
 #  endif
 #endif
@@ -35,8 +35,9 @@
 #  define Perl_pregcomp my_regcomp
 #  define Perl_regdump my_regdump
 #  define Perl_regprop my_regprop
-/* *These* symbols are masked to allow static link. */
 #  define Perl_pregfree my_regfree
+#  define Perl_re_intuit_string my_re_intuit_string
+/* *These* symbols are masked to allow static link. */
 #  define Perl_regnext my_regnext
 #  define Perl_save_re_context my_save_re_context
 #  define Perl_reginitcolors my_reginitcolors 
@@ -898,7 +899,11 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
                 PL_regkind[(U8)OP(first)] == NBOUND)
            r->regstclass = first;
        else if (PL_regkind[(U8)OP(first)] == BOL) {
-           r->reganch |= (OP(first) == MBOL ? ROPT_ANCH_MBOL: ROPT_ANCH_BOL);
+           r->reganch |= (OP(first) == MBOL
+                          ? ROPT_ANCH_MBOL
+                          : (OP(first) == SBOL
+                             ? ROPT_ANCH_SBOL
+                             : ROPT_ANCH_BOL));
            first = NEXTOPER(first);
            goto again;
        }
@@ -912,12 +917,21 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            !(r->reganch & ROPT_ANCH) )
        {
            /* turn .* into ^.* with an implied $*=1 */
-           r->reganch |= ROPT_ANCH_BOL | ROPT_IMPLICIT;
+           int type = OP(NEXTOPER(first));
+
+           if (type == REG_ANY || type == ANYUTF8)
+               type = ROPT_ANCH_MBOL;
+           else
+               type = ROPT_ANCH_SBOL;
+
+           r->reganch |= type | ROPT_IMPLICIT;
            first = NEXTOPER(first);
            goto again;
        }
-       if (sawplus && (!sawopen || !PL_regsawback))
-           r->reganch |= ROPT_SKIP;    /* x+ must match 1st of run */
+       if (sawplus && (!sawopen || !PL_regsawback) 
+           && !(PL_regseen & REG_SEEN_EVAL)) /* May examine pos and $& */
+           /* x+ must match at the 1st pos of run of x's */
+           r->reganch |= ROPT_SKIP;
 
        /* Scan is after the zeroth branch, first is atomic matcher. */
        DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %d\n", 
@@ -1010,6 +1024,11 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
            r->check_offset_min = data.offset_float_min;
            r->check_offset_max = data.offset_float_max;
        }
+       if (r->check_substr) {
+           r->reganch |= RE_USE_INTUIT;
+           if (SvTAIL(r->check_substr))
+               r->reganch |= RE_INTUIT_TAIL;
+       }
     }
     else {
        /* Several toplevels. Best we can is to set minlen. */
@@ -2846,6 +2865,8 @@ Perl_regdump(pTHX_ regexp *r)
            PerlIO_printf(Perl_debug_log, "(BOL)");
        if (r->reganch & ROPT_ANCH_MBOL)
            PerlIO_printf(Perl_debug_log, "(MBOL)");
+       if (r->reganch & ROPT_ANCH_SBOL)
+           PerlIO_printf(Perl_debug_log, "(SBOL)");
        if (r->reganch & ROPT_ANCH_GPOS)
            PerlIO_printf(Perl_debug_log, "(GPOS)");
        PerlIO_putc(Perl_debug_log, ' ');
@@ -2896,10 +2917,37 @@ Perl_regprop(pTHX_ SV *sv, regnode *o)
 #endif /* DEBUGGING */
 }
 
+SV *
+Perl_re_intuit_string(pTHX_ regexp *prog)
+{                              /* Assume that RE_INTUIT is set */
+    DEBUG_r(
+       {   STRLEN n_a;
+           char *s = SvPV(prog->check_substr,n_a);
+
+           if (!PL_colorset) reginitcolors();
+           PerlIO_printf(Perl_debug_log,
+                     "%sUsing REx substr:%s `%s%.60s%s%s'\n",
+                     PL_colors[4],PL_colors[5],PL_colors[0],
+                     s,
+                     PL_colors[1],
+                     (strlen(s) > 60 ? "..." : ""));
+       } );
+
+    return prog->check_substr;
+}
+
 void
 Perl_pregfree(pTHX_ struct regexp *r)
 {
     dTHR;
+    DEBUG_r(PerlIO_printf(Perl_debug_log,
+                     "%sFreeing REx:%s `%s%.60s%s%s'\n",
+                     PL_colors[4],PL_colors[5],PL_colors[0],
+                     r->precomp,
+                     PL_colors[1],
+                     (strlen(r->precomp) > 60 ? "..." : "")));
+
+
     if (!r || (--r->refcnt > 0))
        return;
     if (r->precomp)
index 7c5c13a..518add0 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -237,3 +237,34 @@ EXTCONST char PL_simple[] = {
 #endif
 
 END_EXTERN_C
+
+typedef struct re_scream_pos_data_s
+{
+    char **scream_olds;                /* match pos */
+    I32 *scream_pos;           /* Internal iterator of scream. */
+} re_scream_pos_data;
+
+struct reg_data {
+    U32 count;
+    U8 *what;
+    void* data[1];
+};
+
+struct reg_substr_datum {
+    I32 min_offset;
+    I32 max_offset;
+    SV *substr;
+};
+
+struct reg_substr_data {
+    struct reg_substr_datum data[3];   /* Actual array */
+};
+
+#define anchored_substr substrs->data[0].substr
+#define anchored_offset substrs->data[0].min_offset
+#define float_substr substrs->data[1].substr
+#define float_min_offset substrs->data[1].min_offset
+#define float_max_offset substrs->data[1].max_offset
+#define check_substr substrs->data[2].substr
+#define check_offset_min substrs->data[2].min_offset
+#define check_offset_max substrs->data[2].max_offset
index 7dbf6dc..c97f89e 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -25,7 +25,7 @@
 #    define PERL_IN_XSUB_RE
 #  endif
 /* need access to debugger hooks */
-#  ifndef DEBUGGING
+#  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
 #    define DEBUGGING
 #  endif
 #endif
@@ -35,6 +35,7 @@
 #  define Perl_regexec_flags my_regexec
 #  define Perl_regdump my_regdump
 #  define Perl_regprop my_regprop
+#  define Perl_re_intuit_start my_re_intuit_start
 /* *These* symbols are masked to allow static link. */
 #  define Perl_pregexec my_pregexec
 #  define Perl_reginitcolors my_reginitcolors 
@@ -258,6 +259,192 @@ S_restore_pos(pTHX_ void *arg)
     }  
 }
 
+/* 
+ * Need to implement the following flags for reg_anch:
+ *
+ * USE_INTUIT_NOML             - Useful to call re_intuit_start() first
+ * USE_INTUIT_ML
+ * INTUIT_AUTORITATIVE_NOML    - Can trust a positive answer
+ * INTUIT_AUTORITATIVE_ML
+ * INTUIT_ONCE_NOML            - Intuit can match in one location only.
+ * INTUIT_ONCE_ML
+ *
+ * Another flag for this function: SECOND_TIME (so that float substrs
+ * with giant delta may be not rechecked).
+ */
+
+/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
+
+/* If SCREAM, then 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. */
+
+char *
+Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
+                    char *strend, U32 flags, re_scream_pos_data *data)
+{
+    I32 start_shift;
+    /* Should be nonnegative! */
+    I32 end_shift;
+    char *s;
+    char *t;
+    I32 ml_anch;
+
+    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",
+                     PL_colors[4],PL_colors[5],PL_colors[0],
+                     prog->precomp,
+                     PL_colors[1],
+                     (strlen(prog->precomp) > 60 ? "..." : ""),
+                     PL_colors[0],
+                     (strend - strpos > 60 ? 60 : strend - strpos),
+                     strpos, PL_colors[1],
+                     (strend - strpos > 60 ? "..." : ""))
+       );
+
+    if (prog->minlen > strend - strpos)
+       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) {
+       ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
+                    || ( (prog->reganch & ROPT_ANCH_BOL)
+                         && !PL_multiline ) );
+
+       if ((prog->check_offset_min == prog->check_offset_max) && !ml_anch) {
+           /* Anchored... */
+           I32 slen;
+
+           if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
+                && (sv && (strpos + SvCUR(sv) != strend)) )
+               goto fail;
+
+           s = (char*)HOP((U8*)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;
+               }
+               /* 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;
+           }
+           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;
+       }
+       s = strpos;
+       if (!ml_anch && (s + prog->check_offset_max < strend - prog->minlen))
+           end_shift += strend - s - prog->minlen - prog->check_offset_max;
+    }
+    else {
+       ml_anch = 0;
+       s = strpos;
+    }
+
+  restart:
+    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);
+       else
+           s = Nullch;
+       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);
+
+    /* Update the count-of-usability, remove useless subpatterns,
+       unshift s.  */
+  finish:
+    if (!s) {
+       ++BmUSEFUL(prog->check_substr); /* hooray */
+       goto fail;                      /* not present */
+    }
+    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) ) {
+       if (ml_anch && t[-1] != '\n') {
+         find_anchor:
+           while (t < strend - end_shift - prog->minlen) {
+               if (*t == '\n') {
+                   if (t < s - prog->check_offset_min) {
+                       s = t + 1;
+                       goto set_useful;
+                   }
+                   s = t + 1;
+                   goto restart;
+               }
+               t++;
+           }
+           s = Nullch;
+           goto finish;
+       }
+       s = t;
+      set_useful:
+       ++BmUSEFUL(prog->check_substr); /* hooray/2 */
+    }
+    else {
+       if (ml_anch && sv 
+           && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n') {
+           t = strpos;
+           goto find_anchor;
+       }
+       if (!(prog->reganch & ROPT_NAUGHTY)
+           && --BmUSEFUL(prog->check_substr) < 0
+           && prog->check_substr == prog->float_substr) { /* boo */
+           /* If flags & SOMETHING - do not do it many times on the same match */
+           SvREFCNT_dec(prog->check_substr);
+           prog->check_substr = Nullsv;        /* disable */
+           prog->float_substr = Nullsv;        /* clear */
+           s = strpos;
+           prog->reganch &= ~RE_USE_INTUIT;
+       }
+       else
+           s = strpos;
+    }
+
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%sFound%s at offset %ld\n",
+                         PL_colors[4],PL_colors[5], (long)(s - strpos)) );
+    return s;
+  fail:
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%sNot found...%s\n",
+                         PL_colors[4],PL_colors[5]));
+    return Nullch;
+}
 
 /*
  - regexec_flags - match a regexp against a string
@@ -339,103 +526,78 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 
     /* If there is a "must appear" string, look for it. */
     s = startpos;
-    if (!(flags & REXEC_CHECKED) 
-       && prog->check_substr != Nullsv &&
-       !(prog->reganch & ROPT_ANCH_GPOS) &&
-       (!(prog->reganch & (ROPT_ANCH_BOL | ROPT_ANCH_MBOL))
-        || (PL_multiline && prog->check_substr == prog->anchored_substr)) )
-    {
-       char *t;
-       start_shift = prog->check_offset_min;   /* okay to underestimate on CC */
-       /* Should be nonnegative! */
-       end_shift = minlen - start_shift -
-           CHR_SVLEN(prog->check_substr) + (SvTAIL(prog->check_substr) != 0);
-       if (flags & REXEC_SCREAM) {
-           SV *c = prog->check_substr;
-
-           if (PL_screamfirst[BmRARE(c)] >= 0
-               || ( BmRARE(c) == '\n'
-                    && (BmPREVIOUS(c) == SvCUR(c) - 1)
-                    && SvTAIL(c) ))
-                   s = screaminstr(sv, prog->check_substr, 
-                                   start_shift + (stringarg - strbeg),
-                                   end_shift, &scream_pos, 0);
-           else
-                   s = Nullch;
-           scream_olds = s;
-       }
+
+    if (prog->reganch & ROPT_GPOS_SEEN) {
+       MAGIC *mg;
+
+       if (!(flags & REXEC_IGNOREPOS) && sv && SvTYPE(sv) >= SVt_PVMG
+           && SvMAGIC(sv) && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
+           PL_reg_ganch = strbeg + mg->mg_len;
        else
-           s = fbm_instr((unsigned char*)s + start_shift,
-                         (unsigned char*)strend - end_shift,
-               prog->check_substr, PL_multiline ? FBMrf_MULTILINE : 0);
-       if (!s) {
-           ++BmUSEFUL(prog->check_substr);     /* hooray */
-           goto phooey;        /* not present */
-       }
-       else if (s - stringarg > prog->check_offset_max &&
-                (UTF 
-                   ? ((t = reghopmaybe_c(s, -(prog->check_offset_max))) && t >= stringarg)
-                   : (t = s - prog->check_offset_max) != 0
-                )
-               )
-       {
-           ++BmUSEFUL(prog->check_substr);     /* hooray/2 */
-           s = t;
-       }
-       else if (!(prog->reganch & ROPT_NAUGHTY)
-                  && --BmUSEFUL(prog->check_substr) < 0
-                  && prog->check_substr == prog->float_substr) { /* boo */
-           SvREFCNT_dec(prog->check_substr);
-           prog->check_substr = Nullsv;        /* disable */
-           prog->float_substr = Nullsv;        /* clear */
-           s = startpos;
+           PL_reg_ganch = startpos;
+       if (prog->reganch & ROPT_ANCH_GPOS) {
+           if (s > PL_reg_ganch)
+               goto phooey;
+           s = PL_reg_ganch;
        }
-       else
-           s = startpos;
     }
 
-    DEBUG_r(if (!PL_colorset) reginitcolors());
-    DEBUG_r(PerlIO_printf(Perl_debug_log, 
+    if (!(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) {
+       re_scream_pos_data d;
+
+       d.scream_olds = &scream_olds;
+       d.scream_pos = &scream_pos;
+       s = re_intuit_start(prog, sv, s, strend, flags, &d);
+       if (!s)
+           goto phooey;        /* not present */
+    }
+
+    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",
                      PL_colors[4],PL_colors[5],PL_colors[0],
                      prog->precomp,
                      PL_colors[1],
                      (strlen(prog->precomp) > 60 ? "..." : ""),
-                     PL_colors[0], 
+                     PL_colors[0],
                      (strend - startpos > 60 ? 60 : strend - startpos),
                      startpos, PL_colors[1],
                      (strend - startpos > 60 ? "..." : ""))
        );
 
-    if (prog->reganch & ROPT_GPOS_SEEN) {
-       MAGIC *mg;
-
-       if (!(flags & REXEC_IGNOREPOS) && sv && SvTYPE(sv) >= SVt_PVMG
-           && SvMAGIC(sv) && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
-           PL_reg_ganch = strbeg + mg->mg_len;
-       else
-           PL_reg_ganch = startpos;
-    }
-
     /* Simplest case:  anchored match need be tried only once. */
     /*  [unless only anchor is BOL and multiline is set] */
     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
-       if (regtry(prog, startpos))
+       if (s == startpos && regtry(prog, startpos))
            goto got_it;
        else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
                 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
        {
+           char *end;
+
            if (minlen)
                dontbother = minlen - 1;
-           strend = HOPc(strend, -dontbother);
+           end = HOPc(strend, -dontbother) - 1;
            /* for multiline we only have to try after newlines */
-           if (s > startpos)
-               s--;
-           while (s < strend) {
-               if (*s++ == '\n') {     /* don't need PL_utf8skip here */
-                   if (s < strend && regtry(prog, s))
+           if (prog->check_substr) {
+               while (1) {
+                   if (regtry(prog, s))
                        goto got_it;
-               }
+                   if (s >= end)
+                       goto phooey;
+                   s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
+                   if (!s)
+                       goto phooey;
+               }               
+           } else {
+               if (s > startpos)
+                   s--;
+               while (s < end) {
+                   if (*s++ == '\n') { /* don't need PL_utf8skip here */
+                       if (regtry(prog, s))
+                           goto got_it;
+                   }
+               }               
            }
        }
        goto phooey;
@@ -448,7 +610,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     /* Messy cases:  unanchored match. */
     if (prog->anchored_substr && prog->reganch & ROPT_SKIP) { 
        /* we have /x+whatever/ */
-       /* it must be a one character string */
+       /* it must be a one character string (XXXX Except UTF?) */
        char ch = SvPVX(prog->anchored_substr)[0];
        if (UTF) {
            while (s < strend) {
index 9da5bd4..5d787e0 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -17,38 +17,13 @@ struct regnode {
 
 typedef struct regnode regnode;
 
-struct reg_data {
-    U32 count;
-    U8 *what;
-    void* data[1];
-};
-
-struct reg_substr_datum {
-    I32 min_offset;
-    I32 max_offset;
-    SV *substr;
-};
-
-struct reg_substr_data {
-    struct reg_substr_datum data[3];   /* Actual array */
-};
+struct reg_substr_data;
 
 typedef struct regexp {
        I32 *startp;
        I32 *endp;
        regnode *regstclass;
-#if 0
-        SV *anchored_substr;   /* Substring at fixed position wrt start. */
-       I32 anchored_offset;    /* Position of it. */
-        SV *float_substr;      /* Substring at variable position wrt start. */
-       I32 float_min_offset;   /* Minimal position of it. */
-       I32 float_max_offset;   /* Maximal position of it. */
-        SV *check_substr;      /* Substring to check before matching. */
-        I32 check_offset_min;  /* Offset of the above. */
-        I32 check_offset_max;  /* Offset of the above. */
-#else
         struct reg_substr_data *substrs;
-#endif
        char *precomp;          /* pre-compilation regular expression */
         struct reg_data *data; /* Additional data. */
        char *subbeg;           /* saved or original string 
@@ -64,29 +39,20 @@ typedef struct regexp {
        regnode program[1];     /* Unwarranted chumminess with compiler. */
 } regexp;
 
-#define anchored_substr substrs->data[0].substr
-#define anchored_offset substrs->data[0].min_offset
-#define float_substr substrs->data[1].substr
-#define float_min_offset substrs->data[1].min_offset
-#define float_max_offset substrs->data[1].max_offset
-#define check_substr substrs->data[2].substr
-#define check_offset_min substrs->data[2].min_offset
-#define check_offset_max substrs->data[2].max_offset
-
-#define ROPT_ANCH              (ROPT_ANCH_BOL|ROPT_ANCH_MBOL|ROPT_ANCH_GPOS)
-#define ROPT_ANCH_SINGLE       (ROPT_ANCH_BOL|ROPT_ANCH_GPOS)
+#define ROPT_ANCH              (ROPT_ANCH_BOL|ROPT_ANCH_MBOL|ROPT_ANCH_GPOS|ROPT_ANCH_SBOL)
+#define ROPT_ANCH_SINGLE       (ROPT_ANCH_SBOL|ROPT_ANCH_GPOS)
 #define ROPT_ANCH_BOL          0x00001
 #define ROPT_ANCH_MBOL         0x00002
-#define ROPT_ANCH_GPOS         0x00004
-#define ROPT_SKIP              0x00008
-#define ROPT_IMPLICIT          0x00010 /* Converted .* to ^.* */
-#define ROPT_NOSCAN            0x00020 /* Check-string always at start. */
-#define ROPT_GPOS_SEEN         0x00040
-#define ROPT_CHECK_ALL         0x00080
-#define ROPT_LOOKBEHIND_SEEN   0x00100
-#define ROPT_EVAL_SEEN         0x00200
-#define ROPT_TAINTED_SEEN      0x00400
-#define ROPT_ANCH_SBOL         0x00800
+#define ROPT_ANCH_SBOL         0x00004
+#define ROPT_ANCH_GPOS         0x00008
+#define ROPT_SKIP              0x00010
+#define ROPT_IMPLICIT          0x00020 /* Converted .* to ^.* */
+#define ROPT_NOSCAN            0x00040 /* Check-string always at start. */
+#define ROPT_GPOS_SEEN         0x00080
+#define ROPT_CHECK_ALL         0x00100
+#define ROPT_LOOKBEHIND_SEEN   0x00200
+#define ROPT_EVAL_SEEN         0x00400
+#define ROPT_TAINTED_SEEN      0x00800
 
 /* 0xf800 of reganch is used by PMf_COMPILETIME */
 
@@ -94,6 +60,19 @@ typedef struct regexp {
 #define ROPT_NAUGHTY           0x20000 /* how exponential is this pattern? */
 #define ROPT_COPY_DONE         0x40000 /* subbeg is a copy of the string */
 
+#define RE_USE_INTUIT_NOML     0x0100000 /* Best to intuit before matching */
+#define RE_USE_INTUIT_ML       0x0200000
+#define REINT_AUTORITATIVE_NOML        0x0400000 /* Can trust a positive answer */
+#define REINT_AUTORITATIVE_ML  0x0800000 
+#define REINT_ONCE_NOML                0x1000000 /* Intuit can succed once only. */
+#define REINT_ONCE_ML          0x2000000
+#define RE_INTUIT_ONECHAR      0x4000000
+#define RE_INTUIT_TAIL         0x8000000
+
+#define RE_USE_INTUIT          (RE_USE_INTUIT_NOML|RE_USE_INTUIT_ML)
+#define REINT_AUTORITATIVE     (REINT_AUTORITATIVE_NOML|REINT_AUTORITATIVE_ML)
+#define REINT_ONCE             (REINT_ONCE_NOML|REINT_ONCE_ML)
+
 #define RX_MATCH_TAINTED(prog) ((prog)->reganch & ROPT_TAINTED_SEEN)
 #define RX_MATCH_TAINTED_on(prog) ((prog)->reganch |= ROPT_TAINTED_SEEN)
 #define RX_MATCH_TAINTED_off(prog) ((prog)->reganch &= ~ROPT_TAINTED_SEEN)
@@ -108,18 +87,22 @@ typedef struct regexp {
                                         ? RX_MATCH_COPIED_on(prog) \
                                         : RX_MATCH_COPIED_off(prog))
 
-#define REXEC_COPY_STR 1               /* Need to copy the string. */
-#define REXEC_CHECKED  2               /* check_substr already checked. */
-#define REXEC_SCREAM   4               /* use scream table. */
-#define REXEC_IGNOREPOS        8               /* \G matches at start. */
+#define REXEC_COPY_STR 0x01            /* Need to copy the string. */
+#define REXEC_CHECKED  0x02            /* check_substr already checked. */
+#define REXEC_SCREAM   0x04            /* use scream table. */
+#define REXEC_IGNOREPOS        0x08            /* \G matches at start. */
 #define REXEC_NOT_FIRST        0x10            /* This is another iteration of //g. */
+#define REXEC_ML       0x20            /* $* was set. */
 
 #define ReREFCNT_inc(re) ((re && re->refcnt++), re)
-#define ReREFCNT_dec(re) pregfree(re)
+#define ReREFCNT_dec(re) CALLREGFREE(aTHX_ re)
 
 #define FBMcf_TAIL_DOLLAR      1
-#define FBMcf_TAIL_Z           2
-#define FBMcf_TAIL_z           4
-#define FBMcf_TAIL             (FBMcf_TAIL_DOLLAR|FBMcf_TAIL_Z|FBMcf_TAIL_z)
+#define FBMcf_TAIL_DOLLARM     2
+#define FBMcf_TAIL_Z           4
+#define FBMcf_TAIL_z           8
+#define FBMcf_TAIL             (FBMcf_TAIL_DOLLAR|FBMcf_TAIL_DOLLARM|FBMcf_TAIL_Z|FBMcf_TAIL_z)
 
 #define FBMrf_MULTILINE        1
+
+struct re_scream_pos_data_s;
diff --git a/sv.c b/sv.c
index 282baf9..a61d2ea 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -435,12 +435,12 @@ S_more_xiv(pTHX)
 STATIC XPVNV*
 S_new_xnv(pTHX)
 {
-    double* xnv;
+    NV* xnv;
     LOCK_SV_MUTEX;
     if (!PL_xnv_root)
        more_xnv();
     xnv = PL_xnv_root;
-    PL_xnv_root = *(double**)xnv;
+    PL_xnv_root = *(NV**)xnv;
     UNLOCK_SV_MUTEX;
     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 }
@@ -448,9 +448,9 @@ S_new_xnv(pTHX)
 STATIC void
 S_del_xnv(pTHX_ XPVNV *p)
 {
-    double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+    NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
     LOCK_SV_MUTEX;
-    *(double**)xnv = PL_xnv_root;
+    *(NV**)xnv = PL_xnv_root;
     PL_xnv_root = xnv;
     UNLOCK_SV_MUTEX;
 }
@@ -458,17 +458,17 @@ S_del_xnv(pTHX_ XPVNV *p)
 STATIC void
 S_more_xnv(pTHX)
 {
-    register double* xnv;
-    register double* xnvend;
-    New(711, xnv, 1008/sizeof(double), double);
-    xnvend = &xnv[1008 / sizeof(double) - 1];
-    xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
+    register NV* xnv;
+    register NV* xnvend;
+    New(711, xnv, 1008/sizeof(NV), NV);
+    xnvend = &xnv[1008 / sizeof(NV) - 1];
+    xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
     PL_xnv_root = xnv;
     while (xnv < xnvend) {
-       *(double**)xnv = (double*)(xnv + 1);
+       *(NV**)xnv = (NV*)(xnv + 1);
        xnv++;
     }
-    *(double**)xnv = 0;
+    *(NV**)xnv = 0;
 }
 
 STATIC XRV*
@@ -631,7 +631,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
     U32                cur;
     U32                len;
     IV         iv;
-    double     nv;
+    NV         nv;
     MAGIC*     magic;
     HV*                stash;
 
@@ -656,7 +656,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
        cur     = 0;
        len     = 0;
        iv      = SvIVX(sv);
-       nv      = (double)SvIVX(sv);
+       nv      = (NV)SvIVX(sv);
        del_XIV(SvANY(sv));
        magic   = 0;
        stash   = 0;
@@ -683,7 +683,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
        cur     = 0;
        len     = 0;
        iv      = (IV)pv;
-       nv      = (double)(unsigned long)pv;
+       nv      = (NV)(unsigned long)pv;
        del_XRV(SvANY(sv));
        magic   = 0;
        stash   = 0;
@@ -1017,7 +1017,7 @@ Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
 }
 
 void
-Perl_sv_setnv(pTHX_ register SV *sv, double num)
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
 {
     SV_CHECK_THINKFIRST(sv);
     switch (SvTYPE(sv)) {
@@ -1049,7 +1049,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, double num)
 }
 
 void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, double num)
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
 {
     sv_setnv(sv,num);
     SvSETMAGIC(sv);
@@ -1181,7 +1181,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_PVNV);
 
        (void)SvIOK_on(sv);
-       if (SvNVX(sv) < (double)IV_MAX + 0.5)
+       if (SvNVX(sv) < (NV)IV_MAX + 0.5)
            SvIVX(sv) = I_V(SvNVX(sv));
        else {
            SvUVX(sv) = U_V(SvNVX(sv));
@@ -1208,7 +1208,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
        if (numtype & IS_NUMBER_NOT_IV) {
            /* May be not an integer.  Need to cache NV if we cache IV
             * - otherwise future conversion to NV will be wrong.  */
-           double d;
+           NV d;
 
            d = Atof(SvPVX(sv));
 
@@ -1217,10 +1217,14 @@ Perl_sv_2iv(pTHX_ register SV *sv)
            SvNVX(sv) = d;
            (void)SvNOK_on(sv);
            (void)SvIOK_on(sv);
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                 "0x%lx 2nv(%g)\n",(unsigned long)sv,
-                                 SvNVX(sv)));
-           if (SvNVX(sv) < (double)IV_MAX + 0.5)
+#if defined(USE_LONG_DOUBLE)
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
+#else
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
+#endif
+           if (SvNVX(sv) < (NV)IV_MAX + 0.5)
                SvIVX(sv) = I_V(SvNVX(sv));
            else {
                SvUVX(sv) = U_V(SvNVX(sv));
@@ -1348,7 +1352,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
        if (numtype & IS_NUMBER_NOT_IV) {
            /* May be not an integer.  Need to cache NV if we cache IV
             * - otherwise future conversion to NV will be wrong.  */
-           double d;
+           NV d;
 
            d = Atof(SvPVX(sv));        /* XXXX 64-bit? */
 
@@ -1357,9 +1361,13 @@ Perl_sv_2uv(pTHX_ register SV *sv)
            SvNVX(sv) = d;
            (void)SvNOK_on(sv);
            (void)SvIOK_on(sv);
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                 "0x%lx 2nv(%g)\n",(unsigned long)sv,
-                                 SvNVX(sv)));
+#if defined(USE_LONG_DOUBLE)
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
+#else
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
+#endif
            if (SvNVX(sv) < -0.5) {
                SvIVX(sv) = I_V(SvNVX(sv));
                goto ret_zero;
@@ -1420,7 +1428,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
 }
 
-double
+NV
 Perl_sv_2nv(pTHX_ register SV *sv)
 {
     if (!sv)
@@ -1437,9 +1445,9 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        }
        if (SvIOKp(sv)) {
            if (SvIsUV(sv)) 
-               return (double)SvUVX(sv);
+               return (NV)SvUVX(sv);
            else
-               return (double)SvIVX(sv);
+               return (NV)SvIVX(sv);
        }       
         if (!SvROK(sv)) {
            if (!(SvFLAGS(sv) & SVs_PADTMP)) {
@@ -1455,7 +1463,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
          SV* tmpstr;
          if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
              return SvNV(tmpstr);
-         return (double)(unsigned long)SvRV(sv);
+         return (NV)(unsigned long)SvRV(sv);
        }
        if (SvREADONLY(sv)) {
            dTHR;
@@ -1466,9 +1474,9 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            }
            if (SvIOKp(sv)) {
                if (SvIsUV(sv)) 
-                   return (double)SvUVX(sv);
+                   return (NV)SvUVX(sv);
                else
-                   return (double)SvIVX(sv);
+                   return (NV)SvIVX(sv);
            }
            if (ckWARN(WARN_UNINITIALIZED))
                Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
@@ -1480,19 +1488,28 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_PVNV);
        else
            sv_upgrade(sv, SVt_NV);
+#if defined(USE_LONG_DOUBLE)
+       DEBUG_c({
+           RESTORE_NUMERIC_STANDARD();
+           PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
+                         (unsigned long)sv, SvNVX(sv));
+           RESTORE_NUMERIC_LOCAL();
+       });
+#else
        DEBUG_c({
            RESTORE_NUMERIC_STANDARD();
-           PerlIO_printf(Perl_debug_log,
-                         "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv));
+           PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
+                         (unsigned long)sv, SvNVX(sv));
            RESTORE_NUMERIC_LOCAL();
        });
+#endif
     }
     else if (SvTYPE(sv) < SVt_PVNV)
        sv_upgrade(sv, SVt_PVNV);
     if (SvIOKp(sv) &&
            (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
     {
-       SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
+       SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
     }
     else if (SvPOKp(sv) && SvLEN(sv)) {
        dTHR;
@@ -1510,12 +1527,21 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        return 0.0;
     }
     SvNOK_on(sv);
+#if defined(USE_LONG_DOUBLE)
+    DEBUG_c({
+       RESTORE_NUMERIC_STANDARD();
+       PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                     (unsigned long)sv, SvNVX(sv));
+       RESTORE_NUMERIC_LOCAL();
+    });
+#else
     DEBUG_c({
        RESTORE_NUMERIC_STANDARD();
-       PerlIO_printf(Perl_debug_log,
-                     "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv));
+       PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
+                     (unsigned long)sv, SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     });
+#endif
     return SvNVX(sv);
 }
 
@@ -1523,7 +1549,7 @@ STATIC IV
 S_asIV(pTHX_ SV *sv)
 {
     I32 numtype = looks_like_number(sv);
-    double d;
+    NV d;
 
     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
        return atol(SvPVX(sv));         /* XXXX 64-bit? */
@@ -3754,13 +3780,13 @@ Perl_sv_inc(pTHX_ register SV *sv)
     if (flags & SVp_IOK) {
        if (SvIsUV(sv)) {
            if (SvUVX(sv) == UV_MAX)
-               sv_setnv(sv, (double)UV_MAX + 1.0);
+               sv_setnv(sv, (NV)UV_MAX + 1.0);
            else
                (void)SvIOK_only_UV(sv);
                ++SvUVX(sv);
        } else {
            if (SvIVX(sv) == IV_MAX)
-               sv_setnv(sv, (double)IV_MAX + 1.0);
+               sv_setnv(sv, (NV)IV_MAX + 1.0);
            else {
                (void)SvIOK_only(sv);
                ++SvIVX(sv);
@@ -3863,7 +3889,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
            }       
        } else {
            if (SvIVX(sv) == IV_MIN)
-               sv_setnv(sv, (double)IV_MIN - 1.0);
+               sv_setnv(sv, (NV)IV_MIN - 1.0);
            else {
                (void)SvIOK_only(sv);
                --SvIVX(sv);
@@ -3981,7 +4007,7 @@ Perl_newSVpvf(pTHX_ const char* pat, ...)
 }
 
 SV *
-Perl_newSVnv(pTHX_ double n)
+Perl_newSVnv(pTHX_ NV n)
 {
     register SV *sv;
 
@@ -4273,7 +4299,7 @@ Perl_sv_uv(pTHX_ register SV *sv)
     return sv_2uv(sv);
 }
 
-double
+NV
 Perl_sv_nv(pTHX_ register SV *sv)
 {
     if (SvNOK(sv))
@@ -4449,7 +4475,7 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
 }
 
 SV*
-Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
+Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
 {
     sv_setnv(newSVrv(rv,classname), nv);
     return rv;
@@ -4733,7 +4759,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        unsigned base;
        IV iv;
        UV uv;
-       double nv;
+       NV nv;
        STRLEN have;
        STRLEN need;
        STRLEN gap;
@@ -5051,7 +5077,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            /* This is evil, but floating point is even more evil */
 
            if (args)
-               nv = va_arg(*args, double);
+               nv = va_arg(*args, NV);
            else
                nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
 
@@ -5078,6 +5104,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            eptr = ebuf + sizeof ebuf;
            *--eptr = '\0';
            *--eptr = c;
+#ifdef USE_LONG_DOUBLE
+           *--eptr = 'L';
+#endif
            if (has_precis) {
                base = precis;
                do { *--eptr = '0' + (base % 10); } while (base /= 10);
diff --git a/sv.h b/sv.h
index 8eddc57..5787da3 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -196,7 +196,7 @@ struct xpvnv {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
 };
 
 /* These structure must match the beginning of struct xpvhv in hv.h. */
@@ -205,7 +205,7 @@ struct xpvmg {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 };
@@ -215,7 +215,7 @@ struct xpvlv {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 
@@ -230,7 +230,7 @@ struct xpvgv {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 
@@ -246,7 +246,7 @@ struct xpvbm {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 
@@ -264,7 +264,7 @@ struct xpvfm {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 
@@ -292,7 +292,7 @@ struct xpvio {
     STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
     STRLEN     xpv_len;        /* allocated size */
     IV         xiv_iv;         /* integer value or pv offset */
-    double     xnv_nv;         /* numeric value, if any */
+    NV         xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 
index a442367..c823393 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -170,9 +170,16 @@ PERLVAR(Treg_oldsaved,     char*)          /* old saved substr during match */
 PERLVAR(Treg_oldsavedlen, STRLEN)      /* old length of saved substr during match */
 
 PERLVARI(Tregcompp,    regcomp_t, FUNC_NAME_TO_PTR(Perl_pregcomp))
-                                       /* Pointer to RE compiler */
+                                       /* Pointer to REx compiler */
 PERLVARI(Tregexecp,    regexec_t, FUNC_NAME_TO_PTR(Perl_regexec_flags))
-                                       /* Pointer to RE executer */
+                                       /* Pointer to REx executer */
+PERLVARI(Tregint_start,        re_intuit_start_t, FUNC_NAME_TO_PTR(Perl_re_intuit_start))
+                                       /* Pointer to optimized REx executer */
+PERLVARI(Tregint_string,re_intuit_string_t, FUNC_NAME_TO_PTR(Perl_re_intuit_string))
+                                       /* Pointer to optimized REx string */
+PERLVARI(Tregfree,     regfree_t, FUNC_NAME_TO_PTR(Perl_pregfree))
+                                       /* Pointer to REx free()er */
+
 PERLVARI(Treginterp_cnt,int,       0)  /* Whether `Regexp'
                                                   was interpolated. */
 PERLVARI(Treg_starttry,        char *,     0)  /* -Dr: where regtry was called. */
diff --git a/toke.c b/toke.c
index dd8742b..7849152 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -5953,7 +5953,7 @@ Perl_scan_num(pTHX_ char *start)
     register char *d;                  /* destination in temp buffer */
     register char *e;                  /* end of temp buffer */
     I32 tryiv;                         /* used to see if it can be an int */
-    double value;                      /* number read, as a double */
+    NV value;                          /* number read, as a double */
     SV *sv;                            /* place to put the converted number */
     I32 floatit;                       /* boolean: int or float? */
     char *lastub = 0;                  /* position of last underbar */
@@ -6169,7 +6169,7 @@ Perl_scan_num(pTHX_ char *start)
           conversion at all.
        */
        tryiv = I_V(value);
-       if (!floatit && (double)tryiv == value)
+       if (!floatit && (NV)tryiv == value)
            sv_setiv(sv, tryiv);
        else
            sv_setnv(sv, value);
index 3e5547a..032a536 100644 (file)
@@ -183,7 +183,7 @@ XS(XS_UNIVERSAL_VERSION)
     GV *gv;
     SV *sv;
     char *undef;
-    double req;
+    NV req;
 
     if(SvROK(ST(0))) {
         sv = (SV*)SvRV(ST(0));
diff --git a/util.c b/util.c
index 3655cef..242a308 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2630,7 +2630,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi
 }
 
 U32
-Perl_cast_ulong(pTHX_ double f)
+Perl_cast_ulong(pTHX_ NV f)
 {
     long along;
 
@@ -2667,7 +2667,7 @@ Perl_cast_ulong(pTHX_ double f)
 #endif
 
 I32
-Perl_cast_i32(pTHX_ double f)
+Perl_cast_i32(pTHX_ NV f)
 {
     if (f >= I32_MAX)
        return (I32) I32_MAX;
@@ -2677,12 +2677,12 @@ Perl_cast_i32(pTHX_ double f)
 }
 
 IV
-Perl_cast_iv(pTHX_ double f)
+Perl_cast_iv(pTHX_ NV f)
 {
     if (f >= IV_MAX) {
        UV uv;
        
-       if (f >= (double)UV_MAX)
+       if (f >= (NV)UV_MAX)
            return (IV) UV_MAX; 
        uv = (UV) f;
        return (IV)uv;
@@ -2693,7 +2693,7 @@ Perl_cast_iv(pTHX_ double f)
 }
 
 UV
-Perl_cast_uv(pTHX_ double f)
+Perl_cast_uv(pTHX_ NV f)
 {
     if (f >= MY_UV_MAX)
        return (UV) MY_UV_MAX;
@@ -3235,6 +3235,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     PL_maxscream = -1;
     PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
     PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
+    PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
+    PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
+    PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
     PL_regindent = 0;
     PL_reginterp_cnt = 0;
     PL_lastscream = Nullsv;
@@ -3303,7 +3306,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
  * So it is in perl for (say) POSIX to use. 
  * Needed for SunOS with Sun's 'acc' for example.
  */
-double 
+NV 
 Perl_huge(void)
 {
  return HUGE_VAL;
@@ -3506,22 +3509,23 @@ Perl_my_fflush_all(pTHX)
 #endif
 }
 
-double
+NV
 Perl_my_atof(pTHX_ const char* s) {
 #ifdef USE_LOCALE_NUMERIC
     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
-       double x, y;
+       NV x, y;
 
-       x = atof(s);
+       x = Perl_atof(s);
        SET_NUMERIC_STANDARD();
-       y = atof(s);
+       y = Perl_atof(s);
        SET_NUMERIC_LOCAL();
        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
            return y;
        return x;
-    } else
-       return atof(s);
+    }
+    else
+       return Perl_atof(s);
 #else
-    return atof(s);
+    return Perl_atof(s);
 #endif
 }