diff options
| -rw-r--r-- | ObjXSub.h | 6 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | embedvar.h | 3 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | hv.c | 39 | ||||
| -rw-r--r-- | interp.sym | 1 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | lib/Math/BigInt.pm | 19 | ||||
| -rw-r--r-- | lib/overload.pm | 94 | ||||
| -rw-r--r-- | objpp.h | 6 | ||||
| -rw-r--r-- | op.c | 12 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | perl.h | 7 | ||||
| -rw-r--r-- | pp_ctl.c | 6 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | scope.c | 7 | ||||
| -rw-r--r-- | scope.h | 10 | ||||
| -rwxr-xr-x | t/pragma/overload.t | 82 | ||||
| -rw-r--r-- | toke.c | 125 |
19 files changed, 409 insertions, 19 deletions
@@ -210,6 +210,8 @@ #define he_root pPerl->Perl_he_root #undef hexdigit #define hexdigit pPerl->Perl_hexdigit +#undef hintgv +#define hintgv pPerl->Perl_hintgv #undef hints #define hints pPerl->Perl_hints #undef hv_fetch_ent_mh @@ -1333,6 +1335,8 @@ #define newHVREF pPerl->Perl_newHVREF #undef newHV #define newHV pPerl->Perl_newHV +#undef newHVhv +#define newHVhv pPerl->Perl_newHVhv #undef newIO #define newIO pPerl->Perl_newIO #undef newLISTOP @@ -1574,6 +1578,8 @@ #define save_hash pPerl->Perl_save_hash #undef save_helem #define save_helem pPerl->Perl_save_helem +#undef save_hints +#define save_hints pPerl->Perl_save_hints #undef save_hptr #define save_hptr pPerl->Perl_save_hptr #undef save_I16 @@ -384,6 +384,7 @@ #define newGVgen Perl_newGVgen #define newHV Perl_newHV #define newHVREF Perl_newHVREF +#define newHVhv Perl_newHVhv #define newIO Perl_newIO #define newLISTOP Perl_newLISTOP #define newLOGOP Perl_newLOGOP @@ -869,6 +870,7 @@ #define save_gp Perl_save_gp #define save_hash Perl_save_hash #define save_helem Perl_save_helem +#define save_hints Perl_save_hints #define save_hptr Perl_save_hptr #define save_int Perl_save_int #define save_item Perl_save_item diff --git a/embedvar.h b/embedvar.h index e77abbc5f3..e0c09203e8 100644 --- a/embedvar.h +++ b/embedvar.h @@ -137,6 +137,7 @@ #define generation (curinterp->Igeneration) #define gensym (curinterp->Igensym) #define globalstash (curinterp->Iglobalstash) +#define hintgv (curinterp->Ihintgv) #define in_clean_all (curinterp->Iin_clean_all) #define in_clean_objs (curinterp->Iin_clean_objs) #define incgv (curinterp->Iincgv) @@ -311,6 +312,7 @@ #define Igeneration generation #define Igensym gensym #define Iglobalstash globalstash +#define Ihintgv hintgv #define Iin_clean_all in_clean_all #define Iin_clean_objs in_clean_objs #define Iincgv incgv @@ -547,6 +549,7 @@ #define generation Perl_generation #define gensym Perl_gensym #define globalstash Perl_globalstash +#define hintgv Perl_hintgv #define in_clean_all Perl_in_clean_all #define in_clean_objs Perl_in_clean_objs #define incgv Perl_incgv diff --git a/global.sym b/global.sym index ea5b20f3f0..61bba976e4 100644 --- a/global.sym +++ b/global.sym @@ -477,6 +477,7 @@ newGVREF newGVgen newHV newHVREF +newHVhv newIO newLISTOP newLOGOP @@ -924,6 +925,7 @@ save_freesv save_gp save_hash save_helem +save_hints save_hptr save_int save_item @@ -834,6 +834,45 @@ newHV(void) return hv; } +HV * +newHVhv(HV *ohv) +{ + register HV *hv; + register XPVHV* xhv; + STRLEN hv_max = ohv ? HvMAX(ohv) : 0; + STRLEN hv_fill = ohv ? HvFILL(ohv) : 0; + + hv = newHV(); + while (hv_max && hv_max + 1 >= hv_fill * 2) + hv_max = hv_max / 2; /* Is always 2^n-1 */ + ((XPVHV*)SvANY(hv))->xhv_max = hv_max; + if (!hv_fill) + return hv; + +#if 0 + if (!SvRMAGICAL(ohv) || !mg_find((SV*)ohv,'P')) { + /* Quick way ???*/ + } + else +#endif + { + HE *entry; + I32 hv_riter = HvRITER(ohv); /* current root of iterator */ + HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */ + + /* Slow way */ + hv_iterinit(hv); + while (entry = hv_iternext(ohv)) { + hv_store(hv, HeKEY(entry), HeKLEN(entry), + SvREFCNT_inc(HeVAL(entry)), HeHASH(entry)); + } + HvRITER(ohv) = hv_riter; + HvEITER(ohv) = hv_eiter; + } + + return hv; +} + void hv_free_ent(HV *hv, register HE *entry) { diff --git a/interp.sym b/interp.sym index 8e381173e6..66e539b0cf 100644 --- a/interp.sym +++ b/interp.sym @@ -66,6 +66,7 @@ formtarget generation gensym globalstash +hintgv in_clean_all in_clean_objs in_eval diff --git a/intrpvar.h b/intrpvar.h index 2ecde8d482..ea5159a32a 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -19,6 +19,7 @@ PERLVAR(Iorigargv, char **) PERLVAR(Ienvgv, GV *) PERLVAR(Isiggv, GV *) PERLVAR(Iincgv, GV *) +PERLVAR(Ihintgv, GV *) PERLVAR(Iorigfilename, char *) PERLVAR(Idiehook, SV *) PERLVAR(Iwarnhook, SV *) diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 013e55fadb..bbd15e4a88 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -36,6 +36,12 @@ sub stringify { "${$_[0]}" } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on # stringify +sub import { + shift; + return unless @_; + die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; + overload::constant integer => sub {Math::BigInt->new(shift)}; +} $zero = 0; @@ -384,6 +390,19 @@ are not numbers, as well as the result of dividing by zero. '1 23 456 7890' canonical value '+1234567890' +=head1 Autocreating constants + +After C<use Math::BigInt ':constant'> all the integer decimal constants +in the given scope are converted to C<Math::BigInt>. This convertion +happens at compile time. + +In particular + + perl -MMath::BigInt=:constant -e 'print 2**100' + +print the integer value of C<2**100>. Note that without convertion of +constants the expression 2**100 will be calculatted as floating point number. + =head1 BUGS The current version of this module is a preliminary version of the diff --git a/lib/overload.pm b/lib/overload.pm index c9044db0dc..dfcdb02b1e 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -100,6 +100,32 @@ sub mycan { # Real can would leave stubs. return undef; } +%constants = ( + 'integer' => 0x1000, + 'float' => 0x2000, + 'binary' => 0x4000, + 'q' => 0x8000, + 'qr' => 0x10000, + ); + +sub constant { + # Arguments: what, sub + while (@_) { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]} | 0x20000; + shift, shift; + } +} + +sub remove_constant { + # Arguments: what, sub + while (@_) { + delete $^H{$_[0]}; + $^H &= ~ $constants{$_[0]}; + shift, shift; + } +} + 1; __END__ @@ -522,6 +548,72 @@ Returns C<undef> or a reference to the method that implements C<op>. =back +=head1 Overloading constants + +For some application Perl parser mangles constants too much. It is possible +to hook into this process via overload::constant() and overload::remove_constant() +functions. + +These functions take a hash as an argument. The recognized keys of this hash +are + +=over 8 + +=item integer + +to overload integer constants, + +=item float + +to overload floating point constants, + +=item binary + +to overload octal and hexadecimal constants, + +=item q + +to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted +strings and here-documents, + +=item qr + +to overload constant pieces of regular expressions. + +=back + +The corresponding values are references to functions which take three arguments: +the first one is the I<initial> string form of the constant, the second one +is how Perl interprets this constant, the third one is how the constant is used. +Note that the initial string form does not +contain string delimiters, and has backslashes in backslash-delimiter +combinations stripped (thus the value of delimiter is not relevant for +processing of this string). The return value of this function is how this +constant is going to be interpreted by Perl. The third argument is undefined +unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote +context (comes from strings, regular expressions, and single-quote HERE +documents), it is C<tr> for arguments of C<tr>/C<y> operators, +it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise. + +Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>, +it is expected that overloaded constant strings are equipped with reasonable +overloaded catenation operator, otherwise absurd results will result. +Similarly, negative numbers are considered as negations of positive constants. + +Note that it is probably meaningless to call the functions overload::constant() +and overload::remove_constant() from anywhere but import() and unimport() methods. +From these methods they may be called as + + sub import { + shift; + return unless @_; + die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant'; + overload::constant integer => sub {Math::BigInt->new(shift)}; + } + +B<BUGS> Currently overloaded-ness of constants does not propagate +into C<eval '...'>. + =head1 IMPLEMENTATION What follows is subject to change RSN. @@ -597,6 +689,8 @@ C<fallback> is present (possibly undefined). This may create interesting effects if some package is not overloaded, but inherits from two overloaded packages. +Barewords are not covered by overloaded string constants. + This document is confusing. =cut @@ -803,6 +803,8 @@ #define newHVREF CPerlObj::Perl_newHVREF #undef newHV #define newHV CPerlObj::Perl_newHV +#undef newHVhv +#define newHVhv CPerlObj::Perl_newHVhv #undef newIO #define newIO CPerlObj::Perl_newIO #undef newLISTOP @@ -839,6 +841,8 @@ #define newUNOP CPerlObj::Perl_newUNOP #undef newWHILEOP #define newWHILEOP CPerlObj::Perl_newWHILEOP +#undef new_constant +#define new_constant CPerlObj::new_constant #undef new_logop #define new_logop CPerlObj::new_logop #undef new_stackinfo @@ -1111,6 +1115,8 @@ #define save_hek CPerlObj::save_hek #undef save_helem #define save_helem CPerlObj::Perl_save_helem +#undef save_hints +#define save_hints CPerlObj::Perl_save_hints #undef save_hptr #define save_hptr CPerlObj::Perl_save_hptr #undef save_I16 @@ -1518,11 +1518,21 @@ scope(OP *o) return o; } +void +save_hints(void) +{ + SAVEI32(hints); + SAVESPTR(GvHV(hintgv)); + GvHV(hintgv) = newHVhv(GvHV(hintgv)); + SAVEFREESV(GvHV(hintgv)); +} + int block_start(int full) { dTHR; int retval = savestack_ix; + SAVEI32(comppad_name_floor); if (full) { if ((comppad_name_fill = AvFILLp(comppad_name)) > 0) @@ -1537,7 +1547,7 @@ block_start(int full) SAVEI32(padix_floor); padix_floor = padix; pad_reset_pending = FALSE; - SAVEI32(hints); + SAVEHINTS(); hints &= ~HINT_BLOCK_SCOPE; return retval; } @@ -453,6 +453,7 @@ perl_destruct(register PerlInterpreter *sv_interp) envgv = Nullgv; siggv = Nullgv; incgv = Nullgv; + hintgv = Nullgv; errgv = Nullgv; argvgv = Nullgv; argvoutgv = Nullgv; @@ -1870,6 +1871,8 @@ init_main_stash(void) HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(incgv); + hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ + GvMULTI_on(hintgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); GvMULTI_on(errgv); @@ -1816,6 +1816,13 @@ typedef enum { #define HINT_STRICT_VARS 0x00000400 #define HINT_LOCALE 0x00000800 +#define HINT_NEW_INTEGER 0x00001000 +#define HINT_NEW_FLOAT 0x00002000 +#define HINT_NEW_BINARY 0x00004000 +#define HINT_NEW_STRING 0x00008000 +#define HINT_NEW_RE 0x00010000 +#define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */ + /* Various states of an input record separator SV (rs, nrs) */ #define RsSNARF(sv) (! SvOK(sv)) #define RsSIMPLE(sv) (SvOK(sv) && SvCUR(sv)) @@ -2224,7 +2224,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) introduced within evals. See force_ident(). GSAR 96-10-12 */ safestr = savepv(tmpbuf); SAVEDELETE(defstash, safestr, strlen(safestr)); - SAVEI32(hints); + SAVEHINTS(); #ifdef OP_IN_REGISTER opsave = op; #else @@ -2552,7 +2552,7 @@ PP(pp_require) rsfp = tryrsfp; name = savepv(name); SAVEFREEPV(name); - SAVEI32(hints); + SAVEHINTS(); hints = 0; /* switch to eval mode */ @@ -2612,7 +2612,7 @@ PP(pp_entereval) introduced within evals. See force_ident(). GSAR 96-10-12 */ safestr = savepv(tmpbuf); SAVEDELETE(defstash, safestr, strlen(safestr)); - SAVEI32(hints); + SAVEHINTS(); hints = op->op_targ; push_return(op->op_next); @@ -339,6 +339,7 @@ VIRTUAL GV* newGVgen _((char* pack)); VIRTUAL OP* newGVREF _((I32 type, OP* o)); VIRTUAL OP* newHVREF _((OP* o)); VIRTUAL HV* newHV _((void)); +VIRTUAL HV* newHVhv _((HV* hv)); VIRTUAL IO* newIO _((void)); VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); VIRTUAL OP* newPMOP _((I32 type, I32 flags)); @@ -481,6 +482,7 @@ VIRTUAL void save_freepv _((char* pv)); VIRTUAL void save_gp _((GV* gv, I32 empty)); VIRTUAL HV* save_hash _((GV* gv)); VIRTUAL void save_helem _((HV* hv, SV *key, SV **sptr)); +VIRTUAL void save_hints _((void)); VIRTUAL void save_hptr _((HV** hptr)); VIRTUAL void save_I16 _((I16* intp)); VIRTUAL void save_I32 _((I32* intp)); @@ -750,6 +752,7 @@ I32 sublex_start _((void)); int uni _((I32 f, char *s)); #endif char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append)); +SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)); int ao _((int toketype)); void depcom _((void)); #ifdef WIN32 @@ -806,6 +806,13 @@ leave_scope(I32 base) case SAVEt_OP: op = (OP*)SSPOPPTR; break; + case SAVEt_NOHINTS: + if (GvHV(hintgv)) { + SvREFCNT_dec((SV*)GvHV(hintgv)); + GvHV(hintgv) = NULL; + } + *(I32*)&hints = (I32)SSPOPINT; + break; default: croak("panic: leave_scope inconsistency"); } @@ -25,6 +25,7 @@ #define SAVEt_AELEM 24 #define SAVEt_HELEM 25 #define SAVEt_OP 26 +#define SAVEt_NOHINTS 27 #define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow() #define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i)) @@ -94,7 +95,14 @@ SSPUSHINT(SAVEt_STACK_POS); \ } STMT_END #define SAVEOP() save_op() - +#define SAVEHINTS() STMT_START { \ + if (hints & HINT_LOCALIZE_HH) \ + save_hints(); \ + else { \ + SSPUSHINT(hints); \ + SSPUSHINT(SAVEt_NOHINTS); \ + } \ + } STMT_END /* A jmpenv packages the state required to perform a proper non-local jump. * Note that there is a start_env initialized when perl starts, and top_env * points to this initially, so top_env should always be non-null. diff --git a/t/pragma/overload.t b/t/pragma/overload.t index 42d045741d..05035c612d 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -48,7 +48,20 @@ $| = 1; print "1..",&last,"\n"; sub test { - $test++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0} + $test++; + if (@_ > 1) { + if ($_[0] eq $_[1]) { + print "ok $test\n"; + } else { + print "not ok $test: '$_[0]' ne '$_[1]'\n"; + } + } else { + if (shift) { + print "ok $test\n"; + } else { + print "not ok $test\n"; + } + } } $a = new Oscalar "087"; @@ -359,5 +372,70 @@ test(($aI | 3) eq '_<<_xx_<<_'); # 114 # warn $aII << 3; test(($aII << 3) eq '_<<_087_<<_'); # 115 +{ + BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } + $out = 2**10; +} +test($int, 9); # 116 +test($out, 1024); # 117 + +$foo = 'foo'; +$foo1 = 'f\'o\\o'; +{ + BEGIN { $q = $qr = 7; + overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, + 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } + $out = 'foo'; + $out1 = 'f\'o\\o'; + $out2 = "a\a$foo,\,"; + /b\b$foo.\./; +} + +test($out, 'foo'); # 118 +test($out, $foo); # 119 +test($out1, 'f\'o\\o'); # 120 +test($out1, $foo1); # 121 +test($out2, "a\afoo,\,"); # 122 +test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 +test($q, 11); # 124 +test("@qr", "b\\b qq .\\. qq"); # 125 +test($qr, 9); # 126 + +{ + $_ = '!<b>!foo!<-.>!'; + BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, + 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } + $out = 'foo'; + $out1 = 'f\'o\\o'; + $out2 = "a\a$foo,\,"; + $res = /b\b$foo.\./; + $a = <<EOF; +oups +EOF + $b = <<'EOF'; +oups1 +EOF + $c = bareword; + m'try it'; + s'first part'second part'; + s/yet another/tail here/; + tr/z-Z/z-Z/; +} + +test($out, '_<foo>_'); # 117 +test($out1, '_<f\'o\\o>_'); # 128 +test($out2, "_<a\a>_foo_<,\,>_"); # 129 +test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups + qq oups1 + q second part q tail here s z-Z tr z-Z tr"); # 130 +test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 +test($res, 1); # 132 +test($a, "_<oups +>_"); # 133 +test($b, "_<oups1 +>_"); # 134 +test($c, "bareword"); # 135 + + # Last test is: -sub last {115} +sub last {135} @@ -50,6 +50,7 @@ static int uni _((I32 f, char *s)); #endif static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append)); static void restore_rsfp _((void *f)); +static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)); static void restore_expect _((void *e)); static void restore_lex_expect _((void *e)); #endif /* PERL_OBJECT */ @@ -586,20 +587,23 @@ tokeq(SV *sv) register char *s; register char *send; register char *d; - STRLEN len; + STRLEN len = 0; + SV *pv = sv; if (!SvLEN(sv)) - return sv; + goto finish; s = SvPV_force(sv, len); if (SvIVX(sv) == -1) - return sv; + goto finish; send = s + len; while (s < send && *s != '\\') s++; if (s == send) - return sv; + goto finish; d = s; + if ( hints & HINT_NEW_STRING ) + pv = sv_2mortal(newSVpv(SvPVX(pv), len)); while (s < send) { if (*s == '\\') { if (s + 1 < send && (s[1] == '\\')) @@ -609,7 +613,9 @@ tokeq(SV *sv) } *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); - + finish: + if ( hints & HINT_NEW_STRING ) + return new_constant(NULL, 0, "q", sv, pv, "q"); return sv; } @@ -625,10 +631,19 @@ sublex_start(void) } if (op_type == OP_CONST || op_type == OP_READLINE) { SV *sv = tokeq(lex_stuff); - STRLEN len; - char *p = SvPV(sv, len); - yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len)); - SvREFCNT_dec(sv); + + if (SvTYPE(sv) == SVt_PVIV) { + /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ + STRLEN len; + char *p; + SV *nsv; + + p = SvPV(sv, len); + nsv = newSVpv(p, len); + SvREFCNT_dec(sv); + sv = nsv; + } + yylval.opval = (OP*)newSVOP(op_type, 0, sv); lex_stuff = Nullsv; return THING; } @@ -1021,9 +1036,17 @@ scan_const(char *start) } /* return the substring (via yylval) only if we parsed anything */ - if (s > bufptr) + if (s > bufptr) { + if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) + sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"), + sv, Nullsv, + ( lex_inwhat == OP_TRANS + ? "tr" + : ( (lex_inwhat == OP_SUBST && !lex_inpat) + ? "s" + : "qq"))); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); - else + } else SvREFCNT_dec(sv); return s; } @@ -1657,6 +1680,8 @@ yylex(void) SV *sv = newSVsv(linestr); if (!lex_inpat) sv = tokeq(sv); + else if ( hints & HINT_NEW_RE ) + sv = new_constant(NULL, 0, "qr", sv, sv, "q"); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); s = bufend; } @@ -4687,6 +4712,76 @@ checkcomma(register char *s, char *name, char *what) } } +STATIC SV * +new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) +{ + HV *table = perl_get_hv("\10", FALSE); /* ^H */ + dTHR; + dSP; + BINOP myop; + SV *res; + bool oldcatch = CATCH_GET; + SV **cvp; + SV *cv, *typesv; + char buf[128]; + + if (!table) { + yyerror("%^H is not defined"); + return sv; + } + cvp = hv_fetch(table, key, strlen(key), FALSE); + if (!cvp || !SvOK(*cvp)) { + sprintf(buf,"$^H{%s} is not defined", key); + yyerror(buf); + return sv; + } + sv_2mortal(sv); /* Parent created it permanently */ + cv = *cvp; + if (!pv) + pv = sv_2mortal(newSVpv(s, len)); + if (type) + typesv = sv_2mortal(newSVpv(type, 0)); + else + typesv = &sv_undef; + CATCH_SET(TRUE); + Zero(&myop, 1, BINOP); + myop.op_last = (OP *) &myop; + myop.op_next = Nullop; + myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + + PUSHSTACKi(SI_OVERLOAD); + ENTER; + SAVEOP(); + op = (OP *) &myop; + if (PERLDB_SUB && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; + PUTBACK; + pp_pushmark(ARGS); + + EXTEND(sp, 3); + PUSHs(pv); + PUSHs(sv); + PUSHs(typesv); + PUSHs(cv); + PUTBACK; + + if (op = pp_entersub(ARGS)) + CALLRUNOPS(); + LEAVE; + SPAGAIN; + + res = POPs; + PUTBACK; + CATCH_SET(oldcatch); + POPSTACK; + + if (!SvOK(res)) { + sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key); + yyerror(buf); + } + return SvREFCNT_inc(res); +} + STATIC char * scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { @@ -5539,7 +5634,8 @@ scan_num(char *start) digit: n = u << shift; /* make room for the digit */ - if (!overflowed && (n >> shift) != u) { + if (!overflowed && (n >> shift) != u + && !(hints & HINT_NEW_BINARY)) { warn("Integer overflow in %s number", (shift == 4) ? "hex" : "octal"); overflowed = TRUE; @@ -5555,6 +5651,8 @@ scan_num(char *start) out: sv = NEWSV(92,0); sv_setuv(sv, u); + if ( hints & HINT_NEW_BINARY) + sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); } break; @@ -5656,6 +5754,9 @@ scan_num(char *start) sv_setiv(sv, tryiv); else sv_setnv(sv, value); + if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) ) + sv = new_constant(tokenbuf, d - tokenbuf, + (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; } |