----------------
____________________________________________________________________________
+[ 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
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 */
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
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 */
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)
#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 */
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);
#define pregexec Perl_pregexec
#define pregfree Perl_pregfree
#define pregcomp Perl_pregcomp
+#define re_intuit_start Perl_re_intuit_start
+#define re_intuit_string Perl_re_intuit_string
#define regexec_flags Perl_regexec_flags
#define regnext Perl_regnext
#define regprop Perl_regprop
#define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
#define pregfree(a) Perl_pregfree(aTHX_ a)
#define pregcomp(a,b,c) Perl_pregcomp(aTHX_ a,b,c)
+#define re_intuit_start(a,b,c,d,e,f) Perl_re_intuit_start(aTHX_ a,b,c,d,e,f)
+#define re_intuit_string(a) Perl_re_intuit_string(aTHX_ a)
#define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
#define regnext(a) Perl_regnext(aTHX_ a)
#define regprop(a,b) Perl_regprop(aTHX_ a,b)
#define pregfree Perl_pregfree
#define Perl_pregcomp CPerlObj::Perl_pregcomp
#define pregcomp Perl_pregcomp
+#define Perl_re_intuit_start CPerlObj::Perl_re_intuit_start
+#define re_intuit_start Perl_re_intuit_start
+#define Perl_re_intuit_string CPerlObj::Perl_re_intuit_string
+#define re_intuit_string Perl_re_intuit_string
#define Perl_regexec_flags CPerlObj::Perl_regexec_flags
#define regexec_flags Perl_regexec_flags
#define Perl_regnext CPerlObj::Perl_regnext
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
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
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|...
|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
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
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
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
#define PL_regeol (my_perl->Tregeol)
#define PL_regexecp (my_perl->Tregexecp)
#define PL_regflags (my_perl->Tregflags)
+#define PL_regfree (my_perl->Tregfree)
#define PL_regindent (my_perl->Tregindent)
#define PL_reginput (my_perl->Treginput)
+#define PL_regint_start (my_perl->Tregint_start)
+#define PL_regint_string (my_perl->Tregint_string)
#define PL_reginterp_cnt (my_perl->Treginterp_cnt)
#define PL_reglastparen (my_perl->Treglastparen)
#define PL_regnarrate (my_perl->Tregnarrate)
#define PL_regeol (PL_curinterp->Tregeol)
#define PL_regexecp (PL_curinterp->Tregexecp)
#define PL_regflags (PL_curinterp->Tregflags)
+#define PL_regfree (PL_curinterp->Tregfree)
#define PL_regindent (PL_curinterp->Tregindent)
#define PL_reginput (PL_curinterp->Treginput)
+#define PL_regint_start (PL_curinterp->Tregint_start)
+#define PL_regint_string (PL_curinterp->Tregint_string)
#define PL_reginterp_cnt (PL_curinterp->Treginterp_cnt)
#define PL_reglastparen (PL_curinterp->Treglastparen)
#define PL_regnarrate (PL_curinterp->Tregnarrate)
#define PL_Tregeol PL_regeol
#define PL_Tregexecp PL_regexecp
#define PL_Tregflags PL_regflags
+#define PL_Tregfree PL_regfree
#define PL_Tregindent PL_regindent
#define PL_Treginput PL_reginput
+#define PL_Tregint_start PL_regint_start
+#define PL_Tregint_string PL_regint_string
#define PL_Treginterp_cnt PL_reginterp_cnt
#define PL_Treglastparen PL_reglastparen
#define PL_Tregnarrate PL_regnarrate
#define PL_regeol (thr->Tregeol)
#define PL_regexecp (thr->Tregexecp)
#define PL_regflags (thr->Tregflags)
+#define PL_regfree (thr->Tregfree)
#define PL_regindent (thr->Tregindent)
#define PL_reginput (thr->Treginput)
+#define PL_regint_start (thr->Tregint_start)
+#define PL_regint_string (thr->Tregint_string)
#define PL_reginterp_cnt (thr->Treginterp_cnt)
#define PL_reglastparen (thr->Treglastparen)
#define PL_regnarrate (thr->Tregnarrate)
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 { \
}
case INSN_XNV: /* 21 */
{
- double arg;
- BGET_double(arg);
+ NV arg;
+ BGET_NV(arg);
SvNVX(bytecode_sv) = arg;
break;
}
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.
# 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.
use Carp;
-$VERSION = "1.66" ;
+$VERSION = "1.67" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
$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 ;
=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
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.
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.
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>.
=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.
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
1.65 - Fixed a bug in the PUSH logic.
Added BOOT check that using 2.3.4 or greater
1.66 - Added DBM filter code
+ 1.67 - Backed off the use of newSVpvn.
+ Fixed DBM Filter code for Perl 5.004.
+ Fixed a small memory leak in the filter code.
#endif
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+#define DEFSV GvSV(defgv)
+#endif
+
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
* shortly #included by the <db.h>) __attribute__ to the possibly
* already defined __attribute__, for example by GNUC or by Perl. */
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) ;*/ \
}
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
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);
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
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);
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);
#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 ; \
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_key) ;
- OUTPUT:
- RETVAL
SV *
filter_store_key(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_key) ;
- OUTPUT:
- RETVAL
SV *
filter_fetch_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_value) ;
- OUTPUT:
- RETVAL
SV *
filter_store_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
- OUTPUT:
- RETVAL
#endif /* DBM_FILTERING */
# 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
#
$var.size = (int)PL_na;
DBT_flags($var);
+
OUTPUT
T_dbtkeydatum
GDBM_WRITER
);
-$VERSION = "1.02";
+$VERSION = "1.03";
sub AUTOLOAD {
my($constname);
#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 ; \
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_key) ;
- OUTPUT:
- RETVAL
SV *
filter_store_key(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_key) ;
- OUTPUT:
- RETVAL
SV *
filter_fetch_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_value) ;
- OUTPUT:
- RETVAL
SV *
filter_store_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
- OUTPUT:
- RETVAL
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.02";
+$VERSION = "1.03";
bootstrap NDBM_File $VERSION;
#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 ; \
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_key) ;
- OUTPUT:
- RETVAL
SV *
filter_store_key(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_key) ;
- OUTPUT:
- RETVAL
SV *
filter_fetch_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_value) ;
- OUTPUT:
- RETVAL
SV *
filter_store_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
- OUTPUT:
- RETVAL
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.01";
+$VERSION = "1.02";
bootstrap ODBM_File $VERSION;
#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 ; \
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_key) ;
- OUTPUT:
- RETVAL
SV *
filter_store_key(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_key) ;
- OUTPUT:
- RETVAL
SV *
filter_fetch_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_value) ;
- OUTPUT:
- RETVAL
SV *
filter_store_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
- OUTPUT:
- RETVAL
@ISA = qw(Tie::Hash DynaLoader);
-$VERSION = "1.01" ;
+$VERSION = "1.02" ;
bootstrap SDBM_File $VERSION;
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) ;*/ \
}
#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 ; \
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_key) ;
- OUTPUT:
- RETVAL
SV *
filter_store_key(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_key) ;
- OUTPUT:
- RETVAL
SV *
filter_fetch_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_fetch_value) ;
- OUTPUT:
- RETVAL
SV *
filter_store_value(db, code)
SV * RETVAL = &PL_sv_undef ;
CODE:
setFilter(filter_store_value) ;
- OUTPUT:
- RETVAL
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' },
);
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;
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;
}
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;
}
Perl_pregexec
Perl_pregfree
Perl_pregcomp
+Perl_re_intuit_start
+Perl_re_intuit_string
Perl_regexec_flags
Perl_regnext
Perl_regprop
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 */
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 */
# 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
#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) {
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);
SetLastError(dwErr);
}
#else
- sv_setnv(sv, (double)errno);
+ sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
#endif
#endif
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
#define PL_regexecp pPerl->PL_regexecp
#undef PL_regflags
#define PL_regflags pPerl->PL_regflags
+#undef PL_regfree
+#define PL_regfree pPerl->PL_regfree
#undef PL_regindent
#define PL_regindent pPerl->PL_regindent
#undef PL_reginput
#define PL_reginput pPerl->PL_reginput
+#undef PL_regint_start
+#define PL_regint_start pPerl->PL_regint_start
+#undef PL_regint_string
+#define PL_regint_string pPerl->PL_regint_string
#undef PL_reginterp_cnt
#define PL_reginterp_cnt pPerl->PL_reginterp_cnt
#undef PL_reglastparen
#define Perl_pregcomp pPerl->Perl_pregcomp
#undef pregcomp
#define pregcomp Perl_pregcomp
+#undef Perl_re_intuit_start
+#define Perl_re_intuit_start pPerl->Perl_re_intuit_start
+#undef re_intuit_start
+#define re_intuit_start Perl_re_intuit_start
+#undef Perl_re_intuit_string
+#define Perl_re_intuit_string pPerl->Perl_re_intuit_string
+#undef re_intuit_string
+#define re_intuit_string Perl_re_intuit_string
#undef Perl_regexec_flags
#define Perl_regexec_flags pPerl->Perl_regexec_flags
#undef regexec_flags
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;
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 */
type != OP_NEGATE)
{
IV iv = SvIV(sv);
- if ((double)iv == SvNV(sv)) {
+ if ((NV)iv == SvNV(sv)) {
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
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;
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;
#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
# 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.
#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
#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: */
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 */
#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 */
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;
}
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);
}
if (use_double) {
- double dans;
+ NV dans;
#if 1
/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
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)
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);
djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
- SETn(atan2(left, right));
+ SETn(Perl_atan2(left, right));
RETURN;
}
}
{
djSP; dTARGET; tryAMAGICun(sin);
{
- double value;
+ NV value;
value = POPn;
- value = sin(value);
+ value = Perl_sin(value);
XPUSHn(value);
RETURN;
}
{
djSP; dTARGET; tryAMAGICun(cos);
{
- double value;
+ NV value;
value = POPn;
- value = cos(value);
+ value = Perl_cos(value);
XPUSHn(value);
RETURN;
}
PP(pp_rand)
{
djSP; dTARGET;
- double value;
+ NV value;
if (MAXARG < 1)
value = 1.0;
else
{
djSP; dTARGET; tryAMAGICun(exp);
{
- double value;
+ NV value;
value = POPn;
- value = exp(value);
+ value = Perl_exp(value);
XPUSHn(value);
RETURN;
}
{
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;
}
{
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;
}
{
djSP; dTARGET;
{
- double value = TOPn;
+ NV value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
}
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);
{
djSP; dTARGET; tryAMAGICun(abs);
{
- double value = TOPn;
+ NV value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
double adouble;
I32 checksum = 0;
register U32 culong;
- double cdouble;
+ NV cdouble;
int commas = 0;
#ifdef PERL_NATINT_PACK
int natint; /* native integer */
auint = utf8_to_uv((U8*)s, &along);
s += along;
if (checksum > 32)
- cdouble += (double)auint;
+ cdouble += (NV)auint;
else
culong += auint;
}
Copy(s, &aint, 1, int);
s += sizeof(int);
if (checksum > 32)
- cdouble += (double)aint;
+ cdouble += (NV)aint;
else
culong += aint;
}
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
if (checksum > 32)
- cdouble += (double)auint;
+ cdouble += (NV)auint;
else
culong += auint;
}
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
if (checksum > 32)
- cdouble += (double)along;
+ cdouble += (NV)along;
else
culong += along;
}
#endif
s += SIZE32;
if (checksum > 32)
- cdouble += (double)along;
+ cdouble += (NV)along;
else
culong += along;
}
COPYNN(s, &aulong, sizeof(unsigned long));
s += sizeof(unsigned long);
if (checksum > 32)
- cdouble += (double)aulong;
+ cdouble += (NV)aulong;
else
culong += aulong;
}
aulong = vtohl(aulong);
#endif
if (checksum > 32)
- cdouble += (double)aulong;
+ cdouble += (NV)aulong;
else
culong += aulong;
}
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;
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;
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));
}
}
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));
}
}
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
(checksum > 32 && strchr("iIlLNU", datumtype)) ) {
- double trouble;
+ NV trouble;
adouble = 1.0;
while (checksum >= 16) {
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 {
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");
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);
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);
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) {
#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); \
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;
/* 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);
sprintf(t, "%*.0f",
(int) fieldsize, value);
}
+#endif
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
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;
}
SV *tmpsv;
tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
if (tmpsv) {
- double d;
+ NV d;
if (SvIOK(tmpsv)) {
I32 i = SvIVX(tmpsv);
SV *tmpsv;
tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
if (tmpsv) {
- double d;
+ NV d;
if (SvIOK(tmpsv)) {
I32 i = SvIVX(tmpsv);
SV *tmpsv;
tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
if (tmpsv) {
- double d;
+ NV d;
if (SvIOK(tmpsv)) {
I32 i = SvIVX(tmpsv);
SV *tmpsv;
tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
if (tmpsv) {
- double d;
+ NV d;
if (SvIOK(tmpsv)) {
I32 i = SvIVX(tmpsv);
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;
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;
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)) {
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))
{
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;
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;
}
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)) {
}
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? */
/* 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);
}
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);
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);
goto ret_no;
nope:
- ++BmUSEFUL(rx->check_substr);
-
ret_no:
SPAGAIN;
PUSHs(&PL_sv_no);
register I32 j;
register char *s;
register SV *sv;
- double value;
+ NV value;
I32 maxlen = 0;
I32 nfound;
struct timeval timebuf;
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
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);
}
/* 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 */
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
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
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, ...);
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);
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);
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);
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);
# 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
# 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
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;
}
!(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",
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. */
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, ' ');
#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)
#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
# 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
# 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
}
}
+/*
+ * 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
/* 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;
/* 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) {
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
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 */
#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)
? 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;
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));
}
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;
}
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*
U32 cur;
U32 len;
IV iv;
- double nv;
+ NV nv;
MAGIC* magic;
HV* stash;
cur = 0;
len = 0;
iv = SvIVX(sv);
- nv = (double)SvIVX(sv);
+ nv = (NV)SvIVX(sv);
del_XIV(SvANY(sv));
magic = 0;
stash = 0;
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;
}
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)) {
}
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);
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));
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));
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));
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? */
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;
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
-double
+NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
if (!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)) {
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;
}
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);
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;
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);
}
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? */
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);
}
} 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);
}
SV *
-Perl_newSVnv(pTHX_ double n)
+Perl_newSVnv(pTHX_ NV n)
{
register SV *sv;
return sv_2uv(sv);
}
-double
+NV
Perl_sv_nv(pTHX_ register SV *sv)
{
if (SvNOK(sv))
}
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;
unsigned base;
IV iv;
UV uv;
- double nv;
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
/* 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;
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);
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. */
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 */
};
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 */
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 */
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 */
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 */
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 */
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. */
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 */
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);
GV *gv;
SV *sv;
char *undef;
- double req;
+ NV req;
if(SvROK(ST(0))) {
sv = (SV*)SvRV(ST(0));
}
U32
-Perl_cast_ulong(pTHX_ double f)
+Perl_cast_ulong(pTHX_ NV f)
{
long along;
#endif
I32
-Perl_cast_i32(pTHX_ double f)
+Perl_cast_i32(pTHX_ NV f)
{
if (f >= I32_MAX)
return (I32) I32_MAX;
}
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;
}
UV
-Perl_cast_uv(pTHX_ double f)
+Perl_cast_uv(pTHX_ NV f)
{
if (f >= MY_UV_MAX)
return (UV) MY_UV_MAX;
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;
* 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;
#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
}
projects / p5sagit/p5-mst-13.2.git / commitdiff