This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
added patch for overloading constants, made PERL_OBJECT-aware
authorIlya Zakharevich <ilya@math.berkeley.edu>
Fri, 26 Jun 1998 23:28:41 +0000 (19:28 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 29 Jun 1998 06:01:35 +0000 (06:01 +0000)
Message-Id: <199806270328.XAA21088@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@1259

19 files changed:
ObjXSub.h
embed.h
embedvar.h
global.sym
hv.c
interp.sym
intrpvar.h
lib/Math/BigInt.pm
lib/overload.pm
objpp.h
op.c
perl.c
perl.h
pp_ctl.c
proto.h
scope.c
scope.h
t/pragma/overload.t
toke.c

index 53796df..b0890a0 100644 (file)
--- a/ObjXSub.h
+++ b/ObjXSub.h
 #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
diff --git a/embed.h b/embed.h
index c367ac7..53607f1 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
index e77abbc..e0c0920 100644 (file)
 #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
index ea5b20f..61bba97 100644 (file)
@@ -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
diff --git a/hv.c b/hv.c
index 6d6c3ce..3966b1f 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -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)
 {
index 8e38117..66e539b 100644 (file)
@@ -66,6 +66,7 @@ formtarget
 generation
 gensym
 globalstash
+hintgv
 in_clean_all
 in_clean_objs
 in_eval
index 2ecde8d..ea5159a 100644 (file)
@@ -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 *)
index 013e55f..bbd15e4 100644 (file)
@@ -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
index c9044db..dfcdb02 100644 (file)
@@ -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
diff --git a/objpp.h b/objpp.h
index 75f8e69..94837c7 100644 (file)
--- a/objpp.h
+++ b/objpp.h
 #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
diff --git a/op.c b/op.c
index 6d3a6d3..7c5587e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;
 }
diff --git a/perl.c b/perl.c
index 0a675ea..14357b7 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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);
diff --git a/perl.h b/perl.h
index 3d20cf6..4a26b15 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -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))
index 82ee92a..f1c0669 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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);
diff --git a/proto.h b/proto.h
index 0beb384..0479480 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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
diff --git a/scope.c b/scope.c
index 5958aba..c95ae54 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -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");
        }
diff --git a/scope.h b/scope.h
index cc349f0..2bccd63 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -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))
     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.
index 42d0457..05035c6 100755 (executable)
@@ -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}
diff --git a/toke.c b/toke.c
index 6738dc1..1c098ab 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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;
     }