diff options
| -rw-r--r-- | Changes | 93 | ||||
| -rw-r--r-- | av.h | 2 | ||||
| -rw-r--r-- | bytecode.pl | 2 | ||||
| -rw-r--r-- | cv.h | 2 | ||||
| -rw-r--r-- | doio.c | 2 | ||||
| -rw-r--r-- | dump.c | 3 | ||||
| -rw-r--r-- | embed.h | 8 | ||||
| -rwxr-xr-x | embed.pl | 26 | ||||
| -rw-r--r-- | embedvar.h | 12 | ||||
| -rw-r--r-- | ext/ByteLoader/bytecode.h | 4 | ||||
| -rw-r--r-- | ext/ByteLoader/byterun.c | 4 | ||||
| -rw-r--r-- | ext/DB_File/Changes | 9 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.pm | 172 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.xs | 50 | ||||
| -rw-r--r-- | ext/DB_File/typemap | 5 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.pm | 2 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.xs | 11 | ||||
| -rw-r--r-- | ext/NDBM_File/NDBM_File.pm | 2 | ||||
| -rw-r--r-- | ext/NDBM_File/NDBM_File.xs | 11 | ||||
| -rw-r--r-- | ext/ODBM_File/ODBM_File.pm | 2 | ||||
| -rw-r--r-- | ext/ODBM_File/ODBM_File.xs | 11 | ||||
| -rw-r--r-- | ext/SDBM_File/SDBM_File.pm | 2 | ||||
| -rw-r--r-- | ext/SDBM_File/SDBM_File.xs | 14 | ||||
| -rw-r--r-- | ext/re/Makefile.PL | 2 | ||||
| -rw-r--r-- | ext/re/re.xs | 16 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | hv.h | 2 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | mg.c | 14 | ||||
| -rw-r--r-- | objXSUB.h | 14 | ||||
| -rw-r--r-- | op.c | 8 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | perl.h | 60 | ||||
| -rw-r--r-- | pp.c | 104 | ||||
| -rw-r--r-- | pp.h | 16 | ||||
| -rw-r--r-- | pp_ctl.c | 27 | ||||
| -rw-r--r-- | pp_hot.c | 173 | ||||
| -rw-r--r-- | pp_sys.c | 16 | ||||
| -rw-r--r-- | proto.h | 24 | ||||
| -rw-r--r-- | regcomp.c | 60 | ||||
| -rw-r--r-- | regcomp.h | 31 | ||||
| -rw-r--r-- | regexec.c | 310 | ||||
| -rw-r--r-- | regexp.h | 93 | ||||
| -rw-r--r-- | sv.c | 121 | ||||
| -rw-r--r-- | sv.h | 14 | ||||
| -rw-r--r-- | thrdvar.h | 11 | ||||
| -rw-r--r-- | toke.c | 4 | ||||
| -rw-r--r-- | universal.c | 2 | ||||
| -rw-r--r-- | util.c | 30 |
49 files changed, 1060 insertions, 548 deletions
@@ -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 @@ -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 1e18d55990..4d318ff4fa 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 @@ -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 */ @@ -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) @@ -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); @@ -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 @@ -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 dbd94e9c51..f759b632ae 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 9d597fbed2..04a05e4251 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 544a59f042..035578f424 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 82d9af5af0..236af0f312 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 7e6c90789f..7dd1d26360 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 be584a2ce6..ed3a7fa3e0 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 8e4dacbdd0..a614cc4c29 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 42bb6d28e8..aff01527dc 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 db28891b79..be1817bba2 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 cad800adf4..8db59ee03c 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 60b141e230..29cc288769 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 572318b0cd..0af875dc36 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 9ad794da89..7601c3433b 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 006bbbd17d..34c971734c 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 e8711f410b..c2e940bf6c 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 040b085f4f..bd0f1f741c 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 b49a110377..10e44f76de 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 efbca1d6ae..87ece3c083 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 @@ -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 0bf826e79a..5cff858675 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 */ @@ -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 @@ -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 @@ -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; @@ -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; @@ -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 */ @@ -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) { @@ -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); \ @@ -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; @@ -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); @@ -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 */ @@ -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); @@ -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) @@ -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 @@ -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) { @@ -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; @@ -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); @@ -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 */ @@ -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. */ @@ -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 3e5547a58d..032a536e55 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)); @@ -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 } |