#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
#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
#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
#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
#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
#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)
#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
#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
newGVgen
newHV
newHVREF
+newHVhv
newIO
newLISTOP
newLOGOP
save_gp
save_hash
save_helem
+save_hints
save_hptr
save_int
save_item
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)
{
generation
gensym
globalstash
+hintgv
in_clean_all
in_clean_objs
in_eval
PERLVAR(Ienvgv, GV *)
PERLVAR(Isiggv, GV *)
PERLVAR(Iincgv, GV *)
+PERLVAR(Ihintgv, GV *)
PERLVAR(Iorigfilename, char *)
PERLVAR(Idiehook, SV *)
PERLVAR(Iwarnhook, SV *)
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;
'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
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__
=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.
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
#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
#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
#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
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)
SAVEI32(padix_floor);
padix_floor = padix;
pad_reset_pending = FALSE;
- SAVEI32(hints);
+ SAVEHINTS();
hints &= ~HINT_BLOCK_SCOPE;
return retval;
}
envgv = Nullgv;
siggv = Nullgv;
incgv = Nullgv;
+ hintgv = Nullgv;
errgv = Nullgv;
argvgv = Nullgv;
argvoutgv = Nullgv;
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);
#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))
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
rsfp = tryrsfp;
name = savepv(name);
SAVEFREEPV(name);
- SAVEI32(hints);
+ SAVEHINTS();
hints = 0;
/* switch to eval mode */
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);
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));
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));
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
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");
}
#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))
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.
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";
# 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}
#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 */
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] == '\\'))
}
*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;
}
}
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;
}
}
/* 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;
}
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;
}
}
}
+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)
{
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;
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;
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;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff