From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Tue, 6 Jul 1999 09:28:48 +0000 (+0000)
Subject: Integrate with Sarathy.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cad2e5aadfceb1a406f657488ea1c699f44a1487;p=p5sagit%2Fp5-mst-13.2.git
Integrate with Sarathy.
p4raw-id: //depot/cfgperl@3609
---
diff --git a/Changes b/Changes
index c1b80ca..87d97f4 100644
--- 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
--- 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 */
diff --git a/bytecode.pl b/bytecode.pl
index 1e18d55..4d318ff 100644
--- a/bytecode.pl
+++ b/bytecode.pl
@@ -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
--- 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
--- 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
--- 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
--- a/embed.h
+++ b/embed.h
@@ -448,6 +448,8 @@
#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
@@ -1762,6 +1764,8 @@
#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)
@@ -3486,6 +3490,10 @@
#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
diff --git a/embed.pl b/embed.pl
index d7c5a87..ed7f3e4 100755
--- 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
diff --git a/embedvar.h b/embedvar.h
index dbd94e9..f759b63 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -85,8 +85,11 @@
#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)
@@ -212,8 +215,11 @@
#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)
@@ -854,8 +860,11 @@
#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
@@ -992,8 +1001,11 @@
#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)
diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h
index 9d597fb..04a05e4 100644
--- a/ext/ByteLoader/bytecode.h
+++ b/ext/ByteLoader/bytecode.h
@@ -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 { \
diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c
index 544a59f..035578f 100644
--- a/ext/ByteLoader/byterun.c
+++ b/ext/ByteLoader/byterun.c
@@ -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;
}
diff --git a/ext/DB_File/Changes b/ext/DB_File/Changes
index 82d9af5..236af0f 100644
--- a/ext/DB_File/Changes
+++ b/ext/DB_File/Changes
@@ -237,3 +237,12 @@
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.
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index 7e6c907..7dd1d26 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -1,10 +1,10 @@
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (Paul.Marquess@btinternet.com)
-# last modified 6th March 1999
-# version 1.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.
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index be584a2..ed3a7fa 100644
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -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.
@@ -89,6 +92,11 @@
#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 */
diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap
index 8e4dacb..a614cc4 100644
--- a/ext/DB_File/typemap
+++ b/ext/DB_File/typemap
@@ -1,8 +1,8 @@
# typemap for Perl 5 interface to Berkeley
#
# written by Paul Marquess <Paul.Marquess@btinternet.com>
-# last modified 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
diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm
index 42bb6d2..aff0152 100644
--- a/ext/GDBM_File/GDBM_File.pm
+++ b/ext/GDBM_File/GDBM_File.pm
@@ -59,7 +59,7 @@ require DynaLoader;
GDBM_WRITER
);
-$VERSION = "1.02";
+$VERSION = "1.03";
sub AUTOLOAD {
my($constname);
diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index db28891..be1817b 100644
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -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
diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm
index cad800a..8db59ee 100644
--- a/ext/NDBM_File/NDBM_File.pm
+++ b/ext/NDBM_File/NDBM_File.pm
@@ -12,7 +12,7 @@ require DynaLoader;
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.02";
+$VERSION = "1.03";
bootstrap NDBM_File $VERSION;
diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs
index 60b141e..29cc288 100644
--- a/ext/NDBM_File/NDBM_File.xs
+++ b/ext/NDBM_File/NDBM_File.xs
@@ -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
diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm
index 572318b..0af875d 100644
--- a/ext/ODBM_File/ODBM_File.pm
+++ b/ext/ODBM_File/ODBM_File.pm
@@ -8,7 +8,7 @@ require DynaLoader;
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.01";
+$VERSION = "1.02";
bootstrap ODBM_File $VERSION;
diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index 9ad794d..7601c34 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/ext/ODBM_File/ODBM_File.xs
@@ -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
diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm
index 006bbbd..34c9717 100644
--- a/ext/SDBM_File/SDBM_File.pm
+++ b/ext/SDBM_File/SDBM_File.pm
@@ -8,7 +8,7 @@ require DynaLoader;
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.01" ;
+$VERSION = "1.02" ;
bootstrap SDBM_File $VERSION;
diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs
index e8711f4..c2e940b 100644
--- a/ext/SDBM_File/SDBM_File.xs
+++ b/ext/SDBM_File/SDBM_File.xs
@@ -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
diff --git a/ext/re/Makefile.PL b/ext/re/Makefile.PL
index 040b085..bd0f1f7 100644
--- a/ext/re/Makefile.PL
+++ b/ext/re/Makefile.PL
@@ -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' },
);
diff --git a/ext/re/re.xs b/ext/re/re.xs
index b49a110..10e44f7 100644
--- a/ext/re/re.xs
+++ b/ext/re/re.xs
@@ -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;
}
diff --git a/global.sym b/global.sym
index efbca1d..87ece3c 100644
--- a/global.sym
+++ b/global.sym
@@ -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
--- 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 */
diff --git a/intrpvar.h b/intrpvar.h
index 0bf826e..5cff858 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -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
--- 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
diff --git a/objXSUB.h b/objXSUB.h
index d14de86..d91f84d 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -546,10 +546,16 @@
#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
@@ -2426,6 +2432,14 @@
#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
--- 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
--- 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
--- 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
--- 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
--- a/pp.h
+++ b/pp.h
@@ -88,43 +88,43 @@
#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); \
diff --git a/pp_ctl.c b/pp_ctl.c
index 64e695b..21d0335 100644
--- 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;
diff --git a/pp_hot.c b/pp_hot.c
index d3a1f5c..697c306 100644
--- 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);
diff --git a/pp_sys.c b/pp_sys.c
index 483ddce..ca4f464 100644
--- 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
--- 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);
diff --git a/regcomp.c b/regcomp.c
index 76ae523..59fe5a7 100644
--- 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)
diff --git a/regcomp.h b/regcomp.h
index 7c5c13a..518add0 100644
--- 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
diff --git a/regexec.c b/regexec.c
index 7dbf6dc..c97f89e 100644
--- 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) {
diff --git a/regexp.h b/regexp.h
index 9da5bd4..5d787e0 100644
--- 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
--- 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
--- 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 */
diff --git a/thrdvar.h b/thrdvar.h
index a442367..c823393 100644
--- 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
--- 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);
diff --git a/universal.c b/universal.c
index 3e5547a..032a536 100644
--- a/universal.c
+++ b/universal.c
@@ -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
--- 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
}