perl 5.0 alpha 5
authorLarry Wall <larry@netlabs.com>
Fri, 10 Dec 1993 00:00:00 +0000 (00:00 +0000)
committerLarry Wall <larry@netlabs.com>
Fri, 10 Dec 1993 00:00:00 +0000 (00:00 +0000)
[editor's note: the sparc executables have not been included,
and emacs backup files and other cruft such as patch backup files have
been removed.  This was reconstructed from a tarball found on the
September 1994 InfoMagic CD]

48 files changed:
.package [deleted file]
Bugs/mislex [new file with mode: 0644]
Bugs/substleak [new file with mode: 0644]
Changes
README
SDBM_File.c
Todo
av.c
bar [deleted file]
config.h
config_h.SH
doio.c
doop.c
dump.c
ext/dbm/SDBM_File.xs
ext/xsubpp
ext/xsubpp.bak [deleted file]
foo
gv.c
internals [new file with mode: 0644]
keywords.h
lib/bigint.pl
lib/perldb.pl
lib/termcap.pl
make.out
mg.c
op.c
op.h
opcode.h
opcode.pl
peek [new file with mode: 0755]
perl.c
perl.h
perly.c
perly.c.diff
pp.c
proto.h
save_ary.bad [deleted file]
sv.c
sv.h
t/foo [new file with mode: 0755]
t/op/magic.t
t/op/ref.t
t/op/subst.t [moved from t/op/s.t with 100% similarity]
t/perl5a1.tar [deleted file]
toke.c
unixish.h
util.c

deleted file mode 100644 (file)
index a084d4f..0000000
--- a/.package
+++ /dev/null
@@ -1,16 +0,0 @@
-: basic variables
-package=perl
-baserev=4.1
-patchbranch=1
-mydiff='diff -c'
-maintname='Larry Wall'
-maintloc='lwall@netlabs.com'
-ftpsite=''
-orgname='NetLabs, Inc.'
-newsgroups='comp.lang.perl'
-recipients=''
-ftpdir=''
-
-: derivative variables--do not change
-revbranch="$baserev.$patchbranch"
-packver='1'
diff --git a/Bugs/mislex b/Bugs/mislex
new file mode 100644 (file)
index 0000000..07d972b
--- /dev/null
@@ -0,0 +1 @@
+print( STDOUT "hello\n" )
diff --git a/Bugs/substleak b/Bugs/substleak
new file mode 100644 (file)
index 0000000..ff14446
--- /dev/null
@@ -0,0 +1,98 @@
+Return-Path: Martin.Ward@durham.ac.uk
+Return-Path: <Martin.Ward@durham.ac.uk>
+Received: from scalpel.netlabs.com by netlabs.com (4.1/SMI-4.1)
+       id AA01931; Thu, 20 Jan 94 03:56:39 PST
+Received: from netlabs.com (vaccine-eng1.netlabs.com) by scalpel.netlabs.com (4.1/SMI-4.1)
+       id AA09639; Thu, 20 Jan 94 03:56:36 PST
+Received: from sun2.nsfnet-relay.ac.uk by netlabs.com (4.1/SMI-4.1)
+       id AA01923; Thu, 20 Jan 94 03:56:01 PST
+Via: uk.ac.durham; Thu, 20 Jan 1994 11:47:16 +0000
+Received: from easby.dur.ac.uk by durham.ac.uk; Thu, 20 Jan 94 11:47:05 GMT
+Received: from ws-csm3.durham.ac.uk (ws-csm3.dur) by uk.ac.durham.easby;
+          Thu, 20 Jan 94 11:46:29 GMT
+From: Martin.Ward@durham.ac.uk (Martin Ward)
+Date: Thu, 20 Jan 94 11:46:27 GMT
+Message-Id: <AA00871.9401201146.ws-csm3@uk.ac.durham>
+To: des0mpw@easby.durham.ac.uk, lwall@scalpel.netlabs.com
+Subject: Re: My last message
+
+>: After saying I was stumped, I managed to track down the problem!
+>: The problem was caused by a line much higher up:
+>: 
+>: $seqpat = "$bs[s]\000e\000q\000\{\000";       # } hack
+>: 
+>: Changing this by adding {} gives:
+>: 
+>: $seqpat = "${bs}[s]\000e\000q\000\{\000";       # } hack
+>: 
+>: which worked! No idea why :-)
+>
+>It apparently intuited $bs[s] to be an array reference.
+
+Aha! I think the interpretation is:
+"$bs[      s] .....
+^^^^^      ^^
+array ref  Therefore this is an expression, so "s]" is the start of
+           a pattern match/replace, so it scans for ...]....]
+
+I found the line by repeatedly chopping away everything after (and including)
+the line where perl _thought_ the error started. This gradually worked back
+through a nasty cascade of errors!
+
+>: No speed improvement this time (the improvement in user time was swamped
+>: by an increase in system time. This may be because it uses 5048k of
+>: data/stack space, compared with 985k for perl4).
+>
+>That doesn't sound good.  I hope it's a bug.  Does it grow continuously?
+>Hopefully it's just a memory leak.
+
+For perl4 the memory size (shown by top) grows by about 100-150k per 2 seconds,
+for perl5 it grows by about 1 - 1.5 Meg per 2 seconds. I don't use the script
+very often (and I have over 100 Meg of swap space) so its not a big problem.
+Still, with a 124k input file, the size for perl5 went up to 40 Meg!
+
+I have tracked down a memory leak, which is basically one line from the
+texqed script. Store this script in "tmp" and run "perl tmp /vmunix"
+(or some other large random file). Monitor the process using "top" in 
+another window.
+
+Perl4 is OK but perl5 leaks like a leaky cistern.
+
+
+#!/usr/local/bin/perl
+# print a "." every $interval lines:
+$interval = 10;
+open (PAIRS, "$ARGV[0]");
+open (OUT, "> /dev/null");
+$bs = "\\\\" . "\000";
+for (;;) {
+  $line++;
+  if (($line % $interval) == 0) {
+    print STDERR ".";
+  }
+  read(PAIRS, $_, 20);
+  last if ($_ eq "");
+  
+  s/$bs([_^\\])\000/\\\377$1\377/g;
+  
+  print OUT ;
+}
+
+print STDERR "\n";
+
+
+
+I hope you find this useful!
+
+NB Changing the "s/.../.../g" to an "m/.../" (with the same pattern)
+makes the leak go away even on input files where the pattern NEVER matches!!
+
+                       Martin.
+
+JANET: Martin.Ward@uk.ac.durham    Internet (eg US): Martin.Ward@durham.ac.uk
+or if that fails:  Martin.Ward%uk.ac.durham@nsfnet-relay.ac.uk  
+or even: Martin.Ward%DURHAM.AC.UK@CUNYVM.CUNY.EDU
+BITNET: Martin.Ward%durham.ac.uk@UKACRL UUCP:...!uknet!durham!Martin.Ward
+[Last acked 0.7 days ago--not acked]
+
diff --git a/Changes b/Changes
index 9941ea0..4dbcd46 100644 (file)
--- a/Changes
+++ b/Changes
@@ -96,3 +96,7 @@ Incompatibilities
     taintperl is no longer a separate executable.  There is now a -T
     switch to turn on tainting when it isn't turned on automatically.
 
+    Symbols starting with _ are no longer forced into package main, except
+    for $_ itself (and @_, etc.).
+
+    Double-quoted strings may no longer end with an unescaped $.
diff --git a/README b/README
index 59986f1..4c39a20 100644 (file)
--- a/README
+++ b/README
@@ -1,14 +1,15 @@
-[This is an unsupported, pre-release version of Perl 5.0.  It is expected
-to work only on a Sparc architecture machine.  No Configure support is
-provided.  In fact, if you succeed in configuring and making a new
-makefile, you'll probably overwrite the only makefile that works.  Note
-that a Sparc executable comes with the kit, so you may not need to
-compile at all.  There is no list of new features yet, but if you look
-at t/op/ref.t you'll see some of them in use.  perl -Dxst is also fun.]
+This is an unsupported, pre-release version of Perl 5.0.  It is expected
+to work only on a Sparc architecture machine.  NO CONFIGURE SUPPORT IS
+PROVIDED, despite what it says below.  In fact, if you succeed in
+configuring and making a new makefile, you'll probably overwrite the
+only makefile that works.  Note that a SunOS executable comes with the
+kit, so you may not need to compile at all.  See file Changes for a
+list of new features.  If you look at t/op/ref.t you'll see some of
+them in use.  perl -Dxst is also fun.
 
                           Perl Kit, Version 5.0
 
-           Copyright (c) 1989,1990,1991,1992,1993, Larry Wall
+           Copyright (c) 1989,1990,1991,1992,1993,1994  Larry Wall
                            All rights reserved.
 
     This program is free software; you can redistribute it and/or modify
index 23b8356..d6e08c4 100644 (file)
@@ -5,6 +5,7 @@
 
 typedef DBM* SDBM_File;
 #define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
+#define nextkey(db,key) sdbm_nextkey(db)
 
 static int
 XS_SDBM_File_sdbm_new(ix, sp, items)
@@ -42,7 +43,7 @@ register int items;
        SDBM_File       db;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
        sdbm_close(db);
@@ -65,7 +66,7 @@ register int items;
        datum   RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -95,7 +96,7 @@ register int items;
        int     RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -131,7 +132,7 @@ register int items;
        int     RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -158,7 +159,7 @@ register int items;
        datum   RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -170,7 +171,7 @@ register int items;
 }
 
 static int
-XS_SDBM_File_sdbm_nextkey(ix, sp, items)
+XS_SDBM_File_nextkey(ix, sp, items)
 register int ix;
 register int sp;
 register int items;
@@ -184,13 +185,13 @@ register int items;
        datum   RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
        key.dptr = SvPV(ST(2), key.dsize);;
 
-       RETVAL = sdbm_nextkey(db, key);
+       RETVAL = nextkey(db, key);
        ST(0) = sv_mortalcopy(&sv_undef);
        sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
     }
@@ -211,7 +212,7 @@ register int items;
        int     RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -236,7 +237,7 @@ register int items;
        int     RETVAL;
 
        if (sv_isa(ST(1), "SDBM_File"))
-           db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+           db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
        else
            croak("db is not of type SDBM_File");
 
@@ -260,7 +261,7 @@ int items;
     newXSUB("SDBM_File::store", 0, XS_SDBM_File_sdbm_store, file);
     newXSUB("SDBM_File::delete", 0, XS_SDBM_File_sdbm_delete, file);
     newXSUB("SDBM_File::firstkey", 0, XS_SDBM_File_sdbm_firstkey, file);
-    newXSUB("SDBM_File::nextkey", 0, XS_SDBM_File_sdbm_nextkey, file);
+    newXSUB("SDBM_File::nextkey", 0, XS_SDBM_File_nextkey, file);
     newXSUB("SDBM_File::error", 0, XS_SDBM_File_sdbm_error, file);
     newXSUB("SDBM_File::clearerr", 0, XS_SDBM_File_sdbm_clearerr, file);
 }
diff --git a/Todo b/Todo
index f561af4..d073b04 100755 (executable)
--- a/Todo
+++ b/Todo
@@ -8,6 +8,12 @@ Bugs
        perl -c shell_script bug
        fix the need for double ^D on $x
        STDOUT->print("howdy\n");
+       %ENV not there
+       Make "delete $array{$key} while ($key) = each %array" safe
+       using unpack(P,$ref) shouldn't unref the ref
+       binary function is missing
+       wrong line reported for runtime elsif condition error
+       unreference variable warnings busted (but don't warn on $seen{$key}++)
 
 Regexp extensions
        /m  for multiline
@@ -24,6 +30,7 @@ Nice to have
        lexperl
        Bundled perl preprocessor
        FILEHANDLE methods
+       Make $[ compile-time instead of run-time
 
 Optimizations
        Make specialized allocators
@@ -35,6 +42,7 @@ Optimizations
        rcatmaybe
        Shrink opcode tables via multiple implementations selected in peep
        Cache hash value?
+       Optimize away @_ where possible
        sfio?
 
 Need to think more about
@@ -42,9 +50,12 @@ Need to think more about
        When does split() go to @_?
        Figure out BEGIN { ... @ARGV ... }
        Implement eval once?  (Unnecessary with cache?)
-       detect inconsistent linkage when using -DDEBUGGING?
+       Detect inconsistent linkage when using -DDEBUGGING?
+       Populate %SIG at startup if appropriate
+       Multiple levels of warning
 
 Vague possibilities
+       readonly variables
        sub mysplice(@, $, $, ...)
        data prettyprint function?  (or is it, as I suspect, a lib routine?)
        Nested destructors
diff --git a/av.c b/av.c
index 822f935..dd54bd5 100644 (file)
--- a/av.c
+++ b/av.c
@@ -51,15 +51,20 @@ I32 lval;
     }
 
     if (key < 0 || key > AvFILL(av)) {
-       if (lval && key >= 0) {
+       if (key < 0) {
+           key += AvFILL(av) + 1;
+           if (key < 0)
+               return 0;
+       }
+       else {
+           if (!lval)
+               return 0;
            if (AvREAL(av))
                sv = NEWSV(5,0);
            else
                sv = sv_mortalcopy(&sv_undef);
            return av_store(av,key,sv);
        }
-       else
-           return 0;
     }
     if (!AvARRAY(av)[key]) {
        if (lval) {
@@ -80,8 +85,11 @@ SV *val;
     I32 tmp;
     SV** ary;
 
-    if (key < 0)
-       return 0;
+    if (key < 0) {
+       key += AvFILL(av) + 1;
+       if (key < 0)
+           return 0;
+    }
 
     if (SvMAGICAL(av)) {
        if (mg_find((SV*)av,'P')) {
@@ -181,6 +189,7 @@ register SV **strp;
        }
        strp++;
     }
+    SvOK_on(av);
     return av;
 }
 
@@ -207,6 +216,7 @@ register SV **strp;
            SvTEMP_off(*strp);
        strp++;
     }
+    SvOK_on(av);
     return av;
 }
 
diff --git a/bar b/bar
deleted file mode 100755 (executable)
index 43ada97..0000000
--- a/bar
+++ /dev/null
@@ -1,7 +0,0 @@
-#!./perl
-
-$o = {A,1};
-$r = \($o->{A});
-print $$r;
-$$r = foo;
-print $$r;
index 376fa77..09dd7ca 100644 (file)
--- a/config.h
+++ b/config.h
 #define        CASTNEGFLOAT    /**/
 #define        CASTFLAGS 0     /**/
 
+/* CASTI32
+ *     This symbol, if defined, indicates that this C compiler knows how to
+ *     cast negative or large floating point numbers to 32-bit ints.
+ */
+#define CASTI32        /**/
+
 /* CHARSPRINTF
  *     This symbol is defined if this system declares "char *sprintf()" in
  *     stdio.h.  The trend seems to be to declare it as "int sprintf()".  It
index 03667bd..d1747d4 100755 (executable)
@@ -121,6 +121,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
 #$d_castneg    CASTNEGFLOAT    /**/
 #define        CASTFLAGS $castflags    /**/
 
+/* CASTI32
+ *    This symbol, if defined, indicates that this C compiler knows how to
+ *    cast negative or large floating point numbers to 32-bit ints.
+ */
+#define CASTI32
+
 /* CHARSPRINTF
  *     This symbol is defined if this system declares "char *sprintf()" in
  *     stdio.h.  The trend seems to be to declare it as "int sprintf()".  It
diff --git a/doio.c b/doio.c
index 2b8bbf9..d76cefa 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -867,9 +867,6 @@ FILE *fp;
     switch (SvTYPE(sv)) {
     case SVt_NULL:
        return TRUE;
-    case SVt_REF:
-       fprintf(fp, "%s", sv_2pv(sv, &na));
-       return !ferror(fp);
     case SVt_IV:
        if (SvMAGICAL(sv))
            mg_get(sv);
@@ -1378,8 +1375,12 @@ SV **sp;
     {
        if (getinfo)
        {
-           if (SvREADONLY(astr))
-               croak("Can't %s to readonly var", op_name[optype]);
+           if (SvTHINKFIRST(astr)) {
+               if (SvREADONLY(astr))
+                   croak("Can't %s to readonly var", op_name[optype]);
+               if (SvROK(astr))
+                   sv_unref(astr);
+           }
            SvGROW(astr, infosize+1);
            a = SvPV(astr, na);
        }
@@ -1464,8 +1465,12 @@ SV **sp;
     msize = SvIVx(*++mark);
     mtype = (long)SvIVx(*++mark);
     flags = SvIVx(*++mark);
-    if (SvREADONLY(mstr))
-       croak("Can't msgrcv to readonly var");
+    if (SvTHINKFIRST(mstr)) {
+       if (SvREADONLY(mstr))
+           croak("Can't msgrcv to readonly var");
+       if (SvROK(mstr))
+           sv_unref(mstr);
+    }
     mbuf = SvPV(mstr, len);
     if (len < sizeof(long)+msize+1) {
        SvGROW(mstr, sizeof(long)+msize+1);
@@ -1541,8 +1546,12 @@ SV **sp;
        return -1;
     mbuf = SvPV(mstr, len);
     if (optype == OP_SHMREAD) {
-       if (SvREADONLY(mstr))
-           croak("Can't shmread to readonly var");
+       if (SvTHINKFIRST(mstr)) {
+           if (SvREADONLY(mstr))
+               croak("Can't shmread to readonly var");
+           if (SvROK(mstr))
+               sv_unref(mstr);
+       }
        if (len < msize) {
            SvGROW(mstr, msize+1);
            mbuf = SvPV(mstr, len);
diff --git a/doop.c b/doop.c
index fa43e37..146bd24 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -421,8 +421,12 @@ register SV *sv;
 
     if (!sv)
        return;
-    if (SvREADONLY(sv))
-       croak("Can't chop readonly value");
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak("Can't chop readonly value");
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvTYPE(sv) == SVt_PVAV) {
        I32 max;
        SV **array = AvARRAY(sv);
@@ -471,8 +475,12 @@ SV *right;
     register char *rc = SvPV(right, rightlen);
     register I32 len;
 
-    if (SvREADONLY(sv))
-       croak("Can't do %s to readonly value", op_name[optype]);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak("Can't do %s to readonly value", op_name[optype]);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     len = leftlen < rightlen ? leftlen : rightlen;
     if (SvTYPE(sv) < SVt_PV)
        sv_upgrade(sv, SVt_PV);
diff --git a/dump.c b/dump.c
index a51a012..7839ed7 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -66,7 +66,7 @@ GV* gv;
        gv_fullname(sv,gv);
        dump("\nSUB %s = ", SvPVX(sv));
        if (CvUSERSUB(GvCV(gv)))
-           dump("(usersub 0x%x %d)\n",
+           dump("(xsub 0x%x %d)\n",
                (long)CvUSERSUB(GvCV(gv)),
                CvUSERINDEX(GvCV(gv)));
        else if (CvROOT(GvCV(gv)))
index 0b898ad..25cb67c 100644 (file)
@@ -5,6 +5,7 @@
 
 typedef DBM* SDBM_File;
 #define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
+#define nextkey(db,key) sdbm_nextkey(db)
 
 MODULE = SDBM_File     PACKAGE = SDBM_File     PREFIX = sdbm_
 
@@ -43,7 +44,7 @@ sdbm_firstkey(db)
        SDBM_File       db
 
 datum
-sdbm_nextkey(db, key)
+nextkey(db, key)
        SDBM_File       db
        datum           key
 
index 2cc1486..e7a710b 100755 (executable)
@@ -52,30 +52,30 @@ T_STRING
 T_PTR
        $var = ($type)(unsigned long)SvNV($arg)
 T_PTRREF
-       if (SvTYPE($arg) == SVt_REF)
-           $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
+       if (SvROK($arg))
+           $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
        else
            croak(\"$var is not a reference\")
 T_PTROBJ
        if (sv_isa($arg, \"${ntype}\"))
-           $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
+           $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
        else
            croak(\"$var is not of type ${ntype}\")
 T_PTRDESC
        if (sv_isa($arg, \"${ntype}\")) {
-           ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvANY($arg));
+           ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvRV($arg));
            $var = ${type}_desc->ptr;
        }
        else
            croak(\"$var is not of type ${ntype}\")
 T_REFREF
-       if (SvTYPE($arg) == SVt_REF)
-           $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
+       if (SvROK($arg))
+           $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
        else
            croak(\"$var is not a reference\")
 T_REFOBJ
        if (sv_isa($arg, \"${ntype}\"))
-           $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
+           $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
        else
            croak(\"$var is not of type ${ntype}\")
 T_OPAQUE
diff --git a/ext/xsubpp.bak b/ext/xsubpp.bak
deleted file mode 100755 (executable)
index 0f309e3..0000000
+++ /dev/null
@@ -1,529 +0,0 @@
-#!/usr/bin/perl
-# $Header$ 
-
-$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
-die $usage unless (@ARGV >= 2 && @ARGV <= 6);
-
-SWITCH: while ($ARGV[0] =~ /^-/) {
-    $flag = shift @ARGV;
-    $aflag = 1, next SWITCH if $flag =~ /^-a$/;
-    $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
-    $cflag = 1, next SWITCH if $flag =~ /^-c$/;
-    $eflag = 1, next SWITCH if $flag =~ /^-e$/;
-    die $usage;
-}
-
-$typemap = shift @ARGV;
-open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
-while (<TYPEMAP>) {
-       next if /^\s*$/ || /^#/;
-       chop;
-       ($typename, $kind) = split(/\t+/, $_, 2);
-       $type_kind{$typename} = $kind;
-}
-close(TYPEMAP);
-
-%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
-
-T_INT
-       $var = (int)SvIVn($arg)
-T_ENUM
-       $var = ($type)SvIVn($arg)
-T_U_INT
-       $var = (unsigned int)SvIVn($arg)
-T_SHORT
-       $var = (short)SvIVn($arg)
-T_U_SHORT
-       $var = (unsigned short)SvIVn($arg)
-T_LONG
-       $var = (long)SvIVn($arg)
-T_U_LONG
-       $var = (unsigned long)SvIVn($arg)
-T_CHAR
-       $var = (char)*SvPVn($arg,na)
-T_U_CHAR
-       $var = (unsigned char)SvIVn($arg)
-T_FLOAT
-       $var = (float)SvNVn($arg)
-T_DOUBLE
-       $var = SvNVn($arg)
-T_STRING
-       $var = SvPVn($arg,na)
-T_PTR
-       $var = ($type)(unsigned long)SvNVn($arg)
-T_PTRREF
-       if (SvTYPE($arg) == SVt_REF)
-           $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
-       else
-           croak(\"$var is not a reference\")
-T_PTROBJ
-       if (sv_isa($arg, \"${ntype}\"))
-           $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
-       else
-           croak(\"$var is not of type ${ntype}\")
-T_PTRDESC
-       if (sv_isa($arg, \"${ntype}\")) {
-           ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNVn((SV*)SvANY($arg));
-           $var = ${type}_desc->ptr;
-       }
-       else
-           croak(\"$var is not of type ${ntype}\")
-T_REFREF
-       if (SvTYPE($arg) == SVt_REF)
-           $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
-       else
-           croak(\"$var is not a reference\")
-T_REFOBJ
-       if (sv_isa($arg, \"${ntype}\"))
-           $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
-       else
-           croak(\"$var is not of type ${ntype}\")
-T_OPAQUE
-       $var NOT IMPLEMENTED
-T_OPAQUEPTR
-       $var = ($type)SvPVn($arg,na)
-T_PACKED
-       $var = XS_unpack_$ntype($arg)
-T_PACKEDARRAY
-       $var = XS_unpack_$ntype($arg)
-T_CALLBACK
-       $var = make_perl_cb_$type($arg)
-T_ARRAY
-       $var = $ntype(items -= $argoff);
-       U32 ix_$var = $argoff;
-       while (items--) {
-           DO_ARRAY_ELEM;
-       }
-T_DATUM
-       $var.dptr = SvPVn($arg, $var.dsize);
-T_GDATUM
-       UNIMPLEMENTED
-T_PLACEHOLDER
-T_END
-
-$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
-T_INT
-       sv_setiv($arg, (I32)$var);
-T_ENUM
-       sv_setiv($arg, (I32)$var);
-T_U_INT
-       sv_setiv($arg, (I32)$var);
-T_SHORT
-       sv_setiv($arg, (I32)$var);
-T_U_SHORT
-       sv_setiv($arg, (I32)$var);
-T_LONG
-       sv_setiv($arg, (I32)$var);
-T_U_LONG
-       sv_setiv($arg, (I32)$var);
-T_CHAR
-       sv_setpvn($arg, (char *)&$var, 1);
-T_U_CHAR
-       sv_setiv($arg, (I32)$var);
-T_FLOAT
-       sv_setnv($arg, (double)$var);
-T_DOUBLE
-       sv_setnv($arg, $var);
-T_STRING
-       sv_setpv($arg, $var);
-T_PTR
-       sv_setnv($arg, (double)(unsigned long)$var);
-T_PTRREF
-       sv_setptrref($arg, $var);
-T_PTROBJ
-       sv_setptrobj($arg, $var, \"${ntype}\");
-T_PTRDESC
-       sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
-T_REFREF
-       sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
-                   ($var ? (void*)new $ntype($var) : 0));
-T_REFOBJ
-       NOT IMPLEMENTED
-T_OPAQUE
-       sv_setpvn($arg, (char *)&$var, sizeof($var));
-T_OPAQUEPTR
-       sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
-T_PACKED
-       XS_pack_$ntype($arg, $var);
-T_PACKEDARRAY
-       XS_pack_$ntype($arg, $var, count_$ntype);
-T_DATAUNIT     
-       sv_setpvn($arg, $var.chp(), $var.size());
-T_CALLBACK
-       sv_setpvn($arg, $var.context.value().chp(),
-               $var.context.value().size());
-T_ARRAY
-       ST_EXTEND($var.size);
-       for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
-               ST(ix_$var) = sv_mortalcopy(&sv_undef);
-       DO_ARRAY_ELEM
-       }
-       sp += $var.size - 1;
-T_DATUM
-       sv_setpvn($arg, $var.dptr, $var.dsize);
-T_GDATUM
-       sv_usepvn($arg, $var.dptr, $var.dsize);
-T_END
-
-$uvfile = shift @ARGV;
-open(F, $uvfile) || die "cannot open $uvfile\n";
-
-if ($eflag) {
-       print qq|#include "cfm/basic.h"\n|;
-}
-
-while (<F>) {
-       last if ($Module, $foo, $Package, $foo1, $Prefix) =
-               /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
-       print $_;
-}
-$Pack = $Package;
-$Package .= "::" if defined $Package && $Package ne "";
-$/ = "";
-
-while (<F>) {
-       # parse paragraph
-       chop;
-       next if /^\s*$/;
-       next if /^(#.*\n?)+$/;
-       if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
-               $Module = $1;
-               $foo = $2;
-               $Package = $3;
-               $Pack = $Package;
-               $foo1 = $4;
-               $Prefix = $5;
-               $Package .= "::" if defined $Package && $Package ne "";
-               next;
-       }
-       split(/[\t ]*\n/);
-
-       # initialize info arrays
-       undef(%args_match);
-       undef(%var_types);
-       undef(%var_addr);
-       undef(%defaults);
-       undef($class);
-       undef($static);
-       undef($elipsis);
-
-       # extract return type, function name and arguments
-       $ret_type = shift(@_);
-       if ($ret_type =~ /^static\s+(.*)$/) {
-               $static = 1;
-               $ret_type = $1;
-       }
-       $func_header = shift(@_);
-       ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
-       if ($func_name =~ /(.*)::(.*)/) {
-               $class = $1;
-               $func_name = $2;
-       }
-       ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
-       push(@Func_name, "${Pack}_$func_name");
-       push(@Func_pname, $pname);
-       @args = split(/\s*,\s*/, $orig_args);
-       if (defined($class) && !defined($static)) {
-               unshift(@args, "THIS");
-               $orig_args = "THIS, $orig_args";
-               $orig_args =~ s/^THIS, $/THIS/;
-       }
-       $orig_args =~ s/"/\\"/g;
-       $min_args = $num_args = @args;
-       foreach $i (0..$num_args-1) {
-               if ($args[$i] =~ s/\.\.\.//) {
-                       $elipsis = 1;
-                       $min_args--;
-                       if ($args[i] eq '' && $i == $num_args - 1) {
-                           pop(@args);
-                           last;
-                       }
-               }
-               if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
-                       $min_args--;
-                       $args[$i] = $1;
-                       $defaults{$args[$i]} = $2;
-                       $defaults{$args[$i]} =~ s/"/\\"/g;
-               }
-       }
-       if (defined($class) && !defined($static)) {
-               $func_args = join(", ", @args[1..$#args]);
-       } else {
-               $func_args = join(", ", @args);
-       }
-       @args_match{@args} = 1..@args;
-
-       # print function header
-       print <<"EOF" if $aflag;
-static int
-XS_${Pack}_$func_name(int, int sp, int items)
-EOF
-       print <<"EOF" if !$aflag;
-static int
-XS_${Pack}_$func_name(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-EOF
-       print <<"EOF" if $elipsis;
-{
-    if (items < $min_args) {
-       croak("Usage: $pname($orig_args)");
-    }
-EOF
-       print <<"EOF" if !$elipsis;
-{
-    if (items < $min_args || items > $num_args) {
-       croak("Usage: $pname($orig_args)");
-    }
-EOF
-
-# Now do a block of some sort.
-
-$condnum = 0;
-if (!@_) {
-    @_ = "CLEANUP:";
-}
-while (@_) {
-       if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
-               $cond = shift(@_);
-               if ($condnum == 0) {
-                   print "    if ($cond)\n";
-               }
-               elsif ($cond ne '') {
-                   print "    else if ($cond)\n";
-               }
-               else {
-                   print "    else\n";
-               }
-               $condnum++;
-       }
-
-       print           <<"EOF" if $eflag;
-    TRY {
-EOF
-       print           <<"EOF" if !$eflag;
-    {
-EOF
-
-       # do initialization of input variables
-       $thisdone = 0;
-       $retvaldone = 0;
-       $deferred = "";
-       while ($_ = shift(@_)) {
-               last if /^\s*NOT_IMPLEMENTED_YET/;
-               last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
-               ($var_type, $var_name, $var_init) =
-                   /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
-               if ($var_name =~ /^&/) {
-                       $var_name =~ s/^&//;
-                       $var_addr{$var_name} = 1;
-               }
-               $thisdone |= $var_name eq "THIS";
-               $retvaldone |= $var_name eq "RETVAL";
-               $var_types{$var_name} = $var_type;
-               print "\t" . &map_type($var_type);
-               $var_num = $args_match{$var_name};
-               if ($var_addr{$var_name}) {
-                       $func_args =~ s/\b($var_name)\b/&\1/;
-               }
-               if ($var_init !~ /^=\s*NO_INIT\s*$/) {
-                       if ($var_init !~ /^\s*$/) {
-                               &output_init($var_type, $var_num,
-                                   "$var_name $var_init");
-                       } elsif ($var_num) {
-                               # generate initialization code
-                               &generate_init($var_type, $var_num, $var_name);
-                       } else {
-                               print ";\n";
-                       }
-               } else {
-                       print "\t$var_name;\n";
-               }
-       }
-       if (!$thisdone && defined($class) && !defined($static)) {
-               print "\t$class *";
-               $var_types{"THIS"} = "$class *";
-               &generate_init("$class *", 1, "THIS");
-       }
-
-       # do code
-       if (/^\s*NOT_IMPLEMENTED_YET/) {
-               print "\ncroak(\"$pname: not implemented yet\");\n";
-       } else {
-               if ($ret_type ne "void") {
-                       print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
-                               if !$retvaldone;
-                       $args_match{"RETVAL"} = 0;
-                       $var_types{"RETVAL"} = $ret_type;
-               }
-               print $deferred;
-               if (/^\s*CODE:/) {
-                       while ($_ = shift(@_)) {
-                               last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
-                               print "$_\n";
-                       }
-               } else {
-                       print "\n\t";
-                       if ($ret_type ne "void") {
-                               print "RETVAL = ";
-                       }
-                       if (defined($static)) {
-                               print "$class::";
-                       } elsif (defined($class)) {
-                               print "THIS->";
-                       }
-                       if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
-                               $func_name = $2;
-                       }
-                       print "$func_name($func_args);\n";
-                       &generate_output($ret_type, 0, "RETVAL")
-                           unless $ret_type eq "void";
-               }
-       }
-
-       # do output variables
-       if (/^\s*OUTPUT\s*:/) {
-               while ($_ = shift(@_)) {
-                       last if /^\s*CLEANUP\s*:/;
-                       s/^\s+//;
-                       ($outarg, $outcode) = split(/\t+/);
-                       if ($outcode) {
-                       print "\t$outcode\n";
-                       } else {
-                               die "$outarg not an argument"
-                                   unless defined($args_match{$outarg});
-                               $var_num = $args_match{$outarg};
-                               &generate_output($var_types{$outarg}, $var_num,
-                                   $outarg); 
-                       }
-               }
-       }
-       # do cleanup
-       if (/^\s*CLEANUP\s*:/) {
-           while ($_ = shift(@_)) {
-                   last if /^\s*CASE\s*:/;
-                   print "$_\n";
-           }
-       }
-       # print function trailer
-       print <<EOF if $eflag;
-    }
-    BEGHANDLERS
-    CATCHALL
-       croak("%s: %s\\tpropagated", Xname, Xreason);
-    ENDHANDLERS
-EOF
-       print <<EOF if !$eflag;
-    }
-EOF
-       if (/^\s*CASE\s*:/) {
-           unshift(@_, $_);
-       }
-}
-       print <<EOF;
-    return sp;
-}
-
-EOF
-}
-
-# print initialization routine
-print qq/extern "C"\n/ if $cflag;
-print <<"EOF";
-int init_$Module(ix,sp,items)
-int ix;
-int sp;
-int items;
-{
-    char* file = __FILE__;
-
-EOF
-
-for (@Func_name) {
-       $pname = shift(@Func_pname);
-       print "    newXSUB(\"$pname\", 0, XS_$_, file);\n";
-}
-print "}\n";
-
-sub output_init {
-       local($type, $num, $init) = @_;
-       local($arg) = "ST($num)";
-
-       eval qq/print " $init\\\n"/;
-}
-
-sub generate_init {
-       local($type, $num, $var) = @_;
-       local($arg) = "ST($num)";
-       local($argoff) = $num - 1;
-       local($ntype);
-
-       die "$type not in typemap" if !defined($type_kind{$type});
-       ($ntype = $type) =~ s/\s*\*/Ptr/g;
-       $subtype = $ntype;
-       $subtype =~ s/Ptr$//;
-       $subtype =~ s/Array$//;
-       $expr = $input_expr{$type_kind{$type}};
-       if ($expr =~ /DO_ARRAY_ELEM/) {
-           $subexpr = $input_expr{$type_kind{$subtype}};
-           $subexpr =~ s/ntype/subtype/g;
-           $subexpr =~ s/\$arg/ST(ix_$var)/g;
-           $subexpr =~ s/\n\t/\n\t\t/g;
-           $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
-           $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
-           $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
-       }
-       if (defined($defaults{$var})) {
-               $expr =~ s/(\t+)/$1    /g;
-               $expr =~ s/        /\t/g;
-               eval qq/print "\\t$var;\\n"/;
-               $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
-       } elsif ($expr !~ /^\t\$var =/) {
-               eval qq/print "\\t$var;\\n"/;
-               $deferred .= eval qq/"\\n$expr;\\n"/;
-       } else {
-               eval qq/print "$expr;\\n"/;
-       }
-}
-
-sub generate_output {
-       local($type, $num, $var) = @_;
-       local($arg) = "ST($num)";
-       local($argoff) = $num - 1;
-       local($ntype);
-
-       if ($type =~ /^array\(([^,]*),(.*)\)/) {
-               print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
-       } else {
-               die "$type not in typemap" if !defined($type_kind{$type});
-               ($ntype = $type) =~ s/\s*\*/Ptr/g;
-               $ntype =~ s/\(\)//g;
-               $subtype = $ntype;
-               $subtype =~ s/Ptr$//;
-               $subtype =~ s/Array$//;
-               $expr = $output_expr{$type_kind{$type}};
-               if ($expr =~ /DO_ARRAY_ELEM/) {
-                   $subexpr = $output_expr{$type_kind{$subtype}};
-                   $subexpr =~ s/ntype/subtype/g;
-                   $subexpr =~ s/\$arg/ST(ix_$var)/g;
-                   $subexpr =~ s/\$var/${var}[ix_$var]/g;
-                   $subexpr =~ s/\n\t/\n\t\t/g;
-                   $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
-               }
-               elsif ($arg eq 'ST(0)') {
-                   print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
-               }
-               eval "print qq\f$expr\f";
-       }
-}
-
-sub map_type {
-       local($type) = @_;
-
-       if ($type =~ /^array\(([^,]*),(.*)\)/) {
-               return "$1 *";
-       } else {
-               return $type;
-       }
-}
diff --git a/foo b/foo
index 94d9292..8977a26 100755 (executable)
--- a/foo
+++ b/foo
@@ -1,5 +1,12 @@
 #!./perl
 
-# Test the singlequoted eval optimizer
+tie ( @a, TST_tie, "arg1", "arg2" ); 
+$a[2]=[1];
 
-for (1..1) { }
+package TST_tie;
+
+sub new { bless []; }
+
+sub fetch { print "store @_\n" }
+sub store { print "store @_\n" }
+sub delete { print "store @_\n" }
diff --git a/gv.c b/gv.c
index 790e9d7..5e04e52 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -278,6 +278,11 @@ I32 add;
 
     /* set up magic where warranted */
     switch (*name) {
+    case 'a':
+    case 'b':
+       if (len == 1)
+           SvMULTI_on(gv);
+       break;
     case 'I':
        if (strEQ(name, "ISA")) {
            AV* av = GvAVn(gv);
diff --git a/internals b/internals
new file mode 100644 (file)
index 0000000..471ad95
--- /dev/null
+++ b/internals
@@ -0,0 +1,295 @@
+Newsgroups: comp.lang.perl
+Subject: Re: perl5a4:  tie ref restriction?
+Summary: 
+Expires: 
+References: <2h7b64$aai@jethro.Corp.Sun.COM>
+Sender: 
+Followup-To: 
+Distribution: world
+Organization: NetLabs, Inc.
+Keywords: 
+
+In article <2h7b64$aai@jethro.Corp.Sun.COM> Eric.Arnold@Sun.COM writes:
+: Darn:
+:      tie ( @a, TST_tie, "arg1", "arg2" ); 
+:      $a[2]=[1];
+: 
+: produces:
+: 
+:      Can't assign a reference to a magical variable at ./tsttie line 12.
+: 
+: I'm all agog about the "tie" function, but ... if this restriction
+: wasn't there, I think I would be able to tie a top level
+: reference/variable to my own package, and then automatically tie in all
+: subsequently linked vars/references so that I could "tie" any arbitrary thing
+: like:
+:      $r->{key}[el]{key}
+: 
+: to a DBM or other type storage area.
+: 
+: Is the restriction necessary?
+
+In the current storage scheme, yes, but as I mentioned in the other
+article, I can and probably should relax that.  That code is some of
+the oldest Perl 5 code, and I didn't see some things then that I do
+now.
+
+Ok, let me explain some things about how values are stored.  Consider
+this a little design document.
+
+Internally everything is unified to look like a scalar, regardless of
+its type.  There's a type-invariant part of every value, and a
+type-variant part.  When we modify the type of a value, we can do it in
+place because all references point to the invariant part.  All we do is
+swap the variant part for a different part and change that ANY pointer
+in the invariant part to point to the new variant.
+
+The invariant part looks like this:
+
+struct sv {
+    void*      sv_any;         /* pointer to something */
+    U32                sv_refcnt;      /* how many references to us */
+    SVTYPE     sv_type;        /* what sort of thing pointer points to */
+    U8         sv_flags;       /* extra flags, some depending on type */
+    U8         sv_storage;     /* storage class */
+    U8         sv_private;     /* extra value, depending on type */
+};
+
+This is typedefed to SV.  There are other structurally equivalent
+types, AV, HV and CV, that are there merely to help gdb know what kind
+of pointer sv_any is, and provide a little bit of C type-checking.
+Here's a key to Perl naming:
+
+       SV      scalar value
+       AV      array value
+       HV      hash value
+       CV      code value
+
+Additionally I often use names containing
+
+       IV      integer value
+       NV      numeric value (double)
+       PV      pointer value
+       LV      lvalue, such as a substr() or vec() being assigned to
+       BM      a string containing a Boyer-Moore compiled pattern
+       FM      a format line program
+
+You'll notice that in SV there's an sv_type field.  This contains one
+of the following values, which gives the interpretation of sv_any.
+
+typedef enum {
+       SVt_NULL,
+       SVt_REF,
+       SVt_IV,
+       SVt_NV,
+       SVt_PV,
+       SVt_PVIV,
+       SVt_PVNV,
+       SVt_PVMG,
+       SVt_PVLV,
+       SVt_PVAV,
+       SVt_PVHV,
+       SVt_PVCV,
+       SVt_PVGV,
+       SVt_PVBM,
+       SVt_PVFM,
+} svtype;
+
+These are arranged ROUGHLY in order of increasing complexity, though
+there are some discontinuities.  Many of them indicate that sv_any
+points to a struct of a similar name with an X on the front.  They can
+be classified like this:
+
+    SVt_NULL
+       The sv_any doesn't point to anything meaningful.
+
+    SVt_REF
+       The sv_any points to another SV.  (This is what we're talking
+       about changing to work more like IV and NV below.)
+
+    SVt_IV
+    SVt_NV
+       These are a little tricky in order to be efficient in both
+       memory and time.  The sv_any pointer indicates the location of
+       a solitary integer(double), but not directly.  The pointer is
+       really a pointer to an XPVIV(XPVNV), so that if there's a valid
+       integer(double) the same code works regardless of the type of
+       the SV.  They have special allocators that guarantee that, even
+       though sv_any is pointing to a location several words earlier
+       than the integer(double), it never points to unallocated
+       memory.  This does waste a few allocated integers(doubles) at
+       the beginning, but it's probably an overall win.
+
+    SVt_PV
+    SVt_PVIV
+    SVt_PVNV
+    SVt_PVMG
+       These are pretty ordinary, and each is "derived" from the
+       previous in the sense that it just adds more data to the
+       previous structure.
+
+       struct xpv {
+           char *      xpv_pv;         /* pointer to malloced string */
+           STRLEN      xpv_cur;        /* length of xpv_pv as a C string */
+           STRLEN      xpv_len;        /* allocated size */
+       };
+
+           This is your basic string scalar that is never used numerically
+           or magically.
+
+       struct xpviv {
+           char *      xpv_pv;         /* pointer to malloced string */
+           STRLEN      xpv_cur;        /* length of xpv_pv as a C string */
+           STRLEN      xpv_len;        /* allocated size */
+           I32         xiv_iv;         /* integer value or pv offset */
+       };
+
+           This is a string scalar that has either been used as an
+           integer, or an integer that has been used in a string
+           context, or has had the front trimmed off of it, in which
+           case xiv_iv contains how far xpv_pv has been incremented
+           from the original allocated value.
+
+       struct xpvnv {
+           char *      xpv_pv;         /* pointer to malloced string */
+           STRLEN      xpv_cur;        /* length of xpv_pv as a C string */
+           STRLEN      xpv_len;        /* allocated size */
+           I32         xiv_iv;         /* integer value or pv offset */
+           double      xnv_nv;         /* numeric value, if any */
+       };
+
+           This is a string or integer scalar that has been used in a
+           numeric context, or a number that has been used in a string
+           or integer context.
+
+       struct xpvmg {
+           char *      xpv_pv;         /* pointer to malloced string */
+           STRLEN      xpv_cur;        /* length of xpv_pv as a C string */
+           STRLEN      xpv_len;        /* allocated size */
+           I32         xiv_iv;         /* integer value or pv offset */
+           double      xnv_nv;         /* numeric value, if any */
+           MAGIC*      xmg_magic;      /* linked list of magicalness */
+           HV*         xmg_stash;      /* class package */
+       };
+
+           This is the top of the line for ordinary scalars.  This scalar
+           has been charmed with one or more kinds of magical or object
+           behavior.  In addition it can contain any or all of integer,
+           double or string.
+
+    SVt_PVLV
+    SVt_PVAV
+    SVt_PVHV
+    SVt_PVCV
+    SVt_PVGV
+    SVt_PVBM
+    SVt_PVFM
+       These are specialized forms that are never directly visible to
+       the Perl script.  They are independent of each other, and may
+       not be promoted to any other type.
+
+There are several additional data values in the SV structure.  The sv_refcnt
+gives the number of references to this SV.  Some of these references may be
+actual Perl language references, but many other are just internal pointers,
+from a symbol table, or from the syntax tree, for example.  When sv_refcnt
+goes to zero, the value can be safely deallocated.
+
+The sv_storage byte is not very well thought out, but tends to indicate
+something about where the scalar lives.  It's used in allocating
+lexical storage, and at runtime contains an 'O' if the value has been
+blessed as an object.  There may be some conflicts lurking in here, and
+I may eventually claim some of the bits for other purposes.
+
+The sv_flags are currently as follows.  Most of these are set and cleared
+by macros to guarantee their consistency, and you should always use the
+proper macro rather than accessing them directly.
+
+#define SVf_IOK                1               /* has valid integer value */
+#define SVf_NOK                2               /* has valid numeric value */
+#define SVf_POK                4               /* has valid pointer value */
+    These tell whether an integer, double or string value is
+    immediately available without further consideration.  All tainting
+    and magic (but not objecthood) works by turning off these bits and
+    forcing a routine to be executed to discover the real value.  The
+    SvIV(), SvNV() and SvPV() macros that fetch values are smart about
+    all this, and should always be used if possible.  Most of the stuff
+    mentioned below you really don't have to deal with directly.  (Values
+    aren't stored using macros, but using functions sv_setiv(), sv_setnv()
+    and sv_setpv(), plus variants.  You should never have to explicitly
+    follow the sv_any pointer to any X structure in your code.)
+
+#define SVf_OOK                8               /* has valid offset value */
+    This is only on when SVf_IOK is off, and indicates that the unused
+    integer storage is holding an offset for the string pointer value
+    because you've done something like s/^prefix//.
+
+#define SVf_MAGICAL    16              /* has special methods */
+    This indicates not only that sv_type is at least SVt_PVMG, but
+    also that the linked list of magical behaviors is not empty.
+
+#define SVf_OK         32              /* has defined value */
+    This indicates that the value is defined.  Currently it means either
+    that the type if SVt_REF or that one of SVf_IOK, SVf_NOK, or SVf_POK
+    is set.
+
+#define SVf_TEMP       64              /* eventually in sv_private? */
+    This indicates that the string is a temporary allocated by one of
+    the sv_mortal functions, and that any string value may be stolen
+    from it without copying.  (It's important not to steal the value if
+    the temporary will continue to require the value, however.)
+
+#define SVf_READONLY   128             /* may not be modified */
+    This scalar value may not be modified.  Any function that might modify
+    a scalar should check for this first, and reject the operation when
+    inappropriate.  Currently only the builtin values for sv_undef, sv_yes
+    and sv_no are marked readonly, but eventually we may provide a language
+    to set this bit.
+
+The sv_private byte contains some additional bits that apply across the
+board.  Really private bits (that depend on the type) are allocated from
+128 down.
+
+#define SVp_IOK                1               /* has valid non-public integer value */
+#define SVp_NOK                2               /* has valid non-public numeric value */
+#define SVp_POK                4               /* has valid non-public pointer value */
+    These shadow the bits in sv_flags for tainted variables, indicated that
+    there really is a valid value available, but you have to set the global
+    tainted flag if you acces them.
+
+#define SVp_SCREAM     8               /* has been studied? */
+    Indicates that a study was done on this string.  A studied string is
+    magical and automatically unstudies itself when modified.
+
+#define SVp_TAINTEDDIR 16              /* PATH component is a security risk */
+    A special flag for $ENV{PATH} that indicates that, while the value
+    as a whole may be untainted, some path component names an insecure
+    directory.
+
+#define SVpfm_COMPILED 128
+    For a format, whether its picture has been "compiled" yet.  This
+    cannot be done until runtime because the user has access to the
+    internal formline function, and may supply a variable as the
+    picture.
+
+#define SVpbm_VALID    128
+#define SVpbm_CASEFOLD 64
+#define SVpbm_TAIL     32
+    For a Boyer-Moore pattern, whether the search string has been invalidated
+    by modification (can happen to $pat between calls to index($string,$pat)),
+    whether case folding is in force for regexp matching, and whether we're
+    trying to match something like /foo$/.
+
+#define SVpgv_MULTI    128
+    For a symbol table entry, set when we've decided that this symbol is
+    probably not a typo.  Suspected typos can be reported by -w.
+
+
+Well, that's probably enough for now.  As you can see, we could turn
+references into something more like an integer or a pointer value.  In
+fact, I suspect the right thing to do is say that a reference is just
+a funny type of string pointer that isn't allocated the same way.
+This would let us not only have references to scalars, but might provide
+a way to have scalars that point to non-malloced memory.  Hmm.  I'll
+have to think about that s'more.  You can think about it too.
+
+Larry
index 09af786..b075a84 100644 (file)
 #define KEY___FILE__           2
 #define KEY___END__            3
 #define KEY_BEGIN              4
-#define KEY_END                        5
-#define KEY_EQ                 6
-#define KEY_GE                 7
-#define KEY_GT                 8
-#define KEY_LE                 9
-#define KEY_LT                 10
-#define KEY_NE                 11
-#define KEY_abs                        12
-#define KEY_accept             13
-#define KEY_alarm              14
-#define KEY_and                        15
-#define KEY_atan2              16
-#define KEY_bind               17
-#define KEY_binmode            18
-#define KEY_bless              19
-#define KEY_caller             20
-#define KEY_chdir              21
-#define KEY_chmod              22
-#define KEY_chop               23
-#define KEY_chown              24
-#define KEY_chr                        25
-#define KEY_chroot             26
-#define KEY_close              27
-#define KEY_closedir           28
-#define KEY_cmp                        29
-#define KEY_connect            30
-#define KEY_continue           31
-#define KEY_cos                        32
-#define KEY_crypt              33
-#define KEY_dbmclose           34
-#define KEY_dbmopen            35
-#define KEY_defined            36
-#define KEY_delete             37
-#define KEY_die                        38
-#define KEY_do                 39
-#define KEY_dump               40
-#define KEY_each               41
-#define KEY_else               42
-#define KEY_elsif              43
-#define KEY_endgrent           44
-#define KEY_endhostent         45
-#define KEY_endnetent          46
-#define KEY_endprotoent                47
-#define KEY_endpwent           48
-#define KEY_endservent         49
-#define KEY_eof                        50
-#define KEY_eq                 51
-#define KEY_eval               52
-#define KEY_exec               53
-#define KEY_exit               54
-#define KEY_exp                        55
-#define KEY_fcntl              56
-#define KEY_fileno             57
-#define KEY_flock              58
-#define KEY_for                        59
-#define KEY_foreach            60
-#define KEY_fork               61
-#define KEY_format             62
-#define KEY_formline           63
-#define KEY_ge                 64
-#define KEY_getc               65
-#define KEY_getgrent           66
-#define KEY_getgrgid           67
-#define KEY_getgrnam           68
-#define KEY_gethostbyaddr      69
-#define KEY_gethostbyname      70
-#define KEY_gethostent         71
-#define KEY_getlogin           72
-#define KEY_getnetbyaddr       73
-#define KEY_getnetbyname       74
-#define KEY_getnetent          75
-#define KEY_getpeername                76
-#define KEY_getpgrp            77
-#define KEY_getppid            78
-#define KEY_getpriority                79
-#define KEY_getprotobyname     80
-#define KEY_getprotobynumber   81
-#define KEY_getprotoent                82
-#define KEY_getpwent           83
-#define KEY_getpwnam           84
-#define KEY_getpwuid           85
-#define KEY_getservbyname      86
-#define KEY_getservbyport      87
-#define KEY_getservent         88
-#define KEY_getsockname                89
-#define KEY_getsockopt         90
-#define KEY_glob               91
-#define KEY_gmtime             92
-#define KEY_goto               93
-#define KEY_grep               94
-#define KEY_gt                 95
-#define KEY_hex                        96
-#define KEY_if                 97
-#define KEY_index              98
-#define KEY_int                        99
-#define KEY_ioctl              100
-#define KEY_join               101
-#define KEY_keys               102
-#define KEY_kill               103
-#define KEY_last               104
-#define KEY_lc                 105
-#define KEY_lcfirst            106
-#define KEY_le                 107
-#define KEY_length             108
-#define KEY_link               109
-#define KEY_listen             110
-#define KEY_local              111
-#define KEY_localtime          112
-#define KEY_log                        113
-#define KEY_lstat              114
-#define KEY_lt                 115
-#define KEY_m                  116
-#define KEY_mkdir              117
-#define KEY_msgctl             118
-#define KEY_msgget             119
-#define KEY_msgrcv             120
-#define KEY_msgsnd             121
-#define KEY_my                 122
-#define KEY_ne                 123
-#define KEY_next               124
-#define KEY_oct                        125
-#define KEY_open               126
-#define KEY_opendir            127
-#define KEY_or                 128
-#define KEY_ord                        129
-#define KEY_pack               130
-#define KEY_package            131
-#define KEY_pipe               132
-#define KEY_pop                        133
-#define KEY_print              134
-#define KEY_printf             135
-#define KEY_push               136
-#define KEY_q                  137
-#define KEY_qq                 138
-#define KEY_qx                 139
-#define KEY_rand               140
-#define KEY_read               141
-#define KEY_readdir            142
-#define KEY_readline           143
-#define KEY_readlink           144
-#define KEY_readpipe           145
-#define KEY_recv               146
-#define KEY_redo               147
-#define KEY_ref                        148
-#define KEY_rename             149
-#define KEY_require            150
-#define KEY_reset              151
-#define KEY_return             152
-#define KEY_reverse            153
-#define KEY_rewinddir          154
-#define KEY_rindex             155
-#define KEY_rmdir              156
-#define KEY_s                  157
-#define KEY_scalar             158
-#define KEY_seek               159
-#define KEY_seekdir            160
-#define KEY_select             161
-#define KEY_semctl             162
-#define KEY_semget             163
-#define KEY_semop              164
-#define KEY_send               165
-#define KEY_setgrent           166
-#define KEY_sethostent         167
-#define KEY_setnetent          168
-#define KEY_setpgrp            169
-#define KEY_setpriority                170
-#define KEY_setprotoent                171
-#define KEY_setpwent           172
-#define KEY_setservent         173
-#define KEY_setsockopt         174
-#define KEY_shift              175
-#define KEY_shmctl             176
-#define KEY_shmget             177
-#define KEY_shmread            178
-#define KEY_shmwrite           179
-#define KEY_shutdown           180
-#define KEY_sin                        181
-#define KEY_sleep              182
-#define KEY_socket             183
-#define KEY_socketpair         184
-#define KEY_sort               185
-#define KEY_splice             186
-#define KEY_split              187
-#define KEY_sprintf            188
-#define KEY_sqrt               189
-#define KEY_srand              190
-#define KEY_stat               191
-#define KEY_study              192
-#define KEY_sub                        193
-#define KEY_substr             194
-#define KEY_symlink            195
-#define KEY_syscall            196
-#define KEY_sysread            197
-#define KEY_system             198
-#define KEY_syswrite           199
-#define KEY_tell               200
-#define KEY_telldir            201
-#define KEY_tie                        202
-#define KEY_time               203
-#define KEY_times              204
-#define KEY_tr                 205
-#define KEY_truncate           206
-#define KEY_uc                 207
-#define KEY_ucfirst            208
-#define KEY_umask              209
-#define KEY_undef              210
-#define KEY_unless             211
-#define KEY_unlink             212
-#define KEY_unpack             213
-#define KEY_unshift            214
-#define KEY_untie              215
-#define KEY_until              216
-#define KEY_utime              217
-#define KEY_values             218
-#define KEY_vec                        219
-#define KEY_wait               220
-#define KEY_waitpid            221
-#define KEY_wantarray          222
-#define KEY_warn               223
-#define KEY_while              224
-#define KEY_write              225
-#define KEY_x                  226
-#define KEY_y                  227
+#define KEY_DESTROY            5
+#define KEY_END                        6
+#define KEY_EQ                 7
+#define KEY_GE                 8
+#define KEY_GT                 9
+#define KEY_LE                 10
+#define KEY_LT                 11
+#define KEY_NE                 12
+#define KEY_abs                        13
+#define KEY_accept             14
+#define KEY_alarm              15
+#define KEY_and                        16
+#define KEY_atan2              17
+#define KEY_bind               18
+#define KEY_binmode            19
+#define KEY_bless              20
+#define KEY_caller             21
+#define KEY_chdir              22
+#define KEY_chmod              23
+#define KEY_chop               24
+#define KEY_chown              25
+#define KEY_chr                        26
+#define KEY_chroot             27
+#define KEY_close              28
+#define KEY_closedir           29
+#define KEY_cmp                        30
+#define KEY_connect            31
+#define KEY_continue           32
+#define KEY_cos                        33
+#define KEY_crypt              34
+#define KEY_dbmclose           35
+#define KEY_dbmopen            36
+#define KEY_defined            37
+#define KEY_delete             38
+#define KEY_die                        39
+#define KEY_do                 40
+#define KEY_dump               41
+#define KEY_each               42
+#define KEY_else               43
+#define KEY_elsif              44
+#define KEY_endgrent           45
+#define KEY_endhostent         46
+#define KEY_endnetent          47
+#define KEY_endprotoent                48
+#define KEY_endpwent           49
+#define KEY_endservent         50
+#define KEY_eof                        51
+#define KEY_eq                 52
+#define KEY_eval               53
+#define KEY_exec               54
+#define KEY_exit               55
+#define KEY_exp                        56
+#define KEY_fcntl              57
+#define KEY_fileno             58
+#define KEY_flock              59
+#define KEY_for                        60
+#define KEY_foreach            61
+#define KEY_fork               62
+#define KEY_format             63
+#define KEY_formline           64
+#define KEY_ge                 65
+#define KEY_getc               66
+#define KEY_getgrent           67
+#define KEY_getgrgid           68
+#define KEY_getgrnam           69
+#define KEY_gethostbyaddr      70
+#define KEY_gethostbyname      71
+#define KEY_gethostent         72
+#define KEY_getlogin           73
+#define KEY_getnetbyaddr       74
+#define KEY_getnetbyname       75
+#define KEY_getnetent          76
+#define KEY_getpeername                77
+#define KEY_getpgrp            78
+#define KEY_getppid            79
+#define KEY_getpriority                80
+#define KEY_getprotobyname     81
+#define KEY_getprotobynumber   82
+#define KEY_getprotoent                83
+#define KEY_getpwent           84
+#define KEY_getpwnam           85
+#define KEY_getpwuid           86
+#define KEY_getservbyname      87
+#define KEY_getservbyport      88
+#define KEY_getservent         89
+#define KEY_getsockname                90
+#define KEY_getsockopt         91
+#define KEY_glob               92
+#define KEY_gmtime             93
+#define KEY_goto               94
+#define KEY_grep               95
+#define KEY_gt                 96
+#define KEY_hex                        97
+#define KEY_if                 98
+#define KEY_index              99
+#define KEY_int                        100
+#define KEY_ioctl              101
+#define KEY_join               102
+#define KEY_keys               103
+#define KEY_kill               104
+#define KEY_last               105
+#define KEY_lc                 106
+#define KEY_lcfirst            107
+#define KEY_le                 108
+#define KEY_length             109
+#define KEY_link               110
+#define KEY_listen             111
+#define KEY_local              112
+#define KEY_localtime          113
+#define KEY_log                        114
+#define KEY_lstat              115
+#define KEY_lt                 116
+#define KEY_m                  117
+#define KEY_mkdir              118
+#define KEY_msgctl             119
+#define KEY_msgget             120
+#define KEY_msgrcv             121
+#define KEY_msgsnd             122
+#define KEY_my                 123
+#define KEY_ne                 124
+#define KEY_next               125
+#define KEY_oct                        126
+#define KEY_open               127
+#define KEY_opendir            128
+#define KEY_or                 129
+#define KEY_ord                        130
+#define KEY_pack               131
+#define KEY_package            132
+#define KEY_pipe               133
+#define KEY_pop                        134
+#define KEY_print              135
+#define KEY_printf             136
+#define KEY_push               137
+#define KEY_q                  138
+#define KEY_qq                 139
+#define KEY_qx                 140
+#define KEY_rand               141
+#define KEY_read               142
+#define KEY_readdir            143
+#define KEY_readline           144
+#define KEY_readlink           145
+#define KEY_readpipe           146
+#define KEY_recv               147
+#define KEY_redo               148
+#define KEY_ref                        149
+#define KEY_rename             150
+#define KEY_require            151
+#define KEY_reset              152
+#define KEY_return             153
+#define KEY_reverse            154
+#define KEY_rewinddir          155
+#define KEY_rindex             156
+#define KEY_rmdir              157
+#define KEY_s                  158
+#define KEY_scalar             159
+#define KEY_seek               160
+#define KEY_seekdir            161
+#define KEY_select             162
+#define KEY_semctl             163
+#define KEY_semget             164
+#define KEY_semop              165
+#define KEY_send               166
+#define KEY_setgrent           167
+#define KEY_sethostent         168
+#define KEY_setnetent          169
+#define KEY_setpgrp            170
+#define KEY_setpriority                171
+#define KEY_setprotoent                172
+#define KEY_setpwent           173
+#define KEY_setservent         174
+#define KEY_setsockopt         175
+#define KEY_shift              176
+#define KEY_shmctl             177
+#define KEY_shmget             178
+#define KEY_shmread            179
+#define KEY_shmwrite           180
+#define KEY_shutdown           181
+#define KEY_sin                        182
+#define KEY_sleep              183
+#define KEY_socket             184
+#define KEY_socketpair         185
+#define KEY_sort               186
+#define KEY_splice             187
+#define KEY_split              188
+#define KEY_sprintf            189
+#define KEY_sqrt               190
+#define KEY_srand              191
+#define KEY_stat               192
+#define KEY_study              193
+#define KEY_sub                        194
+#define KEY_substr             195
+#define KEY_symlink            196
+#define KEY_syscall            197
+#define KEY_sysread            198
+#define KEY_system             199
+#define KEY_syswrite           200
+#define KEY_tell               201
+#define KEY_telldir            202
+#define KEY_tie                        203
+#define KEY_time               204
+#define KEY_times              205
+#define KEY_tr                 206
+#define KEY_truncate           207
+#define KEY_uc                 208
+#define KEY_ucfirst            209
+#define KEY_umask              210
+#define KEY_undef              211
+#define KEY_unless             212
+#define KEY_unlink             213
+#define KEY_unpack             214
+#define KEY_unshift            215
+#define KEY_untie              216
+#define KEY_until              217
+#define KEY_utime              218
+#define KEY_values             219
+#define KEY_vec                        220
+#define KEY_wait               221
+#define KEY_waitpid            222
+#define KEY_wantarray          223
+#define KEY_warn               224
+#define KEY_while              225
+#define KEY_write              226
+#define KEY_x                  227
+#define KEY_y                  228
index a2a0da9..45ffe1d 100644 (file)
@@ -228,9 +228,9 @@ sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
     else {
        push(@x, 0);
     }
-    @q = (); ($v2,$v1) = @y[$#y-1,$#y];
+    @q = (); ($v2,$v1) = @y[-2,-1];
     while ($#x > $#y) {
-       ($u2,$u1,$u0) = @x[($#x-2)..$#x];
+       ($u2,$u1,$u0) = @x[-3..-1];
        $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
        --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
        if ($q) {
index ff73d81..deeef8a 100644 (file)
@@ -74,14 +74,14 @@ else {
 open(IN, "<$console") || open(IN,  "<&STDIN"); # so we don't dingle stdin
 open(OUT,">$console") || open(OUT, ">&STDOUT");        # so we don't dongle stdout
 select(OUT);
-$| = 1;                                # for DB'OUT
+$| = 1;                                # for DB::OUT
 select(STDOUT);
 $| = 1;                                # for real STDOUT
 $sub = '';
 
 # Is Perl being run from Emacs?
-$emacs = $main'ARGV[$[] eq '-emacs';
-shift(@main'ARGV) if $emacs;
+$emacs = $main::ARGV[$[] eq '-emacs';
+shift(@main::ARGV) if $emacs;
 
 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
 print OUT "\nLoading DB routines from $header\n";
@@ -96,14 +96,14 @@ sub DB {
     $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
        "package $package;";            # this won't let them modify, alas
     local($^P) = 0;                    # don't debug our own evals
-    local(*dbline) = "_<$filename";
+    local(*dbline) = "::_<$filename";
     $max = $#dbline;
     if (($stop,$action) = split(/\0/,$dbline{$line})) {
        if ($stop eq '1') {
            $signal |= 1;
        }
        else {
-           $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
+           $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
            $dbline{$line} =~ s/;9($|\0)/$1/;
        }
     }
@@ -111,7 +111,7 @@ sub DB {
        if ($emacs) {
            print OUT "\032\032$filename:$line:0\n";
        } else {
-           print OUT "$package'" unless $sub =~ /'/;
+           print OUT "$package::" unless $sub =~ /'|::/;
            print OUT "$sub($filename:$line):\t",$dbline[$line];
            for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
                last if $dbline[$i] =~ /^\s*(}|#|\n)/;
@@ -184,7 +184,7 @@ X [vars]    Same as \"V currentpackage [vars]\".
 ! -number      Redo number\'th to last command.
 H -number      Display last number commands (default all).
 q or ^D                Quit.
-p expr         Same as \"print DB'OUT expr\" in current package.
+p expr         Same as \"print DB::OUT expr\" in current package.
 = [alias value]        Define a command alias, or list current aliases.
 command                Execute as a perl statement in current package.
 
@@ -206,12 +206,12 @@ command           Execute as a perl statement in current package.
                    local ($savout) = select(OUT);
                    $packname = $1;
                    @vars = split(' ',$2);
-                   do 'dumpvar.pl' unless defined &main'dumpvar;
-                   if (defined &main'dumpvar) {
-                       &main'dumpvar($packname,@vars);
+                   do 'dumpvar.pl' unless defined &main::dumpvar;
+                   if (defined &main::dumpvar) {
+                       &main::dumpvar($packname,@vars);
                    }
                    else {
-                       print DB'OUT "dumpvar.pl not available.\n";
+                       print DB::OUT "dumpvar.pl not available.\n";
                    }
                    select ($savout);
                    next CMD; };
@@ -222,30 +222,31 @@ command           Execute as a perl statement in current package.
                        print OUT "The new f command switches filenames.\n";
                        next CMD;
                    }
-                   if (!defined $_main{'_<' . $file}) {
-                       if (($try) = grep(m#^_<.*$file#, keys %_main)) {
+                   if (!defined $::_main{'_<' . $file}) {
+                       if (($try) = grep(m#^_<.*$file#, keys %::_main)) {
                            $file = substr($try,2);
                            print "\n$file:\n";
                        }
                    }
-                   if (!defined $_main{'_<' . $file}) {
+                   if (!defined $::_main{'_<' . $file}) {
                        print OUT "There's no code here anything matching $file.\n";
                        next CMD;
                    }
                    elsif ($file ne $filename) {
-                       *dbline = "_<$file";
+                       *dbline = "::_<$file";
                        $max = $#dbline;
                        $filename = $file;
                        $start = 1;
                        $cmd = "l";
                    } };
-               $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
+               $cmd =~ /^l\b\s*([':A-Za-z_][':\w]*)/ && do {
                    $subname = $1;
-                   $subname = "main'" . $subname unless $subname =~ /'/;
-                   $subname = "main" . $subname if substr($subname,0,1) eq "'";
+                   $subname = "main::" . $subname unless $subname =~ /'|::/;
+                   $subname = "main" . $subname if substr($subname,0,1)eq "'";
+                   $subname = "main" . $subname if substr($subname,0,2)eq "::";
                    ($file,$subrange) = split(/:/,$sub{$subname});
                    if ($file ne $filename) {
-                       *dbline = "_<$file";
+                       *dbline = "::_<$file";
                        $max = $#dbline;
                        $filename = $file;
                    }
@@ -316,15 +317,16 @@ command           Execute as a perl statement in current package.
                        }
                    }
                    next CMD; };
-               $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
+               $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
                    $subname = $1;
                    $cond = $2 || '1';
-                   $subname = "$package'" . $subname unless $subname =~ /'/;
+                   $subname = "$package::" . $subname unless $subname =~ /'|::/;
                    $subname = "main" . $subname if substr($subname,0,1) eq "'";
+                   $subname = "main" . $subname if substr($subname,0,2) eq "::";
                    ($filename,$i) = split(/:/, $sub{$subname});
                    $i += 0;
                    if ($i) {
-                       *dbline = "_<$filename";
+                       *dbline = "::_<$filename";
                        ++$i while $dbline[$i] == 0 && $i < $#dbline;
                        $dbline{$i} =~ s/^[^\0]*/$cond/;
                    } else {
@@ -397,15 +399,10 @@ command           Execute as a perl statement in current package.
                    for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
                        @a = @args;
                        for (@a) {
-                           if (/^StB\000/ && length($_) == length($_main{'_main'})) {
-                               $_ = sprintf("%s",$_);
-                           }
-                           else {
-                               s/'/\\'/g;
-                               s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
-                               s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
-                               s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
-                           }
+                           s/'/\\'/g;
+                           s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+                           s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+                           s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
                        }
                        $w = $w ? '@ = ' : '$ = ';
                        $a = $h ? '(' . join(', ', @a) . ')' : '';
@@ -500,7 +497,7 @@ command             Execute as a perl statement in current package.
                            unless $hist[$i] =~ /^.?$/;
                    };
                    next CMD; };
-               $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
+               $cmd =~ s/^p( .*)?$/print DB::OUT$1/;
                $cmd =~ /^=/ && do {
                    if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
                        $alias{$k}="s~$k~$v~";
@@ -534,7 +531,7 @@ sub save {
 # The following takes its argument via $evalarg to preserve current @_
 
 sub eval {
-    eval "$usercontext $evalarg; &DB'save";
+    eval "$usercontext $evalarg; &DB::save";
     print OUT $@;
 }
 
@@ -574,7 +571,7 @@ sub sub {
 
 $single = 1;                   # so it stops on first executable statement
 @hist = ('?');
-$SIG{'INT'} = "DB'catch";
+$SIG{'INT'} = "DB::catch";
 $deep = 100;           # warning if stack gets this deep
 $window = 10;
 $preview = 3;
index 5b48d71..22c1817 100644 (file)
@@ -33,7 +33,7 @@ sub Tgetent {
            while (<TERMCAP>) {
                next if /^#/;
                next if /^\t/;
-               if (/(^|\\|)$TERM[:\\|]/) {
+               if (/(^|\\|)$TERM\[:\\|]/) {
                    chop;
                    while (chop eq '\\\\') {
                        \$_ .= <TERMCAP>;
index f4d95b6..bebbb6a 100644 (file)
--- a/make.out
+++ b/make.out
@@ -1,11 +1,11 @@
 make: Warning: Both `makefile' and `Makefile' exists
-`sh  cflags taint.o` taint.c
+`sh  cflags perl.o` perl.c
          CCCMD =  cc -c -DDEBUGGING -DHAS_SDBM -g  
-`sh  cflags NDBM_File.o` NDBM_File.c
+`sh  cflags op.o` op.c
          CCCMD =  cc -c -DDEBUGGING -DHAS_SDBM -g  
-`sh  cflags ODBM_File.o` ODBM_File.c
+`sh  cflags mg.o` mg.c
          CCCMD =  cc -c -DDEBUGGING -DHAS_SDBM -g  
-`sh  cflags SDBM_File.o` SDBM_File.c
+`sh  cflags toke.o` toke.c
          CCCMD =  cc -c -DDEBUGGING -DHAS_SDBM -g  
 cc -Bstatic   main.o perly.o perl.o av.o scope.o op.o doop.o doio.o dump.o hv.o malloc.o mg.o pp.o regcomp.o regexec.o gv.o sv.o taint.o toke.o util.o deb.o run.o NDBM_File.o ODBM_File.o SDBM_File.o -ldbm -lm -lposix ext/dbm/sdbm/libsdbm.a -o perl
 echo "\a"
diff --git a/mg.c b/mg.c
index 07a0dfe..3196673 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -512,7 +512,7 @@ SV* sv;
 MAGIC* mg;
 {
     SV* rv = mg->mg_obj;
-    HV* stash = SvSTASH((SV*)SvANY(rv));
+    HV* stash = SvSTASH(SvRV(rv));
     GV* gv = gv_fetchmethod(stash, "fetch");
     dSP;
     BINOP myop;
@@ -558,7 +558,7 @@ SV* sv;
 MAGIC* mg;
 {
     SV* rv = mg->mg_obj;
-    HV* stash = SvSTASH((SV*)SvANY(rv));
+    HV* stash = SvSTASH(SvRV(rv));
     GV* gv = gv_fetchmethod(stash, "store");
     dSP;
     BINOP myop;
@@ -605,7 +605,7 @@ SV* sv;
 MAGIC* mg;
 {
     SV* rv = mg->mg_obj;
-    HV* stash = SvSTASH((SV*)SvANY(rv));
+    HV* stash = SvSTASH(SvRV(rv));
     GV* gv = gv_fetchmethod(stash, "delete");
     dSP;
     BINOP myop;
@@ -652,7 +652,7 @@ MAGIC* mg;
 SV* key;
 {
     SV* rv = mg->mg_obj;
-    HV* stash = SvSTASH((SV*)SvANY(rv));
+    HV* stash = SvSTASH(SvRV(rv));
     GV* gv = gv_fetchmethod(stash, SvOK(key) ? "nextkey" : "firstkey");
     dSP;
     BINOP myop;
@@ -1072,7 +1072,9 @@ MAGIC* mg;
            s = origargv[0]+i;
            *s++ = '\0';
            while (++i < origalen)
-               *s++ = ' ';
+               *s++ = '\0';
+           for (i = 1; i < origargc; i++)
+               origargv[i] = NULL;
        }
        break;
     }
diff --git a/op.c b/op.c
index 743c7ca..31b4c7f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -75,7 +75,7 @@ PADOFFSET
 pad_allocmy(name)
 char *name;
 {
-    PADOFFSET off = pad_alloc(OP_PADSV, 'M');
+    PADOFFSET off = pad_alloc(OP_PADSV, SVs_PADMY);
     SV *sv = NEWSV(0,0);
     sv_upgrade(sv, SVt_PVNV);
     sv_setpv(sv, name);
@@ -86,6 +86,7 @@ char *name;
        av_store(comppad, off, (SV*)newAV());
     else if (*name == '%')
        av_store(comppad, off, (SV*)newHV());
+    SvPADMY_on(curpad[off]);
     return off;
 }
 
@@ -144,7 +145,7 @@ char *name;
                    seq > (I32)SvNVX(sv) &&
                    strEQ(SvPVX(sv), name))
                {
-                   PADOFFSET newoff = pad_alloc(OP_PADSV, 'M');
+                   PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
                    AV *oldpad = (AV*)*av_fetch(curlist, CvDEPTH(cv), FALSE);
                    SV *oldsv = *av_fetch(oldpad, off, TRUE);
                    SV *sv = NEWSV(0,0);
@@ -180,26 +181,26 @@ I32 fill;
 PADOFFSET
 pad_alloc(optype,tmptype)      
 I32 optype;
-char tmptype;
+U32 tmptype;
 {
     SV *sv;
     I32 retval;
 
     if (AvARRAY(comppad) != curpad)
        croak("panic: pad_alloc");
-    if (tmptype == 'M') {
+    if (tmptype & SVs_PADMY) {
        do {
            sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
-       } while (SvSTORAGE(sv));                /* need a fresh one */
+       } while (SvPADBUSY(sv));                /* need a fresh one */
        retval = AvFILL(comppad);
     }
     else {
        do {
            sv = *av_fetch(comppad, ++padix, TRUE);
-       } while (SvSTORAGE(sv) == 'T' || SvSTORAGE(sv) == 'M');
+       } while (SvSTORAGE(sv) & (SVs_PADTMP|SVs_PADMY));
        retval = padix;
     }
-    SvSTORAGE(sv) = tmptype;
+    SvSTORAGE(sv) |= tmptype;
     curpad = AvARRAY(comppad);
     DEBUG_X(fprintf(stderr, "Pad alloc %d for %s\n", retval, op_name[optype]));
     return (PADOFFSET)retval;
@@ -225,7 +226,7 @@ PADOFFSET po;
        croak("panic: pad_free po");
     DEBUG_X(fprintf(stderr, "Pad free %d\n", po));
     if (curpad[po])
-       SvSTORAGE(curpad[po]) = 'F';
+       SvPADTMP_off(curpad[po]);
     if (po < padix)
        padix = po - 1;
 }
@@ -240,7 +241,7 @@ PADOFFSET po;
        croak("panic: pad_swipe po");
     DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po));
     curpad[po] = NEWSV(0,0);
-    SvSTORAGE(curpad[po]) = 'F';
+    SvPADTMP_off(curpad[po]);
     if (po < padix)
        padix = po - 1;
 }
@@ -254,8 +255,8 @@ pad_reset()
        croak("panic: pad_reset curpad");
     DEBUG_X(fprintf(stderr, "Pad reset\n"));
     for (po = AvMAX(comppad); po > 0; po--) {
-       if (curpad[po] && SvSTORAGE(curpad[po]) == 'T')
-           SvSTORAGE(curpad[po]) = 'F';
+       if (curpad[po])
+           SvPADTMP_off(curpad[po]);
     }
     padix = 0;
 }
@@ -514,11 +515,26 @@ OP *op;
     return op;
 }
 
+static OP *
+guess_mark(op)
+OP *op;
+{
+    if (op->op_type == OP_LIST &&
+            (!cLISTOP->op_first ||
+             cLISTOP->op_first->op_type != OP_PUSHMARK))
+    {
+       op = prepend_elem(OP_LIST, newOP(OP_PUSHMARK, 0), op);
+       op->op_private |= OPpLIST_GUESSED;
+    }
+    return op;
+}
+
 OP *
 scalarseq(op)
 OP *op;
 {
     OP *kid;
+    OP **prev;
 
     if (op) {
        if (op->op_type == OP_LINESEQ ||
@@ -526,9 +542,14 @@ OP *op;
             op->op_type == OP_LEAVE ||
             op->op_type == OP_LEAVETRY)
        {
+           prev = &cLISTOP->op_first;
            for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
-               if (kid->op_sibling)
+               if (kid->op_sibling) {
                    scalarvoid(kid);
+                   prev = &kid->op_sibling;
+               }
+               else
+                   *prev = guess_mark(kid);
            }
            curcop = &compiling;
        }
@@ -625,7 +646,7 @@ I32 type;
 
     case OP_SUBSTR:
     case OP_VEC:
-       op->op_targ = pad_alloc(op->op_type,'M');
+       op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
        sv = PAD_SV(op->op_targ);
        sv_upgrade(sv, SVt_PVLV);
        sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0);
@@ -736,7 +757,7 @@ I32 type;
 
     case OP_SUBSTR:
     case OP_VEC:
-       op->op_targ = pad_alloc(op->op_type,'M');
+       op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
        sv = PAD_SV(op->op_targ);
        sv_upgrade(sv, SVt_PVLV);
        sv_magic(sv, 0, op->op_type == OP_VEC ? 'v' : 'x', 0, 0);
@@ -936,7 +957,7 @@ register OP *o;
     if (opargs[type] & OA_RETSCALAR)
        scalar(o);
     if (opargs[type] & OA_TARGET)
-       o->op_targ = pad_alloc(type,'T');
+       o->op_targ = pad_alloc(type, SVs_PADTMP);
 
     if (!(opargs[type] & OA_FOLDCONST))
        goto nope;
@@ -1183,7 +1204,7 @@ I32 flags;
     if (opargs[type] & OA_RETSCALAR)
        scalar(op);
     if (opargs[type] & OA_TARGET)
-       op->op_targ = pad_alloc(type,'T');
+       op->op_targ = pad_alloc(type, SVs_PADTMP);
     return (*check[type])(op);
 }
 
@@ -1473,7 +1494,7 @@ SV *sv;
     if (opargs[type] & OA_RETSCALAR)
        scalar((OP*)svop);
     if (opargs[type] & OA_TARGET)
-       svop->op_targ = pad_alloc(type,'T');
+       svop->op_targ = pad_alloc(type, SVs_PADTMP);
     return (*check[type])((OP*)svop);
 }
 
@@ -1493,7 +1514,7 @@ GV *gv;
     if (opargs[type] & OA_RETSCALAR)
        scalar((OP*)gvop);
     if (opargs[type] & OA_TARGET)
-       gvop->op_targ = pad_alloc(type,'T');
+       gvop->op_targ = pad_alloc(type, SVs_PADTMP);
     return (*check[type])((OP*)gvop);
 }
 
@@ -1513,7 +1534,7 @@ char *pv;
     if (opargs[type] & OA_RETSCALAR)
        scalar((OP*)pvop);
     if (opargs[type] & OA_TARGET)
-       pvop->op_targ = pad_alloc(type,'T');
+       pvop->op_targ = pad_alloc(type, SVs_PADTMP);
     return (*check[type])((OP*)pvop);
 }
 
@@ -1535,7 +1556,7 @@ OP *cont;
     if (opargs[type] & OA_RETSCALAR)
        scalar((OP*)cvop);
     if (opargs[type] & OA_TARGET)
-       cvop->op_targ = pad_alloc(type,'T');
+       cvop->op_targ = pad_alloc(type, SVs_PADTMP);
     return (*check[type])((OP*)cvop);
 }
 
@@ -1697,7 +1718,7 @@ OP *right;
            if (curop != op)
                op->op_private = OPpASSIGN_COMMON;
        }
-       op->op_targ = pad_alloc(OP_AASSIGN, 'T');       /* for scalar context */
+       op->op_targ = pad_alloc(OP_AASSIGN, SVs_PADTMP);        /* for scalar context */
        return op;
     }
     if (!right)
@@ -1912,9 +1933,9 @@ OP *right;
     left->op_next = flip;
     right->op_next = flop;
 
-    condop->op_targ = pad_alloc(OP_RANGE, 'M');
+    condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
     sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
-    flip->op_targ = pad_alloc(OP_RANGE, 'M');
+    flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
 
     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
@@ -1946,7 +1967,7 @@ OP *block;
            expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), expr);
     }
 
-    listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
+    listop = append_elem(OP_LINESEQ, guess_mark(block), newOP(OP_UNSTACK, 0));
     op = newLOGOP(OP_AND, 0, expr, listop);
 
     ((LISTOP*)listop)->op_last->op_next = LINKLIST(op);
@@ -2285,7 +2306,7 @@ OP *name;
     mop->op_flags |= OPf_KIDS;
     mop->op_private = 1;
     mop->op_other = LINKLIST(name);
-    mop->op_targ = pad_alloc(OP_METHOD,'T');
+    mop->op_targ = pad_alloc(OP_METHOD, SVs_PADTMP);
     mop->op_next = LINKLIST(ref);
     ref->op_next = (OP*)mop;
     return (OP*)mop;
@@ -2311,15 +2332,22 @@ OP *
 oopsAV(o)
 OP *o;
 {
-    if (o->op_type == OP_PADAV)
-       return o;
-    if (o->op_type == OP_RV2SV) {
+    switch (o->op_type) {
+    case OP_PADSV:
+       o->op_type = OP_PADAV;
+       o->op_ppaddr = ppaddr[OP_PADAV];
+       return ref(newUNOP(OP_RV2AV, 0, scalar(o)), OP_RV2AV);
+       
+    case OP_RV2SV:
        o->op_type = OP_RV2AV;
        o->op_ppaddr = ppaddr[OP_RV2AV];
        ref(o, OP_RV2AV);
-    }
-    else
+       break;
+
+    default:
        warn("oops: oopsAV");
+       break;
+    }
     return o;
 }
 
@@ -2327,15 +2355,24 @@ OP *
 oopsHV(o)
 OP *o;
 {
-    if (o->op_type == OP_PADHV)
-       return o;
-    if (o->op_type == OP_RV2SV || o->op_type == OP_RV2AV) {
+    switch (o->op_type) {
+    case OP_PADSV:
+    case OP_PADAV:
+       o->op_type = OP_PADHV;
+       o->op_ppaddr = ppaddr[OP_PADHV];
+       return ref(newUNOP(OP_RV2HV, 0, scalar(o)), OP_RV2HV);
+
+    case OP_RV2SV:
+    case OP_RV2AV:
        o->op_type = OP_RV2HV;
        o->op_ppaddr = ppaddr[OP_RV2HV];
        ref(o, OP_RV2HV);
-    }
-    else
+       break;
+
+    default:
        warn("oops: oopsHV");
+       break;
+    }
     return o;
 }
 
@@ -2343,8 +2380,11 @@ OP *
 newAVREF(o)
 OP *o;
 {
-    if (o->op_type == OP_PADAV)
+    if (o->op_type == OP_PADANY) {
+       o->op_type = OP_PADAV;
+       o->op_ppaddr = ppaddr[OP_PADAV];
        return o;
+    }
     return newUNOP(OP_RV2AV, 0, scalar(o));
 }
 
@@ -2359,8 +2399,11 @@ OP *
 newHVREF(o)
 OP *o;
 {
-    if (o->op_type == OP_PADHV)
+    if (o->op_type == OP_PADANY) {
+       o->op_type = OP_PADHV;
+       o->op_ppaddr = ppaddr[OP_PADHV];
        return o;
+    }
     return newUNOP(OP_RV2HV, 0, scalar(o));
 }
 
@@ -2384,8 +2427,11 @@ OP *
 newSVREF(o)
 OP *o;
 {
-    if (o->op_type == OP_PADSV)
+    if (o->op_type == OP_PADANY) {
+       o->op_type = OP_PADSV;
+       o->op_ppaddr = ppaddr[OP_PADSV];
        return o;
+    }
     return newUNOP(OP_RV2SV, 0, scalar(o));
 }
 
@@ -2723,7 +2769,7 @@ OP *op;
     gwop->op_flags |= OPf_KIDS;
     gwop->op_private = 1;
     gwop->op_other = LINKLIST(kid);
-    gwop->op_targ = pad_alloc(OP_GREPWHILE,'T');
+    gwop->op_targ = pad_alloc(OP_GREPWHILE, SVs_PADTMP);
     kid->op_next = (OP*)gwop;
 
     return (OP*)gwop;
@@ -2899,6 +2945,7 @@ ck_split(op)
 OP *op;
 {
     register OP *kid;
+    PMOP* pm;
     
     if (op->op_flags & OPf_STACKED)
        return no_fh_allowed(op);
@@ -2924,6 +2971,11 @@ OP *op;
        cLISTOP->op_first = kid;
        kid->op_sibling = sibl;
     }
+    pm = (PMOP*)kid;
+    if (pm->op_pmshort && !(pm->op_pmflags & PMf_ALL)) {
+       sv_free(pm->op_pmshort);        /* can't use substring to optimize */
+       pm->op_pmshort = 0;
+    }
 
     kid->op_type = OP_PUSHRE;
     kid->op_ppaddr = ppaddr[OP_PUSHRE];
diff --git a/op.h b/op.h
index f6375b1..c230dd0 100644 (file)
--- a/op.h
+++ b/op.h
@@ -84,6 +84,9 @@ typedef U16 PADOFFSET;
 /* Private for OP_FLIP/FLOP */
 #define OPpFLIP_LINENUM                1       /* Range arg potentially a line num. */
 
+/* Private for OP_LIST */
+#define OPpLIST_GUESSED                1       /* Guessed that pushmark was needed. */
+
 struct op {
     BASEOP
 };
index cbfa0a7..e9bbcca 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -11,313 +11,314 @@ typedef enum {
        OP_PADSV,       /* 9 */
        OP_PADAV,       /* 10 */
        OP_PADHV,       /* 11 */
-       OP_PUSHRE,      /* 12 */
-       OP_RV2GV,       /* 13 */
-       OP_SV2LEN,      /* 14 */
-       OP_RV2SV,       /* 15 */
-       OP_AV2ARYLEN,   /* 16 */
-       OP_RV2CV,       /* 17 */
-       OP_REFGEN,      /* 18 */
-       OP_REF,         /* 19 */
-       OP_BLESS,       /* 20 */
-       OP_BACKTICK,    /* 21 */
-       OP_GLOB,        /* 22 */
-       OP_READLINE,    /* 23 */
-       OP_RCATLINE,    /* 24 */
-       OP_REGCMAYBE,   /* 25 */
-       OP_REGCOMP,     /* 26 */
-       OP_MATCH,       /* 27 */
-       OP_SUBST,       /* 28 */
-       OP_SUBSTCONT,   /* 29 */
-       OP_TRANS,       /* 30 */
-       OP_SASSIGN,     /* 31 */
-       OP_AASSIGN,     /* 32 */
-       OP_SCHOP,       /* 33 */
-       OP_CHOP,        /* 34 */
-       OP_DEFINED,     /* 35 */
-       OP_UNDEF,       /* 36 */
-       OP_STUDY,       /* 37 */
-       OP_PREINC,      /* 38 */
-       OP_PREDEC,      /* 39 */
-       OP_POSTINC,     /* 40 */
-       OP_POSTDEC,     /* 41 */
-       OP_POW,         /* 42 */
-       OP_MULTIPLY,    /* 43 */
-       OP_DIVIDE,      /* 44 */
-       OP_MODULO,      /* 45 */
-       OP_REPEAT,      /* 46 */
-       OP_ADD,         /* 47 */
-       OP_INTADD,      /* 48 */
-       OP_SUBTRACT,    /* 49 */
-       OP_CONCAT,      /* 50 */
-       OP_LEFT_SHIFT,  /* 51 */
-       OP_RIGHT_SHIFT, /* 52 */
-       OP_LT,          /* 53 */
-       OP_GT,          /* 54 */
-       OP_LE,          /* 55 */
-       OP_GE,          /* 56 */
-       OP_EQ,          /* 57 */
-       OP_NE,          /* 58 */
-       OP_NCMP,        /* 59 */
-       OP_SLT,         /* 60 */
-       OP_SGT,         /* 61 */
-       OP_SLE,         /* 62 */
-       OP_SGE,         /* 63 */
-       OP_SEQ,         /* 64 */
-       OP_SNE,         /* 65 */
-       OP_SCMP,        /* 66 */
-       OP_BIT_AND,     /* 67 */
-       OP_XOR,         /* 68 */
-       OP_BIT_OR,      /* 69 */
-       OP_NEGATE,      /* 70 */
-       OP_NOT,         /* 71 */
-       OP_COMPLEMENT,  /* 72 */
-       OP_ATAN2,       /* 73 */
-       OP_SIN,         /* 74 */
-       OP_COS,         /* 75 */
-       OP_RAND,        /* 76 */
-       OP_SRAND,       /* 77 */
-       OP_EXP,         /* 78 */
-       OP_LOG,         /* 79 */
-       OP_SQRT,        /* 80 */
-       OP_INT,         /* 81 */
-       OP_HEX,         /* 82 */
-       OP_OCT,         /* 83 */
-       OP_ABS,         /* 84 */
-       OP_LENGTH,      /* 85 */
-       OP_SUBSTR,      /* 86 */
-       OP_VEC,         /* 87 */
-       OP_INDEX,       /* 88 */
-       OP_RINDEX,      /* 89 */
-       OP_SPRINTF,     /* 90 */
-       OP_FORMLINE,    /* 91 */
-       OP_ORD,         /* 92 */
-       OP_CHR,         /* 93 */
-       OP_CRYPT,       /* 94 */
-       OP_UCFIRST,     /* 95 */
-       OP_LCFIRST,     /* 96 */
-       OP_UC,          /* 97 */
-       OP_LC,          /* 98 */
-       OP_RV2AV,       /* 99 */
-       OP_AELEMFAST,   /* 100 */
-       OP_AELEM,       /* 101 */
-       OP_ASLICE,      /* 102 */
-       OP_EACH,        /* 103 */
-       OP_VALUES,      /* 104 */
-       OP_KEYS,        /* 105 */
-       OP_DELETE,      /* 106 */
-       OP_RV2HV,       /* 107 */
-       OP_HELEM,       /* 108 */
-       OP_HSLICE,      /* 109 */
-       OP_UNPACK,      /* 110 */
-       OP_PACK,        /* 111 */
-       OP_SPLIT,       /* 112 */
-       OP_JOIN,        /* 113 */
-       OP_LIST,        /* 114 */
-       OP_LSLICE,      /* 115 */
-       OP_ANONLIST,    /* 116 */
-       OP_ANONHASH,    /* 117 */
-       OP_SPLICE,      /* 118 */
-       OP_PUSH,        /* 119 */
-       OP_POP,         /* 120 */
-       OP_SHIFT,       /* 121 */
-       OP_UNSHIFT,     /* 122 */
-       OP_SORT,        /* 123 */
-       OP_REVERSE,     /* 124 */
-       OP_GREPSTART,   /* 125 */
-       OP_GREPWHILE,   /* 126 */
-       OP_RANGE,       /* 127 */
-       OP_FLIP,        /* 128 */
-       OP_FLOP,        /* 129 */
-       OP_AND,         /* 130 */
-       OP_OR,          /* 131 */
-       OP_COND_EXPR,   /* 132 */
-       OP_ANDASSIGN,   /* 133 */
-       OP_ORASSIGN,    /* 134 */
-       OP_METHOD,      /* 135 */
-       OP_ENTERSUBR,   /* 136 */
-       OP_LEAVESUBR,   /* 137 */
-       OP_CALLER,      /* 138 */
-       OP_WARN,        /* 139 */
-       OP_DIE,         /* 140 */
-       OP_RESET,       /* 141 */
-       OP_LINESEQ,     /* 142 */
-       OP_NEXTSTATE,   /* 143 */
-       OP_DBSTATE,     /* 144 */
-       OP_UNSTACK,     /* 145 */
-       OP_ENTER,       /* 146 */
-       OP_LEAVE,       /* 147 */
-       OP_SCOPE,       /* 148 */
-       OP_ENTERITER,   /* 149 */
-       OP_ITER,        /* 150 */
-       OP_ENTERLOOP,   /* 151 */
-       OP_LEAVELOOP,   /* 152 */
-       OP_RETURN,      /* 153 */
-       OP_LAST,        /* 154 */
-       OP_NEXT,        /* 155 */
-       OP_REDO,        /* 156 */
-       OP_DUMP,        /* 157 */
-       OP_GOTO,        /* 158 */
-       OP_EXIT,        /* 159 */
-       OP_NSWITCH,     /* 160 */
-       OP_CSWITCH,     /* 161 */
-       OP_OPEN,        /* 162 */
-       OP_CLOSE,       /* 163 */
-       OP_PIPE_OP,     /* 164 */
-       OP_FILENO,      /* 165 */
-       OP_UMASK,       /* 166 */
-       OP_BINMODE,     /* 167 */
-       OP_TIE,         /* 168 */
-       OP_UNTIE,       /* 169 */
-       OP_DBMOPEN,     /* 170 */
-       OP_DBMCLOSE,    /* 171 */
-       OP_SSELECT,     /* 172 */
-       OP_SELECT,      /* 173 */
-       OP_GETC,        /* 174 */
-       OP_READ,        /* 175 */
-       OP_ENTERWRITE,  /* 176 */
-       OP_LEAVEWRITE,  /* 177 */
-       OP_PRTF,        /* 178 */
-       OP_PRINT,       /* 179 */
-       OP_SYSREAD,     /* 180 */
-       OP_SYSWRITE,    /* 181 */
-       OP_SEND,        /* 182 */
-       OP_RECV,        /* 183 */
-       OP_EOF,         /* 184 */
-       OP_TELL,        /* 185 */
-       OP_SEEK,        /* 186 */
-       OP_TRUNCATE,    /* 187 */
-       OP_FCNTL,       /* 188 */
-       OP_IOCTL,       /* 189 */
-       OP_FLOCK,       /* 190 */
-       OP_SOCKET,      /* 191 */
-       OP_SOCKPAIR,    /* 192 */
-       OP_BIND,        /* 193 */
-       OP_CONNECT,     /* 194 */
-       OP_LISTEN,      /* 195 */
-       OP_ACCEPT,      /* 196 */
-       OP_SHUTDOWN,    /* 197 */
-       OP_GSOCKOPT,    /* 198 */
-       OP_SSOCKOPT,    /* 199 */
-       OP_GETSOCKNAME, /* 200 */
-       OP_GETPEERNAME, /* 201 */
-       OP_LSTAT,       /* 202 */
-       OP_STAT,        /* 203 */
-       OP_FTRREAD,     /* 204 */
-       OP_FTRWRITE,    /* 205 */
-       OP_FTREXEC,     /* 206 */
-       OP_FTEREAD,     /* 207 */
-       OP_FTEWRITE,    /* 208 */
-       OP_FTEEXEC,     /* 209 */
-       OP_FTIS,        /* 210 */
-       OP_FTEOWNED,    /* 211 */
-       OP_FTROWNED,    /* 212 */
-       OP_FTZERO,      /* 213 */
-       OP_FTSIZE,      /* 214 */
-       OP_FTMTIME,     /* 215 */
-       OP_FTATIME,     /* 216 */
-       OP_FTCTIME,     /* 217 */
-       OP_FTSOCK,      /* 218 */
-       OP_FTCHR,       /* 219 */
-       OP_FTBLK,       /* 220 */
-       OP_FTFILE,      /* 221 */
-       OP_FTDIR,       /* 222 */
-       OP_FTPIPE,      /* 223 */
-       OP_FTLINK,      /* 224 */
-       OP_FTSUID,      /* 225 */
-       OP_FTSGID,      /* 226 */
-       OP_FTSVTX,      /* 227 */
-       OP_FTTTY,       /* 228 */
-       OP_FTTEXT,      /* 229 */
-       OP_FTBINARY,    /* 230 */
-       OP_CHDIR,       /* 231 */
-       OP_CHOWN,       /* 232 */
-       OP_CHROOT,      /* 233 */
-       OP_UNLINK,      /* 234 */
-       OP_CHMOD,       /* 235 */
-       OP_UTIME,       /* 236 */
-       OP_RENAME,      /* 237 */
-       OP_LINK,        /* 238 */
-       OP_SYMLINK,     /* 239 */
-       OP_READLINK,    /* 240 */
-       OP_MKDIR,       /* 241 */
-       OP_RMDIR,       /* 242 */
-       OP_OPEN_DIR,    /* 243 */
-       OP_READDIR,     /* 244 */
-       OP_TELLDIR,     /* 245 */
-       OP_SEEKDIR,     /* 246 */
-       OP_REWINDDIR,   /* 247 */
-       OP_CLOSEDIR,    /* 248 */
-       OP_FORK,        /* 249 */
-       OP_WAIT,        /* 250 */
-       OP_WAITPID,     /* 251 */
-       OP_SYSTEM,      /* 252 */
-       OP_EXEC,        /* 253 */
-       OP_KILL,        /* 254 */
-       OP_GETPPID,     /* 255 */
-       OP_GETPGRP,     /* 256 */
-       OP_SETPGRP,     /* 257 */
-       OP_GETPRIORITY, /* 258 */
-       OP_SETPRIORITY, /* 259 */
-       OP_TIME,        /* 260 */
-       OP_TMS,         /* 261 */
-       OP_LOCALTIME,   /* 262 */
-       OP_GMTIME,      /* 263 */
-       OP_ALARM,       /* 264 */
-       OP_SLEEP,       /* 265 */
-       OP_SHMGET,      /* 266 */
-       OP_SHMCTL,      /* 267 */
-       OP_SHMREAD,     /* 268 */
-       OP_SHMWRITE,    /* 269 */
-       OP_MSGGET,      /* 270 */
-       OP_MSGCTL,      /* 271 */
-       OP_MSGSND,      /* 272 */
-       OP_MSGRCV,      /* 273 */
-       OP_SEMGET,      /* 274 */
-       OP_SEMCTL,      /* 275 */
-       OP_SEMOP,       /* 276 */
-       OP_REQUIRE,     /* 277 */
-       OP_DOFILE,      /* 278 */
-       OP_ENTEREVAL,   /* 279 */
-       OP_LEAVEEVAL,   /* 280 */
-       OP_EVALONCE,    /* 281 */
-       OP_ENTERTRY,    /* 282 */
-       OP_LEAVETRY,    /* 283 */
-       OP_GHBYNAME,    /* 284 */
-       OP_GHBYADDR,    /* 285 */
-       OP_GHOSTENT,    /* 286 */
-       OP_GNBYNAME,    /* 287 */
-       OP_GNBYADDR,    /* 288 */
-       OP_GNETENT,     /* 289 */
-       OP_GPBYNAME,    /* 290 */
-       OP_GPBYNUMBER,  /* 291 */
-       OP_GPROTOENT,   /* 292 */
-       OP_GSBYNAME,    /* 293 */
-       OP_GSBYPORT,    /* 294 */
-       OP_GSERVENT,    /* 295 */
-       OP_SHOSTENT,    /* 296 */
-       OP_SNETENT,     /* 297 */
-       OP_SPROTOENT,   /* 298 */
-       OP_SSERVENT,    /* 299 */
-       OP_EHOSTENT,    /* 300 */
-       OP_ENETENT,     /* 301 */
-       OP_EPROTOENT,   /* 302 */
-       OP_ESERVENT,    /* 303 */
-       OP_GPWNAM,      /* 304 */
-       OP_GPWUID,      /* 305 */
-       OP_GPWENT,      /* 306 */
-       OP_SPWENT,      /* 307 */
-       OP_EPWENT,      /* 308 */
-       OP_GGRNAM,      /* 309 */
-       OP_GGRGID,      /* 310 */
-       OP_GGRENT,      /* 311 */
-       OP_SGRENT,      /* 312 */
-       OP_EGRENT,      /* 313 */
-       OP_GETLOGIN,    /* 314 */
-       OP_SYSCALL,     /* 315 */
+       OP_PADANY,      /* 12 */
+       OP_PUSHRE,      /* 13 */
+       OP_RV2GV,       /* 14 */
+       OP_SV2LEN,      /* 15 */
+       OP_RV2SV,       /* 16 */
+       OP_AV2ARYLEN,   /* 17 */
+       OP_RV2CV,       /* 18 */
+       OP_REFGEN,      /* 19 */
+       OP_REF,         /* 20 */
+       OP_BLESS,       /* 21 */
+       OP_BACKTICK,    /* 22 */
+       OP_GLOB,        /* 23 */
+       OP_READLINE,    /* 24 */
+       OP_RCATLINE,    /* 25 */
+       OP_REGCMAYBE,   /* 26 */
+       OP_REGCOMP,     /* 27 */
+       OP_MATCH,       /* 28 */
+       OP_SUBST,       /* 29 */
+       OP_SUBSTCONT,   /* 30 */
+       OP_TRANS,       /* 31 */
+       OP_SASSIGN,     /* 32 */
+       OP_AASSIGN,     /* 33 */
+       OP_SCHOP,       /* 34 */
+       OP_CHOP,        /* 35 */
+       OP_DEFINED,     /* 36 */
+       OP_UNDEF,       /* 37 */
+       OP_STUDY,       /* 38 */
+       OP_PREINC,      /* 39 */
+       OP_PREDEC,      /* 40 */
+       OP_POSTINC,     /* 41 */
+       OP_POSTDEC,     /* 42 */
+       OP_POW,         /* 43 */
+       OP_MULTIPLY,    /* 44 */
+       OP_DIVIDE,      /* 45 */
+       OP_MODULO,      /* 46 */
+       OP_REPEAT,      /* 47 */
+       OP_ADD,         /* 48 */
+       OP_INTADD,      /* 49 */
+       OP_SUBTRACT,    /* 50 */
+       OP_CONCAT,      /* 51 */
+       OP_LEFT_SHIFT,  /* 52 */
+       OP_RIGHT_SHIFT, /* 53 */
+       OP_LT,          /* 54 */
+       OP_GT,          /* 55 */
+       OP_LE,          /* 56 */
+       OP_GE,          /* 57 */
+       OP_EQ,          /* 58 */
+       OP_NE,          /* 59 */
+       OP_NCMP,        /* 60 */
+       OP_SLT,         /* 61 */
+       OP_SGT,         /* 62 */
+       OP_SLE,         /* 63 */
+       OP_SGE,         /* 64 */
+       OP_SEQ,         /* 65 */
+       OP_SNE,         /* 66 */
+       OP_SCMP,        /* 67 */
+       OP_BIT_AND,     /* 68 */
+       OP_XOR,         /* 69 */
+       OP_BIT_OR,      /* 70 */
+       OP_NEGATE,      /* 71 */
+       OP_NOT,         /* 72 */
+       OP_COMPLEMENT,  /* 73 */
+       OP_ATAN2,       /* 74 */
+       OP_SIN,         /* 75 */
+       OP_COS,         /* 76 */
+       OP_RAND,        /* 77 */
+       OP_SRAND,       /* 78 */
+       OP_EXP,         /* 79 */
+       OP_LOG,         /* 80 */
+       OP_SQRT,        /* 81 */
+       OP_INT,         /* 82 */
+       OP_HEX,         /* 83 */
+       OP_OCT,         /* 84 */
+       OP_ABS,         /* 85 */
+       OP_LENGTH,      /* 86 */
+       OP_SUBSTR,      /* 87 */
+       OP_VEC,         /* 88 */
+       OP_INDEX,       /* 89 */
+       OP_RINDEX,      /* 90 */
+       OP_SPRINTF,     /* 91 */
+       OP_FORMLINE,    /* 92 */
+       OP_ORD,         /* 93 */
+       OP_CHR,         /* 94 */
+       OP_CRYPT,       /* 95 */
+       OP_UCFIRST,     /* 96 */
+       OP_LCFIRST,     /* 97 */
+       OP_UC,          /* 98 */
+       OP_LC,          /* 99 */
+       OP_RV2AV,       /* 100 */
+       OP_AELEMFAST,   /* 101 */
+       OP_AELEM,       /* 102 */
+       OP_ASLICE,      /* 103 */
+       OP_EACH,        /* 104 */
+       OP_VALUES,      /* 105 */
+       OP_KEYS,        /* 106 */
+       OP_DELETE,      /* 107 */
+       OP_RV2HV,       /* 108 */
+       OP_HELEM,       /* 109 */
+       OP_HSLICE,      /* 110 */
+       OP_UNPACK,      /* 111 */
+       OP_PACK,        /* 112 */
+       OP_SPLIT,       /* 113 */
+       OP_JOIN,        /* 114 */
+       OP_LIST,        /* 115 */
+       OP_LSLICE,      /* 116 */
+       OP_ANONLIST,    /* 117 */
+       OP_ANONHASH,    /* 118 */
+       OP_SPLICE,      /* 119 */
+       OP_PUSH,        /* 120 */
+       OP_POP,         /* 121 */
+       OP_SHIFT,       /* 122 */
+       OP_UNSHIFT,     /* 123 */
+       OP_SORT,        /* 124 */
+       OP_REVERSE,     /* 125 */
+       OP_GREPSTART,   /* 126 */
+       OP_GREPWHILE,   /* 127 */
+       OP_RANGE,       /* 128 */
+       OP_FLIP,        /* 129 */
+       OP_FLOP,        /* 130 */
+       OP_AND,         /* 131 */
+       OP_OR,          /* 132 */
+       OP_COND_EXPR,   /* 133 */
+       OP_ANDASSIGN,   /* 134 */
+       OP_ORASSIGN,    /* 135 */
+       OP_METHOD,      /* 136 */
+       OP_ENTERSUBR,   /* 137 */
+       OP_LEAVESUBR,   /* 138 */
+       OP_CALLER,      /* 139 */
+       OP_WARN,        /* 140 */
+       OP_DIE,         /* 141 */
+       OP_RESET,       /* 142 */
+       OP_LINESEQ,     /* 143 */
+       OP_NEXTSTATE,   /* 144 */
+       OP_DBSTATE,     /* 145 */
+       OP_UNSTACK,     /* 146 */
+       OP_ENTER,       /* 147 */
+       OP_LEAVE,       /* 148 */
+       OP_SCOPE,       /* 149 */
+       OP_ENTERITER,   /* 150 */
+       OP_ITER,        /* 151 */
+       OP_ENTERLOOP,   /* 152 */
+       OP_LEAVELOOP,   /* 153 */
+       OP_RETURN,      /* 154 */
+       OP_LAST,        /* 155 */
+       OP_NEXT,        /* 156 */
+       OP_REDO,        /* 157 */
+       OP_DUMP,        /* 158 */
+       OP_GOTO,        /* 159 */
+       OP_EXIT,        /* 160 */
+       OP_NSWITCH,     /* 161 */
+       OP_CSWITCH,     /* 162 */
+       OP_OPEN,        /* 163 */
+       OP_CLOSE,       /* 164 */
+       OP_PIPE_OP,     /* 165 */
+       OP_FILENO,      /* 166 */
+       OP_UMASK,       /* 167 */
+       OP_BINMODE,     /* 168 */
+       OP_TIE,         /* 169 */
+       OP_UNTIE,       /* 170 */
+       OP_DBMOPEN,     /* 171 */
+       OP_DBMCLOSE,    /* 172 */
+       OP_SSELECT,     /* 173 */
+       OP_SELECT,      /* 174 */
+       OP_GETC,        /* 175 */
+       OP_READ,        /* 176 */
+       OP_ENTERWRITE,  /* 177 */
+       OP_LEAVEWRITE,  /* 178 */
+       OP_PRTF,        /* 179 */
+       OP_PRINT,       /* 180 */
+       OP_SYSREAD,     /* 181 */
+       OP_SYSWRITE,    /* 182 */
+       OP_SEND,        /* 183 */
+       OP_RECV,        /* 184 */
+       OP_EOF,         /* 185 */
+       OP_TELL,        /* 186 */
+       OP_SEEK,        /* 187 */
+       OP_TRUNCATE,    /* 188 */
+       OP_FCNTL,       /* 189 */
+       OP_IOCTL,       /* 190 */
+       OP_FLOCK,       /* 191 */
+       OP_SOCKET,      /* 192 */
+       OP_SOCKPAIR,    /* 193 */
+       OP_BIND,        /* 194 */
+       OP_CONNECT,     /* 195 */
+       OP_LISTEN,      /* 196 */
+       OP_ACCEPT,      /* 197 */
+       OP_SHUTDOWN,    /* 198 */
+       OP_GSOCKOPT,    /* 199 */
+       OP_SSOCKOPT,    /* 200 */
+       OP_GETSOCKNAME, /* 201 */
+       OP_GETPEERNAME, /* 202 */
+       OP_LSTAT,       /* 203 */
+       OP_STAT,        /* 204 */
+       OP_FTRREAD,     /* 205 */
+       OP_FTRWRITE,    /* 206 */
+       OP_FTREXEC,     /* 207 */
+       OP_FTEREAD,     /* 208 */
+       OP_FTEWRITE,    /* 209 */
+       OP_FTEEXEC,     /* 210 */
+       OP_FTIS,        /* 211 */
+       OP_FTEOWNED,    /* 212 */
+       OP_FTROWNED,    /* 213 */
+       OP_FTZERO,      /* 214 */
+       OP_FTSIZE,      /* 215 */
+       OP_FTMTIME,     /* 216 */
+       OP_FTATIME,     /* 217 */
+       OP_FTCTIME,     /* 218 */
+       OP_FTSOCK,      /* 219 */
+       OP_FTCHR,       /* 220 */
+       OP_FTBLK,       /* 221 */
+       OP_FTFILE,      /* 222 */
+       OP_FTDIR,       /* 223 */
+       OP_FTPIPE,      /* 224 */
+       OP_FTLINK,      /* 225 */
+       OP_FTSUID,      /* 226 */
+       OP_FTSGID,      /* 227 */
+       OP_FTSVTX,      /* 228 */
+       OP_FTTTY,       /* 229 */
+       OP_FTTEXT,      /* 230 */
+       OP_FTBINARY,    /* 231 */
+       OP_CHDIR,       /* 232 */
+       OP_CHOWN,       /* 233 */
+       OP_CHROOT,      /* 234 */
+       OP_UNLINK,      /* 235 */
+       OP_CHMOD,       /* 236 */
+       OP_UTIME,       /* 237 */
+       OP_RENAME,      /* 238 */
+       OP_LINK,        /* 239 */
+       OP_SYMLINK,     /* 240 */
+       OP_READLINK,    /* 241 */
+       OP_MKDIR,       /* 242 */
+       OP_RMDIR,       /* 243 */
+       OP_OPEN_DIR,    /* 244 */
+       OP_READDIR,     /* 245 */
+       OP_TELLDIR,     /* 246 */
+       OP_SEEKDIR,     /* 247 */
+       OP_REWINDDIR,   /* 248 */
+       OP_CLOSEDIR,    /* 249 */
+       OP_FORK,        /* 250 */
+       OP_WAIT,        /* 251 */
+       OP_WAITPID,     /* 252 */
+       OP_SYSTEM,      /* 253 */
+       OP_EXEC,        /* 254 */
+       OP_KILL,        /* 255 */
+       OP_GETPPID,     /* 256 */
+       OP_GETPGRP,     /* 257 */
+       OP_SETPGRP,     /* 258 */
+       OP_GETPRIORITY, /* 259 */
+       OP_SETPRIORITY, /* 260 */
+       OP_TIME,        /* 261 */
+       OP_TMS,         /* 262 */
+       OP_LOCALTIME,   /* 263 */
+       OP_GMTIME,      /* 264 */
+       OP_ALARM,       /* 265 */
+       OP_SLEEP,       /* 266 */
+       OP_SHMGET,      /* 267 */
+       OP_SHMCTL,      /* 268 */
+       OP_SHMREAD,     /* 269 */
+       OP_SHMWRITE,    /* 270 */
+       OP_MSGGET,      /* 271 */
+       OP_MSGCTL,      /* 272 */
+       OP_MSGSND,      /* 273 */
+       OP_MSGRCV,      /* 274 */
+       OP_SEMGET,      /* 275 */
+       OP_SEMCTL,      /* 276 */
+       OP_SEMOP,       /* 277 */
+       OP_REQUIRE,     /* 278 */
+       OP_DOFILE,      /* 279 */
+       OP_ENTEREVAL,   /* 280 */
+       OP_LEAVEEVAL,   /* 281 */
+       OP_EVALONCE,    /* 282 */
+       OP_ENTERTRY,    /* 283 */
+       OP_LEAVETRY,    /* 284 */
+       OP_GHBYNAME,    /* 285 */
+       OP_GHBYADDR,    /* 286 */
+       OP_GHOSTENT,    /* 287 */
+       OP_GNBYNAME,    /* 288 */
+       OP_GNBYADDR,    /* 289 */
+       OP_GNETENT,     /* 290 */
+       OP_GPBYNAME,    /* 291 */
+       OP_GPBYNUMBER,  /* 292 */
+       OP_GPROTOENT,   /* 293 */
+       OP_GSBYNAME,    /* 294 */
+       OP_GSBYPORT,    /* 295 */
+       OP_GSERVENT,    /* 296 */
+       OP_SHOSTENT,    /* 297 */
+       OP_SNETENT,     /* 298 */
+       OP_SPROTOENT,   /* 299 */
+       OP_SSERVENT,    /* 300 */
+       OP_EHOSTENT,    /* 301 */
+       OP_ENETENT,     /* 302 */
+       OP_EPROTOENT,   /* 303 */
+       OP_ESERVENT,    /* 304 */
+       OP_GPWNAM,      /* 305 */
+       OP_GPWUID,      /* 306 */
+       OP_GPWENT,      /* 307 */
+       OP_SPWENT,      /* 308 */
+       OP_EPWENT,      /* 309 */
+       OP_GGRNAM,      /* 310 */
+       OP_GGRGID,      /* 311 */
+       OP_GGRENT,      /* 312 */
+       OP_SGRENT,      /* 313 */
+       OP_EGRENT,      /* 314 */
+       OP_GETLOGIN,    /* 315 */
+       OP_SYSCALL,     /* 316 */
 } opcode;
 
-#define MAXO 316
+#define MAXO 317
 
 #ifndef DOINIT
 extern char *op_name[];
@@ -335,6 +336,7 @@ char *op_name[] = {
        "private variable",
        "private array",
        "private hash",
+       "private something",
        "push regexp",
        "ref-to-glob cast",
        "scalar value length",
@@ -680,6 +682,7 @@ OP *        pp_gv           P((void));
 OP *   pp_padsv        P((void));
 OP *   pp_padav        P((void));
 OP *   pp_padhv        P((void));
+OP *   pp_padany       P((void));
 OP *   pp_pushre       P((void));
 OP *   pp_rv2gv        P((void));
 OP *   pp_sv2len       P((void));
@@ -1001,6 +1004,7 @@ OP * (*ppaddr[])() = {
        pp_padsv,
        pp_padav,
        pp_padhv,
+       pp_padany,
        pp_pushre,
        pp_rv2gv,
        pp_sv2len,
@@ -1324,6 +1328,7 @@ OP * (*check[])() = {
        ck_null,        /* padsv */
        ck_null,        /* padav */
        ck_null,        /* padhv */
+       ck_null,        /* padany */
        ck_null,        /* pushre */
        ck_rvconst,     /* rv2gv */
        ck_null,        /* sv2len */
@@ -1647,6 +1652,7 @@ U32 opargs[] = {
        0x00000000,     /* padsv */
        0x00000000,     /* padav */
        0x00000000,     /* padhv */
+       0x00000000,     /* padany */
        0x00000000,     /* pushre */
        0x00000044,     /* rv2gv */
        0x0000001c,     /* sv2len */
@@ -1912,7 +1918,7 @@ U32 opargs[] = {
        0x0001111d,     /* semget */
        0x0011111d,     /* semctl */
        0x0001111d,     /* semop */
-       0x00000140,     /* require */
+       0x00000940,     /* require */
        0x00000140,     /* dofile */
        0x00000140,     /* entereval */
        0x00000100,     /* leaveeval */
index 06a729b..321188e 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -171,6 +171,7 @@ gv          glob value              ck_null         ds
 padsv          private variable        ck_null         0
 padav          private array           ck_null         0
 padhv          private hash            ck_null         0
+padany         private something       ck_null         0
 
 pushre         push regexp             ck_null         0
 
@@ -538,7 +539,7 @@ semop               semop                   ck_fun          imst    S S S
 
 # Eval.
 
-require                require                 ck_fun          d       S
+require                require                 ck_fun          d       S?
 dofile         do 'file'               ck_fun          d       S
 entereval      eval string             ck_eval         d       S
 leaveeval      eval exit               ck_null         0       S
diff --git a/peek b/peek
new file mode 100755 (executable)
index 0000000..057c897
--- /dev/null
+++ b/peek
@@ -0,0 +1,31 @@
+#!./perl
+
+sub peekstr {
+    local ($addr, $len) = @_;
+    local ($mem) = unpack("P$len", pack("L",$addr+0));
+    $mem;
+}
+
+sub unpackmem {
+    local ($addr, $len, $template) = @_;
+    local $mem = peekstr($addr, $len);
+    unpack($template, $mem);
+}
+
+$foo = "stuff";
+
+($any, $refcnt, $type, $flags, $storage, $private) =
+       unpackmem(\$foo, 12, "L2 C4");
+
+printf "SV = any %lx refcnt %d type %d flags %x storage '%c' private %x\n",
+       $any, $refcnt, $type, $flags, $storage, $private;
+
+if ($type >= 4) {
+    ($pv, $cur, $len) = unpackmem($any, 12, "L3");
+
+    printf "XPV = pv %lx cur %d len %d\n", $pv,$cur,$len;
+
+    $string = peekstr($pv, $cur);
+
+    print "String = $string\n"
+}
diff --git a/perl.c b/perl.c
index 342714f..c6c2bee 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -109,6 +109,7 @@ register PerlInterpreter *sv_interp;
     /* Init the real globals? */
     if (!linestr) {
        linestr = NEWSV(65,80);
+       sv_upgrade(linestr,SVt_PVIV);
 
        SvREADONLY_on(&sv_undef);
 
@@ -693,7 +694,7 @@ char *s;
        s++;
        return s;
     case 'v':
-       fputs("\nThis is perl, version 5.0, Alpha 4 (unsupported)\n\n",stdout);
+       fputs("\nThis is perl, version 5.0, Alpha 5 (unsupported)\n\n",stdout);
        fputs(rcsid,stdout);
        fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
 #ifdef MSDOS
diff --git a/perl.h b/perl.h
index 747f8a1..1b32d4d 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -272,6 +272,12 @@ char Error[1];
 #endif
 
 #include <errno.h>
+#ifdef HAS_SOCKET
+#   ifndef ENOTSOCK
+#     include <net/errno.h>
+#   endif
+#endif
+
 #ifndef MSDOS
 #   ifndef errno
        extern int errno;     /* ANSI allows errno to be an lvalue expr */
@@ -520,6 +526,7 @@ typedef struct context CONTEXT;
 typedef struct block BLOCK;
 
 typedef struct magic MAGIC;
+typedef struct xrv XRV;
 typedef struct xpv XPV;
 typedef struct xpviv XPVIV;
 typedef struct xpvnv XPVNV;
@@ -631,6 +638,13 @@ U32 cast_ulong P((double));
 #define U_L(what) (cast_ulong(what))
 #endif
 
+#ifdef CASTI32
+#define I_32(what) ((I32)(what))
+#else
+I32 cast_i32 P((double));
+#define I_32(what) (cast_i32(what))
+#endif
+
 struct Outrec {
     I32                o_lines;
     char       *o_str;
diff --git a/perly.c b/perly.c
index f0a7fea..8fd9983 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -1699,7 +1699,7 @@ yyloop:
             yys = 0;
             if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
             if (!yys) yys = "illegal-symbol";
-            printf("yydebug: state %d, reading %d (%s)\n", yystate,
+            fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
                     yychar, yys);
         }
 #endif
@@ -1709,7 +1709,7 @@ yyloop:
     {
 #if YYDEBUG
         if (yydebug)
-            printf("yydebug: state %d, shifting to state %d\n",
+            fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
                     yystate, yytable[yyn]);
 #endif
         if (yyssp >= yyss + yystacksize - 1)
@@ -1762,8 +1762,9 @@ yyinrecovery:
             {
 #if YYDEBUG
                 if (yydebug)
-                    printf("yydebug: state %d, error recovery shifting\
- to state %d\n", *yyssp, yytable[yyn]);
+                    fprintf(stderr,
+                    "yydebug: state %d, error recovery shifting to state %d\n",
+                    *yyssp, yytable[yyn]);
 #endif
                 if (yyssp >= yyss + yystacksize - 1)
                 {
@@ -1791,8 +1792,9 @@ yyinrecovery:
             {
 #if YYDEBUG
                 if (yydebug)
-                    printf("yydebug: error recovery discarding state %d\n",
-                            *yyssp);
+                    fprintf(stderr,
+                       "yydebug: error recovery discarding state %d\n",
+                       *yyssp);
 #endif
                 if (yyssp <= yyss) goto yyabort;
                 --yyssp;
@@ -1809,8 +1811,9 @@ yyinrecovery:
             yys = 0;
             if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
             if (!yys) yys = "illegal-symbol";
-            printf("yydebug: state %d, error recovery discards token %d (%s)\n",
-                    yystate, yychar, yys);
+            fprintf(stderr,
+               "yydebug: state %d, error recovery discards token %d (%s)\n",
+               yystate, yychar, yys);
         }
 #endif
         yychar = (-1);
@@ -1819,7 +1822,7 @@ yyinrecovery:
 yyreduce:
 #if YYDEBUG
     if (yydebug)
-        printf("yydebug: state %d, reducing by rule %d (%s)\n",
+        fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
                 yystate, yyn, yyrule[yyn]);
 #endif
     yym = yylen[yyn];
@@ -2571,8 +2574,9 @@ break;
     {
 #if YYDEBUG
         if (yydebug)
-            printf("yydebug: after reduction, shifting from state 0 to\
- state %d\n", YYFINAL);
+            fprintf(stderr,
+               "yydebug: after reduction, shifting from state 0 to state %d\n",
+               YYFINAL);
 #endif
         yystate = YYFINAL;
         *++yyssp = YYFINAL;
@@ -2586,7 +2590,7 @@ break;
                 yys = 0;
                 if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
                 if (!yys) yys = "illegal-symbol";
-                printf("yydebug: state %d, reading %d (%s)\n",
+                fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
                         YYFINAL, yychar, yys);
             }
 #endif
@@ -2601,8 +2605,9 @@ break;
         yystate = yydgoto[yym];
 #if YYDEBUG
     if (yydebug)
-        printf("yydebug: after reduction, shifting from state %d \
-to state %d\n", *yyssp, yystate);
+        fprintf(stderr,
+           "yydebug: after reduction, shifting from state %d to state %d\n",
+           *yyssp, yystate);
 #endif
     if (yyssp >= yyss + yystacksize - 1)
     {
index 06a8b6c..4d81353 100644 (file)
@@ -1,7 +1,7 @@
-*** perly.c.byacc      Tue Oct  5 15:44:31 1993
---- perly.c    Tue Oct  5 16:23:53 1993
+*** perly.c.orig       Fri Jan 14 03:56:26 1994
+--- perly.c    Sun Jan 16 18:29:19 1994
 ***************
-*** 1396,1408 ****
+*** 1635,1647 ****
   int yynerrs;
   int yyerrflag;
   int yychar;
 - short yyss[YYSTACKSIZE];
 - YYSTYPE yyvs[YYSTACKSIZE];
 - #define yystacksize YYSTACKSIZE
-  #line 573 "perly.y"
+  #line 605 "perly.y"
    /* PROGRAM */
-  #line 1409 "y.tab.c"
---- 1396,1403 ----
+  #line 1648 "y.tab.c"
+--- 1635,1642 ----
 ***************
-*** 1413,1418 ****
---- 1408,1426 ----
+*** 1652,1657 ****
+--- 1647,1665 ----
   yyparse()
   {
       register int yym, yyn, yystate;
@@ -39,8 +39,8 @@
       register char *yys;
       extern char *getenv();
 ***************
-*** 1429,1434 ****
---- 1437,1450 ----
+*** 1668,1673 ****
+--- 1676,1689 ----
       yyerrflag = 0;
       yychar = (-1);
   
       yyvsp = yyvs;
       *yyssp = yystate = 0;
 ***************
-*** 1459,1465 ****
+*** 1683,1689 ****
+              yys = 0;
+              if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+              if (!yys) yys = "illegal-symbol";
+!             printf("yydebug: state %d, reading %d (%s)\n", yystate,
+                      yychar, yys);
+          }
+  #endif
+--- 1699,1705 ----
+              yys = 0;
+              if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+              if (!yys) yys = "illegal-symbol";
+!             fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
+                      yychar, yys);
+          }
+  #endif
+***************
+*** 1693,1704 ****
+      {
+  #if YYDEBUG
+          if (yydebug)
+!             printf("yydebug: state %d, shifting to state %d\n",
+                      yystate, yytable[yyn]);
   #endif
           if (yyssp >= yyss + yystacksize - 1)
           {
           }
           *++yyssp = yystate = yytable[yyn];
           *++yyvsp = yylval;
---- 1475,1493 ----
+--- 1709,1732 ----
+      {
+  #if YYDEBUG
+          if (yydebug)
+!             fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
+                      yystate, yytable[yyn]);
   #endif
           if (yyssp >= yyss + yystacksize - 1)
           {
           *++yyssp = yystate = yytable[yyn];
           *++yyvsp = yylval;
 ***************
-*** 1500,1506 ****
+*** 1734,1745 ****
+              {
+  #if YYDEBUG
+                  if (yydebug)
+!                     printf("yydebug: state %d, error recovery shifting\
+!  to state %d\n", *yyssp, yytable[yyn]);
   #endif
                   if (yyssp >= yyss + yystacksize - 1)
                   {
                   }
                   *++yyssp = yystate = yytable[yyn];
                   *++yyvsp = yylval;
---- 1528,1548 ----
+--- 1762,1788 ----
+              {
+  #if YYDEBUG
+                  if (yydebug)
+!                     fprintf(stderr,
+!                   "yydebug: state %d, error recovery shifting to state %d\n",
+!                   *yyssp, yytable[yyn]);
   #endif
                   if (yyssp >= yyss + yystacksize - 1)
                   {
                   *++yyssp = yystate = yytable[yyn];
                   *++yyvsp = yylval;
 ***************
-*** 2281,2295 ****
+*** 1749,1756 ****
+              {
+  #if YYDEBUG
+                  if (yydebug)
+!                     printf("yydebug: error recovery discarding state %d\n",
+!                             *yyssp);
+  #endif
+                  if (yyssp <= yyss) goto yyabort;
+                  --yyssp;
+--- 1792,1800 ----
+              {
+  #if YYDEBUG
+                  if (yydebug)
+!                     fprintf(stderr,
+!                      "yydebug: error recovery discarding state %d\n",
+!                      *yyssp);
+  #endif
+                  if (yyssp <= yyss) goto yyabort;
+                  --yyssp;
+***************
+*** 1767,1774 ****
+              yys = 0;
+              if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+              if (!yys) yys = "illegal-symbol";
+!             printf("yydebug: state %d, error recovery discards token %d (%s)\n",
+!                     yystate, yychar, yys);
+          }
+  #endif
+          yychar = (-1);
+--- 1811,1819 ----
+              yys = 0;
+              if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+              if (!yys) yys = "illegal-symbol";
+!             fprintf(stderr,
+!              "yydebug: state %d, error recovery discards token %d (%s)\n",
+!              yystate, yychar, yys);
+          }
+  #endif
+          yychar = (-1);
+***************
+*** 1777,1783 ****
+  yyreduce:
+  #if YYDEBUG
+      if (yydebug)
+!         printf("yydebug: state %d, reducing by rule %d (%s)\n",
+                  yystate, yyn, yyrule[yyn]);
+  #endif
+      yym = yylen[yyn];
+--- 1822,1828 ----
+  yyreduce:
+  #if YYDEBUG
+      if (yydebug)
+!         fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
+                  yystate, yyn, yyrule[yyn]);
+  #endif
+      yym = yylen[yyn];
+***************
+*** 2529,2536 ****
+      {
+  #if YYDEBUG
+          if (yydebug)
+!             printf("yydebug: after reduction, shifting from state 0 to\
+!  state %d\n", YYFINAL);
+  #endif
+          yystate = YYFINAL;
+          *++yyssp = YYFINAL;
+--- 2574,2582 ----
+      {
+  #if YYDEBUG
+          if (yydebug)
+!             fprintf(stderr,
+!              "yydebug: after reduction, shifting from state 0 to state %d\n",
+!              YYFINAL);
+  #endif
+          yystate = YYFINAL;
+          *++yyssp = YYFINAL;
+***************
+*** 2544,2550 ****
+                  yys = 0;
+                  if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+                  if (!yys) yys = "illegal-symbol";
+!                 printf("yydebug: state %d, reading %d (%s)\n",
+                          YYFINAL, yychar, yys);
+              }
+  #endif
+--- 2590,2596 ----
+                  yys = 0;
+                  if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+                  if (!yys) yys = "illegal-symbol";
+!                 fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
+                          YYFINAL, yychar, yys);
+              }
+  #endif
+***************
+*** 2559,2578 ****
+          yystate = yydgoto[yym];
+  #if YYDEBUG
+      if (yydebug)
+!         printf("yydebug: after reduction, shifting from state %d \
+! to state %d\n", *yyssp, yystate);
   #endif
       if (yyssp >= yyss + yystacksize - 1)
       {
   yyaccept:
 !     return (0);
   }
---- 2323,2357 ----
+--- 2605,2645 ----
+          yystate = yydgoto[yym];
+  #if YYDEBUG
+      if (yydebug)
+!         fprintf(stderr,
+!          "yydebug: after reduction, shifting from state %d to state %d\n",
+!          *yyssp, yystate);
   #endif
       if (yyssp >= yyss + yystacksize - 1)
       {
diff --git a/pp.c b/pp.c
index 7c069a5..c819f38 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -204,6 +204,11 @@ PP(pp_padhv)
     return pp_rv2hv();
 }
 
+PP(pp_padany)
+{
+    DIE("NOT IMPL LINE %d",__LINE__);
+}
+
 PP(pp_pushre)
 {
     dSP;
@@ -216,8 +221,8 @@ PP(pp_pushre)
 PP(pp_rv2gv)
 {
     dSP; dTOPss;
-    if (SvTYPE(sv) == SVt_REF) {
-       sv = (SV*)SvANY(sv);
+    if (SvROK(sv)) {
+       sv = SvRV(sv);
        if (SvTYPE(sv) != SVt_PVGV)
            DIE("Not a glob reference");
     }
@@ -264,8 +269,8 @@ PP(pp_rv2sv)
 {
     dSP; dTOPss;
 
-    if (SvTYPE(sv) == SVt_REF) {
-       sv = (SV*)SvANY(sv);
+    if (SvROK(sv)) {
+       sv = SvRV(sv);
        switch (SvTYPE(sv)) {
        case SVt_PVAV:
        case SVt_PVHV:
@@ -282,19 +287,21 @@ PP(pp_rv2sv)
        }
        sv = GvSV(gv);
        if (op->op_private == OP_RV2HV &&
-         (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVHV)) {
+         (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVHV)) {
            sv_free(sv);
            sv = NEWSV(0,0);
-           sv_upgrade(sv, SVt_REF);
-           SvANY(sv) = (void*)sv_ref((SV*)newHV());
+           sv_upgrade(sv, SVt_RV);
+           SvRV(sv) = sv_ref((SV*)newHV());
+           SvROK_on(sv);
            GvSV(gv) = sv;
        }
        else if (op->op_private == OP_RV2AV &&
-         (SvTYPE(sv) != SVt_REF || SvTYPE((SV*)SvANY(sv)) != SVt_PVAV)) {
+         (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)) {
            sv_free(sv);
            sv = NEWSV(0,0);
-           sv_upgrade(sv, SVt_REF);
-           SvANY(sv) = (void*)sv_ref((SV*)newAV());
+           sv_upgrade(sv, SVt_RV);
+           SvRV(sv) = sv_ref((SV*)newAV());
+           SvROK_on(sv);
            GvSV(gv) = sv;
        }
     }
@@ -338,8 +345,9 @@ PP(pp_refgen)
     if (!sv)
        RETSETUNDEF;
     rv = sv_mortalcopy(&sv_undef);
-    sv_upgrade(rv, SVt_REF);
-    SvANY(rv) = (void*)sv_ref(sv);
+    sv_upgrade(rv, SVt_RV);
+    SvRV(rv) = sv_ref(sv);
+    SvROK_on(rv);
     SETs(rv);
     RETURN;
 }
@@ -356,23 +364,28 @@ PP(pp_ref)
     }
     else
        sv = POPs;
-    if (SvTYPE(sv) != SVt_REF)
+    if (!SvROK(sv))
        RETPUSHUNDEF;
 
-    sv = (SV*)SvANY(sv);
-    if (SvSTORAGE(sv) == 'O')
+    sv = SvRV(sv);
+    if (SvOBJECT(sv))
        pv = HvNAME(SvSTASH(sv));
     else {
        switch (SvTYPE(sv)) {
-       case SVt_REF:           pv = "REF";             break;
        case SVt_NULL:
        case SVt_IV:
        case SVt_NV:
+       case SVt_RV:
        case SVt_PV:
        case SVt_PVIV:
        case SVt_PVNV:
        case SVt_PVMG:
-       case SVt_PVBM:          pv = "SCALAR";          break;
+       case SVt_PVBM:
+                               if (SvROK(sv))
+                                   pv = "REF";
+                               else
+                                   pv = "SCALAR";
+                               break;
        case SVt_PVLV:          pv = "LVALUE";          break;
        case SVt_PVAV:          pv = "ARRAY";           break;
        case SVt_PVHV:          pv = "HASH";            break;
@@ -399,12 +412,10 @@ PP(pp_bless)
        stash = fetch_stash(POPs, TRUE);
 
     sv = TOPs;
-    if (SvTYPE(sv) != SVt_REF)
+    if (!SvROK(sv))
        DIE("Can't bless non-reference value");
-    ref = (SV*)SvANY(sv);
-    if (SvSTORAGE(ref) && SvSTORAGE(ref) != 'O')
-       DIE("Can't bless temporary scalar");
-    SvSTORAGE(ref) = 'O';
+    ref = SvRV(sv);
+    SvOBJECT_on(ref);
     SvUPGRADE(ref, SVt_PVMG);
     SvSTASH(ref) = stash;
     RETURN;
@@ -832,7 +843,7 @@ yup:
     if (pm->op_pmflags & PMf_ONCE)
        pm->op_pmflags |= PMf_USED;
     if (global) {
-       rx->subbeg = t;
+       rx->subbeg = truebase;
        rx->subend = strend;
        rx->startp[0] = s;
        rx->endp[0] = s + SvCUR(pm->op_pmshort);
@@ -1254,11 +1265,15 @@ PP(pp_aassign)
            }
            break;
        default:
-           if (SvREADONLY(sv)) {
-               if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
-                   DIE(no_modify);
-               if (relem <= lastrelem)
-                   relem++;
+           if (SvTHINKFIRST(sv)) {
+               if (SvREADONLY(sv)) {
+                   if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
+                       DIE(no_modify);
+                   if (relem <= lastrelem)
+                       relem++;
+               }
+               if (SvROK(sv))
+                   sv_unref(sv);
                break;
            }
            if (relem <= lastrelem) {
@@ -1405,17 +1420,19 @@ PP(pp_undef)
        RETPUSHUNDEF;
 
     sv = POPs;
-    if (!sv || SvREADONLY(sv))
+    if (!sv)
        RETPUSHUNDEF;
 
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           RETPUSHUNDEF;
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
+
     switch (SvTYPE(sv)) {
     case SVt_NULL:
        break;
-    case SVt_REF:
-       sv_free((SV*)SvANY(sv));
-       SvANY(sv) = 0;
-       SvTYPE(sv) = SVt_NULL;
-       break;
     case SVt_PVAV:
        av_undef((AV*)sv);
        break;
@@ -1634,8 +1651,12 @@ PP(pp_repeat)
        char *tmps;
 
        tmpstr = POPs;
-       if (SvREADONLY(tmpstr))
-           DIE("Can't x= to readonly value");
+       if (SvTHINKFIRST(tmpstr)) {
+           if (SvREADONLY(tmpstr))
+               DIE("Can't x= to readonly value");
+           if (SvROK(tmpstr))
+               sv_unref(tmpstr);
+       }
        SvSetSV(TARG, tmpstr);
        if (count >= 1) {
            STRLEN len;
@@ -2138,8 +2159,12 @@ PP(pp_substr)
            rem = len;
        sv_setpvn(TARG, tmps, rem);
        if (lvalue) {                   /* it's an lvalue! */
-           if (SvREADONLY(sv))
-               DIE(no_modify);
+           if (SvTHINKFIRST(sv)) {
+               if (SvREADONLY(sv))
+                   DIE(no_modify);
+               if (SvROK(sv))
+                   sv_unref(sv);
+           }
            LvTYPE(TARG) = 's';
            LvTARG(TARG) = sv;
            LvTARGOFF(TARG) = tmps - SvPV(sv, na); 
@@ -2190,8 +2215,12 @@ PP(pp_vec)
        }
 
        if (lvalue) {                      /* it's an lvalue! */
-           if (SvREADONLY(src))
-               DIE(no_modify);
+           if (SvTHINKFIRST(src)) {
+               if (SvREADONLY(src))
+                   DIE(no_modify);
+               if (SvROK(src))
+                   sv_unref(src);
+           }
            LvTYPE(TARG) = 'v';
            LvTARG(TARG) = src;
            LvTARGOFF(TARG) = offset; 
@@ -2795,7 +2824,7 @@ PP(pp_ucfirst)
     SV *sv = TOPs;
     register char *s;
 
-    if (SvSTORAGE(sv) != 'T') {
+    if (!SvPADTMP(sv)) {
        dTARGET;
        sv_setsv(TARG, sv);
        sv = TARG;
@@ -2814,7 +2843,7 @@ PP(pp_lcfirst)
     SV *sv = TOPs;
     register char *s;
 
-    if (SvSTORAGE(sv) != 'T') {
+    if (!SvPADTMP(sv)) {
        dTARGET;
        sv_setsv(TARG, sv);
        sv = TARG;
@@ -2836,7 +2865,7 @@ PP(pp_uc)
     register char *send;
     STRLEN len;
 
-    if (SvSTORAGE(sv) != 'T') {
+    if (!SvPADTMP(sv)) {
        dTARGET;
        sv_setsv(TARG, sv);
        sv = TARG;
@@ -2860,7 +2889,7 @@ PP(pp_lc)
     register char *send;
     STRLEN len;
 
-    if (SvSTORAGE(sv) != 'T') {
+    if (!SvPADTMP(sv)) {
        dTARGET;
        sv_setsv(TARG, sv);
        sv = TARG;
@@ -2884,8 +2913,8 @@ PP(pp_rv2av)
 
     AV *av;
 
-    if (SvTYPE(sv) == SVt_REF) {
-       av = (AV*)SvANY(sv);
+    if (SvROK(sv)) {
+       av = (AV*)SvRV(sv);
        if (SvTYPE(av) != SVt_PVAV)
            DIE("Not an array reference");
        if (op->op_flags & OPf_LVAL) {
@@ -2959,14 +2988,16 @@ PP(pp_aelem)
            if (op->op_private == OP_RV2HV) {
                sv_free(*svp);
                *svp = NEWSV(0,0);
-               sv_upgrade(*svp, SVt_REF);
-               SvANY(*svp) = (void*)sv_ref((SV*)newHV());
+               sv_upgrade(*svp, SVt_RV);
+               SvRV(*svp) = sv_ref((SV*)newHV());
+               SvROK_on(*svp);
            }
            else if (op->op_private == OP_RV2AV) {
                sv_free(*svp);
                *svp = NEWSV(0,0);
-               sv_upgrade(*svp, SVt_REF);
-               SvANY(*svp) = (void*)sv_ref((SV*)newAV());
+               sv_upgrade(*svp, SVt_RV);
+               SvRV(*svp) = sv_ref((SV*)newAV());
+               SvROK_on(*svp);
            }
        }
     }
@@ -3075,8 +3106,8 @@ PP(pp_rv2hv)
 
     HV *hv;
 
-    if (SvTYPE(sv) == SVt_REF) {
-       hv = (HV*)SvANY(sv);
+    if (SvTYPE(sv) == SVt_RV) {
+       hv = (HV*)SvRV(sv);
        if (SvTYPE(hv) != SVt_PVHV)
            DIE("Not an associative array reference");
        if (op->op_flags & OPf_LVAL) {
@@ -3146,14 +3177,16 @@ PP(pp_helem)
            if (op->op_private == OP_RV2HV) {
                sv_free(*svp);
                *svp = NEWSV(0,0);
-               sv_upgrade(*svp, SVt_REF);
-               SvANY(*svp) = (void*)sv_ref((SV*)newHV());
+               sv_upgrade(*svp, SVt_RV);
+               SvRV(*svp) = sv_ref((SV*)newHV());
+               SvROK_on(*svp);
            }
            else if (op->op_private == OP_RV2AV) {
                sv_free(*svp);
                *svp = NEWSV(0,0);
-               sv_upgrade(*svp, SVt_REF);
-               SvANY(*svp) = (void*)sv_ref((SV*)newAV());
+               sv_upgrade(*svp, SVt_RV);
+               SvRV(*svp) = sv_ref((SV*)newAV());
+               SvROK_on(*svp);
            }
        }
     }
@@ -4431,6 +4464,8 @@ PP(pp_list)
            *MARK = &sv_undef;
        SP = MARK;
     }
+    else if (op->op_private & OPpLIST_GUESSED) /* didn't need that pushmark */
+       markstack_ptr--;
     RETURN;
 }
 
@@ -4465,7 +4500,14 @@ PP(pp_lslice)
 
     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
        ix = SvIVx(*lelem) - arybase;
-       if (ix < 0 || ix >= max || !(*lelem = firstrelem[ix]))
+       if (ix < 0) {
+           ix += max;
+           if (ix < 0)
+               *lelem = &sv_undef;
+           else if (!(*lelem = firstrelem[ix]))
+               *lelem = &sv_undef;
+       }
+       else if (ix >= max || !(*lelem = firstrelem[ix]))
            *lelem = &sv_undef;
        if (!is_something_there && SvOK(*lelem))
            is_something_there = TRUE;
@@ -4501,6 +4543,7 @@ PP(pp_anonhash)
        (void)hv_store(hv,tmps,SvCUROK(key),val,0);
     }
     SP = ORIGMARK;
+    SvOK_on(hv);
     XPUSHs((SV*)hv);
     RETURN;
 }
@@ -5331,7 +5374,9 @@ PP(pp_method)
     EXTEND(sp,2);
 
     gv = 0;
-    if (SvTYPE(sv) != SVt_REF) {
+    if (SvROK(sv))
+       ob = SvRV(sv);
+    else {
        GV* iogv;
        IO* io;
 
@@ -5358,19 +5403,15 @@ DIE("Can't call method \"%s\" without a package or object reference", name);
        }
        if (!(ob = io->object)) {
            ob = sv_ref((SV*)newHV());
-           SvSTORAGE(ob) = 'O';
+           SvOBJECT_on(ob);
            SvUPGRADE(ob, SVt_PVMG);
            iogv = gv_fetchpv("FILEHANDLE'flush", TRUE);
            SvSTASH(ob) = GvSTASH(iogv);
            io->object = ob;
        }
     }
-    else {
-       gv = 0;
-       ob = (SV*)SvANY(sv);
-    }
 
-    if (!ob || SvSTORAGE(ob) != 'O') {
+    if (!ob || !SvOBJECT(ob)) {
        char *name = SvPVX(((SVOP*)cLOGOP->op_other)->op_sv);
        DIE("Can't call method \"%s\" on unblessed reference", name);
     }
@@ -5814,6 +5855,7 @@ PP(pp_iter)
        RETPUSHNO;
 
     sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
+    SvTEMP_off(sv);
     *cx->blk_loop.itervar = sv ? sv : &sv_undef;
 
     RETPUSHYES;
@@ -6939,8 +6981,12 @@ PP(pp_sysread)
     bufstr = *++MARK;
     buffer = SvPV(bufstr, blen);
     length = SvIVx(*++MARK);
-    if (SvREADONLY(bufstr))
-       DIE(no_modify);
+    if (SvTHINKFIRST(bufstr)) {
+       if (SvREADONLY(bufstr))
+           DIE(no_modify);
+       if (SvROK(bufstr))
+           sv_unref(bufstr);
+    }
     errno = 0;
     if (MARK < SP)
        offset = SvIVx(*++MARK);
@@ -7217,7 +7263,8 @@ PP(pp_ioctl)
 
     if (SvPOK(argstr)) {
        if (s[SvCUR(argstr)] != 17)
-           DIE("Return value overflowed string");
+           DIE("Possible memory corruption: %s overflowed 3rd argument",
+               op_name[optype]);
        s[SvCUR(argstr)] = 0;           /* put our null back */
     }
 
@@ -9153,12 +9200,19 @@ PP(pp_require)
 {
     dSP;
     register CONTEXT *cx;
-    dPOPss;
-    char *name = SvPV(sv, na);
+    SV *sv;
+    char *name;
     char *tmpname;
     SV** svp;
     I32 gimme = G_SCALAR;
 
+    if (MAXARG < 1) {
+       sv = GvSV(defgv);
+       EXTEND(SP, 1);
+    }
+    else
+       sv = POPs;
+    name = SvPV(sv, na);
     if (op->op_type == OP_REQUIRE &&
       (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
       *svp != &sv_undef)
diff --git a/proto.h b/proto.h
index 0aeb908..9407cca 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -243,7 +243,7 @@ OP* op_fold_const P((OP* arg));
 void   op_free P((OP* arg));
 void   op_optimize P((OP* cmd, I32 fliporflop, I32 acmd));
 OP*    over P((GV* eachgv, OP* cmd));
-PADOFFSET      pad_alloc P((I32 optype, char tmptype));
+PADOFFSET      pad_alloc P((I32 optype, U32 tmptype));
 PADOFFSET      pad_allocmy P((char* name));
 PADOFFSET      pad_findmy P((char* name));
 OP*    oopsAV P((OP* o));
@@ -366,6 +366,7 @@ void        sv_setpv P((SV* sv, char* ptr));
 void   sv_setpvn P((SV* sv, char* ptr, STRLEN len));
 void   sv_setsv P((SV* dsv, SV* ssv));
 int    sv_unmagic P((SV* sv, char type));
+void   sv_unref P((SV* sv));
 void   sv_usepvn P((SV* sv, char* ptr, STRLEN len));
 void   taint_env P((void));
 void   taint_not P((char *s));
diff --git a/save_ary.bad b/save_ary.bad
deleted file mode 100644 (file)
index 807e339..0000000
+++ /dev/null
@@ -1,44 +0,0 @@
-AV *
-save_ary(av)
-AV *av;
-{
-    register SV *sv;
-
-    sv = NEWSV(10,0);
-    sv->sv_state = SVs_SARY;
-    sv_setpv(sv, (char*)av, sizeof(AV));
-
-    av->av_sv.sv_rare = AVf_REAL;
-    av->av_magic = NEWSV(7,0);
-    av->av_alloc = av->av_array = 0;
-    /* sv_magic(av->av_magic, gv, '#', Nullch, 0); */
-    av->av_max = av->av_fill = -1;
-
-    sv->sv_u.sv_av = av;
-    (void)av_push(savestack,sv); /* save array ptr */
-    return av;
-}
-
-HV *
-save_hash(hv)
-HV *hv;
-{
-    register SV *sv;
-
-    sv = NEWSV(11,0);
-    sv->sv_state = SVs_SHASH;
-    sv_setpv(sv, (char*)hv, sizeof(HV));
-
-    hv->hv_array = 0;
-    hv->hv_max = 7;
-    hv->hv_dosplit = hv->hv_max * FILLPCT / 100;
-    hv->hv_fill = 0;
-#ifdef SOME_DBM
-    hv->hv_dbm = 0;
-#endif
-    (void)hv_iterinit(hv);      /* so each() will start off right */
-
-    sv->sv_u.sv_hv = hv;
-    (void)av_push(savestack,sv); /* save hash ptr */
-    return hv;
-}
diff --git a/sv.c b/sv.c
index 0e7ca25..fd51712 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -177,6 +177,47 @@ more_xnv()
     return new_xnv();
 }
 
+static XRV* xrv_root;
+
+static XRV* more_xrv();
+
+static XRV*
+new_xrv()
+{
+    XRV* xrv;
+    if (xrv_root) {
+       xrv = xrv_root;
+       xrv_root = (XRV*)xrv->xrv_rv;
+       return xrv;
+    }
+    return more_xrv();
+}
+
+static void
+del_xrv(p)
+XRV* p;
+{
+    p->xrv_rv = (SV*)xrv_root;
+    xrv_root = p;
+}
+
+static XRV*
+more_xrv()
+{
+    register int i;
+    register XRV* xrv;
+    register XRV* xrvend;
+    xrv_root = (XRV*)malloc(1008);
+    xrv = xrv_root;
+    xrvend = &xrv[1008 / sizeof(XRV) - 1];
+    while (xrv < xrvend) {
+       xrv->xrv_rv = (SV*)(xrv + 1);
+       xrv++;
+    }
+    xrv->xrv_rv = 0;
+    return new_xrv();
+}
+
 static XPV* xpv_root;
 
 static XPV* more_xpv();
@@ -253,6 +294,14 @@ more_xpv()
 #endif
 
 #ifdef PURIFY
+#define new_XRV() (void*)malloc(sizeof(XRV))
+#define del_XRV(p) free((char*)p)
+#else
+#define new_XRV() new_xrv()
+#define del_XRV(p) del_xrv(p)
+#endif
+
+#ifdef PURIFY
 #define new_XPV() (void*)malloc(sizeof(XPV))
 #define del_XPV(p) free((char*)p)
 #else
@@ -316,19 +365,6 @@ U32 mt;
        magic   = 0;
        stash   = 0;
        break;
-    case SVt_REF:
-       sv_free((SV*)SvANY(sv));
-       pv      = 0;
-       cur     = 0;
-       len     = 0;
-       iv      = (I32)SvANY(sv);
-       nv      = (double)(unsigned long)SvANY(sv);
-       SvNOK_only(sv);
-       magic   = 0;
-       stash   = 0;
-       if (mt == SVt_PV)
-           mt = SVt_PVIV;
-       break;
     case SVt_IV:
        pv      = 0;
        cur     = 0;
@@ -338,24 +374,34 @@ U32 mt;
        del_XIV(SvANY(sv));
        magic   = 0;
        stash   = 0;
-       if (mt == SVt_PV)
-           mt = SVt_PVIV;
-       else if (mt == SVt_NV)
+       if (mt == SVt_NV)
            mt = SVt_PVNV;
+       else if (mt < SVt_PVIV)
+           mt = SVt_PVIV;
        break;
     case SVt_NV:
        pv      = 0;
        cur     = 0;
        len     = 0;
        nv      = SvNVX(sv);
-       iv      = (I32)nv;
+       iv      = I_32(nv);
        magic   = 0;
        stash   = 0;
        del_XNV(SvANY(sv));
        SvANY(sv) = 0;
-       if (mt == SVt_PV || mt == SVt_PVIV)
+       if (mt < SVt_PVNV)
            mt = SVt_PVNV;
        break;
+    case SVt_RV:
+       pv      = (char*)SvRV(sv);
+       cur     = 0;
+       len     = 0;
+       iv      = (I32)pv;
+       nv      = (double)(unsigned long)pv;
+       del_XRV(SvANY(sv));
+       magic   = 0;
+       stash   = 0;
+       break;
     case SVt_PV:
        nv = 0.0;
        pv      = SvPVX(sv);
@@ -406,9 +452,6 @@ U32 mt;
     switch (mt) {
     case SVt_NULL:
        croak("Can't upgrade to undef");
-    case SVt_REF:
-       SvOK_on(sv);
-       break;
     case SVt_IV:
        SvANY(sv) = new_XIV();
        SvIVX(sv)       = iv;
@@ -417,6 +460,11 @@ U32 mt;
        SvANY(sv) = new_XNV();
        SvNVX(sv)       = nv;
        break;
+    case SVt_RV:
+       SvANY(sv) = new_XRV();
+       SvRV(sv) = (SV*)pv;
+       SvOK_on(sv);
+       break;
     case SVt_PV:
        SvANY(sv) = new_XPV();
        SvPVX(sv)       = pv;
@@ -588,20 +636,20 @@ register SV *sv;
        case SVt_NULL:
            strcpy(t,"UNDEF");
            return tokenbuf;
-       case SVt_REF:
-           *t++ = '\\';
-           if (t - tokenbuf > 10) {
-               strcpy(tokenbuf + 3,"...");
-               return tokenbuf;
-           }
-           sv = (SV*)SvANY(sv);
-           goto retry;
        case SVt_IV:
            strcpy(t,"IV");
            break;
        case SVt_NV:
            strcpy(t,"NV");
            break;
+       case SVt_RV:
+           *t++ = '\\';
+           if (t - tokenbuf > 10) {
+               strcpy(tokenbuf + 3,"...");
+               return tokenbuf;
+           }
+           sv = (SV*)SvRV(sv);
+           goto retry;
        case SVt_PV:
            strcpy(t,"PV");
            break;
@@ -688,8 +736,12 @@ unsigned long newlen;
        my_exit(1);
     }
 #endif /* MSDOS */
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvTYPE(sv) < SVt_PV) {
        sv_upgrade(sv, SVt_PV);
        s = SvPVX(sv);
@@ -718,16 +770,20 @@ sv_setiv(sv,i)
 register SV *sv;
 I32 i;
 {
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     switch (SvTYPE(sv)) {
     case SVt_NULL:
-    case SVt_REF:
        sv_upgrade(sv, SVt_IV);
        break;
     case SVt_NV:
        sv_upgrade(sv, SVt_PVNV);
        break;
+    case SVt_RV:
     case SVt_PV:
        sv_upgrade(sv, SVt_PVIV);
        break;
@@ -742,8 +798,12 @@ sv_setnv(sv,num)
 register SV *sv;
 double num;
 {
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvTYPE(sv) < SVt_NV)
        sv_upgrade(sv, SVt_NV);
     else if (SvTYPE(sv) < SVt_PVNV)
@@ -772,18 +832,20 @@ register SV *sv;
            return (I32)atol(SvPVX(sv));
        return 0;
     }
-    if (SvREADONLY(sv)) {
-       if (SvNOK(sv))
-           return (I32)SvNVX(sv);
-       if (SvPOK(sv) && SvLEN(sv))
-           return (I32)atol(SvPVX(sv));
-       if (dowarn)
-           warn("Use of uninitialized variable");
-       return 0;
+    if (SvTHINKFIRST(sv)) {
+       if (SvROK(sv))
+           return (I32)SvRV(sv);
+       if (SvREADONLY(sv)) {
+           if (SvNOK(sv))
+               return (I32)SvNVX(sv);
+           if (SvPOK(sv) && SvLEN(sv))
+               return (I32)atol(SvPVX(sv));
+           if (dowarn)
+               warn("Use of uninitialized variable");
+           return 0;
+       }
     }
     switch (SvTYPE(sv)) {
-    case SVt_REF:
-       return (I32)SvANY(sv);
     case SVt_NULL:
        sv_upgrade(sv, SVt_IV);
        return SvIVX(sv);
@@ -832,16 +894,18 @@ register SV *sv;
            return (double)SvIVX(sv);
        return 0;
     }
-    if (SvREADONLY(sv)) {
-       if (SvPOK(sv) && SvLEN(sv))
-           return atof(SvPVX(sv));
-       if (dowarn)
-           warn("Use of uninitialized variable");
-       return 0.0;
+    if (SvTHINKFIRST(sv)) {
+       if (SvROK(sv))
+           return (double)(unsigned long)SvRV(sv);
+       if (SvREADONLY(sv)) {
+           if (SvPOK(sv) && SvLEN(sv))
+               return atof(SvPVX(sv));
+           if (dowarn)
+               warn("Use of uninitialized variable");
+           return 0.0;
+       }
     }
     if (SvTYPE(sv) < SVt_NV) {
-       if (SvTYPE(sv) == SVt_REF)
-           return (double)(unsigned long)SvANY(sv);
        if (SvTYPE(sv) == SVt_IV)
            sv_upgrade(sv, SVt_PVNV);
        else
@@ -906,54 +970,56 @@ STRLEN *lp;
        *lp = 0;
        return "";
     }
-    if (SvTYPE(sv) == SVt_REF) {
-       sv = (SV*)SvANY(sv);
-       if (!sv)
-           s = "NULLREF";
-       else {
-           switch (SvTYPE(sv)) {
-           case SVt_NULL:
-           case SVt_REF:
-           case SVt_IV:
-           case SVt_NV:
-           case SVt_PV:
-           case SVt_PVIV:
-           case SVt_PVNV:
-           case SVt_PVMG:      s = "SCALAR";                   break;
-           case SVt_PVLV:      s = "LVALUE";                   break;
-           case SVt_PVAV:      s = "ARRAY";                    break;
-           case SVt_PVHV:      s = "HASH";                     break;
-           case SVt_PVCV:      s = "CODE";                     break;
-           case SVt_PVGV:      s = "GLOB";                     break;
-           case SVt_PVBM:      s = "SEARCHSTRING";                     break;
-           case SVt_PVFM:      s = "FORMATLINE";                       break;
-           default:            s = "UNKNOWN";                  break;
+    if (SvTHINKFIRST(sv)) {
+       if (SvROK(sv)) {
+           sv = (SV*)SvRV(sv);
+           if (!sv)
+               s = "NULLREF";
+           else {
+               switch (SvTYPE(sv)) {
+               case SVt_NULL:
+               case SVt_IV:
+               case SVt_NV:
+               case SVt_RV:
+               case SVt_PV:
+               case SVt_PVIV:
+               case SVt_PVNV:
+               case SVt_PVBM:
+               case SVt_PVMG:  s = "SCALAR";                   break;
+               case SVt_PVLV:  s = "LVALUE";                   break;
+               case SVt_PVAV:  s = "ARRAY";                    break;
+               case SVt_PVHV:  s = "HASH";                     break;
+               case SVt_PVCV:  s = "CODE";                     break;
+               case SVt_PVGV:  s = "GLOB";                     break;
+               case SVt_PVFM:  s = "FORMATLINE";               break;
+               default:        s = "UNKNOWN";                  break;
+               }
+               if (SvOBJECT(sv))
+                   sprintf(tokenbuf, "%s=%s(0x%lx)",
+                               HvNAME(SvSTASH(sv)), s, (unsigned long)sv);
+               else
+                   sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv);
+               s = tokenbuf;
            }
-           if (SvSTORAGE(sv) == 'O')
-               sprintf(tokenbuf, "%s=%s(0x%lx)",
-                           HvNAME(SvSTASH(sv)), s, (unsigned long)sv);
-           else
-               sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv);
-           s = tokenbuf;
-       }
-       *lp = strlen(s);
-       return s;
-    }
-    if (SvREADONLY(sv)) {
-       if (SvIOK(sv)) {
-           (void)sprintf(tokenbuf,"%ld",SvIVX(sv));
-           *lp = strlen(tokenbuf);
-           return tokenbuf;
+           *lp = strlen(s);
+           return s;
        }
-       if (SvNOK(sv)) {
-           (void)sprintf(tokenbuf,"%.20g",SvNVX(sv));
-           *lp = strlen(tokenbuf);
-           return tokenbuf;
+       if (SvREADONLY(sv)) {
+           if (SvIOK(sv)) {
+               (void)sprintf(tokenbuf,"%ld",SvIVX(sv));
+               *lp = strlen(tokenbuf);
+               return tokenbuf;
+           }
+           if (SvNOK(sv)) {
+               (void)sprintf(tokenbuf,"%.20g",SvNVX(sv));
+               *lp = strlen(tokenbuf);
+               return tokenbuf;
+           }
+           if (dowarn)
+               warn("Use of uninitialized variable");
+           *lp = 0;
+           return "";
        }
-       if (dowarn)
-           warn("Use of uninitialized variable");
-       *lp = 0;
-       return "";
     }
     if (!SvUPGRADE(sv, SVt_PV))
        return 0;
@@ -1012,8 +1078,8 @@ register SV *sv;
     if (SvMAGICAL(sv))
        mg_get(sv);
 
-    if (SvTYPE(sv) == SVt_REF)
-       return SvANY(sv) != 0;
+    if (SvROK(sv))
+       return SvRV(sv) != 0;
     if (SvPOKp(sv)) {
        register XPV* Xpv;
        if ((Xpv = (XPV*)SvANY(sv)) &&
@@ -1050,8 +1116,12 @@ register SV *sstr;
 
     if (sstr == dstr)
        return;
-    if (SvREADONLY(dstr))
-       croak(no_modify);
+    if (SvTHINKFIRST(dstr)) {
+       if (SvREADONLY(dstr))
+           croak(no_modify);
+       if (SvROK(dstr))
+           sv_unref(dstr);
+    }
     if (!sstr)
        sstr = &sv_undef;
 
@@ -1059,34 +1129,7 @@ register SV *sstr;
 
     switch (SvTYPE(sstr)) {
     case SVt_NULL:
-       if (SvTYPE(dstr) == SVt_REF) {
-           sv_free((SV*)SvANY(dstr));
-           SvANY(dstr) = 0;
-           SvTYPE(dstr) = SVt_NULL;
-       }
-       else
-           SvOK_off(dstr);
-       return;
-    case SVt_REF:
-       if (SvTYPE(dstr) < SVt_REF)
-           sv_upgrade(dstr, SVt_REF);
-       if (SvTYPE(dstr) == SVt_REF) {
-           sv_free((SV*)SvANY(dstr));
-           SvANY(dstr) = 0;
-           SvANY(dstr) = (void*)sv_ref((SV*)SvANY(sstr));
-       }
-       else {
-           if (SvMAGICAL(dstr))
-               croak("Can't assign a reference to a magical variable");
-           if (SvREFCNT(dstr) != 1)
-               warn("Reference miscount in sv_setsv()");
-           SvREFCNT(dstr) = 0;
-           sv_clear(dstr);
-           SvTYPE(dstr) = SVt_REF;
-           SvANY(dstr) = (void*)sv_ref((SV*)SvANY(sstr));
-           SvOK_off(dstr);
-       }
-       SvTAINT(sstr);
+       SvOK_off(dstr);
        return;
     case SVt_IV:
        if (SvTYPE(dstr) < SVt_IV)
@@ -1106,6 +1149,11 @@ register SV *sstr;
            sv_upgrade(dstr, SVt_PVNV);
        flags = SvFLAGS(sstr);
        break;
+    case SVt_RV:
+       if (SvTYPE(dstr) < SVt_RV)
+           sv_upgrade(dstr, SVt_RV);
+       flags = SvFLAGS(sstr);
+       break;
     case SVt_PV:
        if (SvTYPE(dstr) < SVt_PV)
            sv_upgrade(dstr, SVt_PV);
@@ -1151,10 +1199,24 @@ register SV *sstr;
            flags = SvFLAGS(sstr);
     }
 
-
     SvPRIVATE(dstr)    = SvPRIVATE(sstr) & ~(SVf_IOK|SVf_POK|SVf_NOK);
 
-    if (flags & SVf_POK) {
+    if (SvROK(sstr)) {
+       SvOK_off(dstr);
+       if (SvTYPE(dstr) >= SVt_PV && SvPVX(dstr))
+           Safefree(SvPVX(dstr));
+       SvRV(dstr) = sv_ref(SvRV(sstr));
+       SvROK_on(dstr);
+       if (flags & SVf_NOK) {
+           SvNOK_on(dstr);
+           SvNVX(dstr) = SvNVX(sstr);
+       }
+       if (flags & SVf_IOK) {
+           SvIOK_on(dstr);
+           SvIVX(dstr) = SvIVX(sstr);
+       }
+    }
+    else if (flags & SVf_POK) {
 
        /*
         * Check to see if we can just swipe the string.  If so, it's a
@@ -1218,8 +1280,12 @@ register SV *sv;
 register char *ptr;
 register STRLEN len;
 {
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (!ptr) {
        SvOK_off(sv);
        return;
@@ -1242,8 +1308,12 @@ register char *ptr;
 {
     register STRLEN len;
 
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (!ptr) {
        SvOK_off(sv);
        return;
@@ -1264,8 +1334,12 @@ register SV *sv;
 register char *ptr;
 register STRLEN len;
 {
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (!SvUPGRADE(sv, SVt_PV))
        return;
     if (!ptr) {
@@ -1292,8 +1366,12 @@ register char *ptr;
 
     if (!ptr || !SvPOK(sv))
        return;
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvTYPE(sv) < SVt_PVIV)
        sv_upgrade(sv,SVt_PVIV);
 
@@ -1317,8 +1395,12 @@ register STRLEN len;
 {
     STRLEN tlen;
     char *s;
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     s = SvPV(sv, tlen);
     SvGROW(sv, tlen + len + 1);
     Move(ptr,SvPVX(sv)+tlen,len,char);
@@ -1350,8 +1432,12 @@ register char *ptr;
     STRLEN tlen;
     char *s;
 
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (!ptr)
        return;
     s = SvPV(sv, tlen);
@@ -1394,8 +1480,10 @@ I32 namlen;
 {
     MAGIC* mg;
     
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+    }
     if (SvMAGICAL(sv)) {
        if (SvMAGIC(sv) && mg_find(sv, how))
            return;
@@ -1528,8 +1616,12 @@ STRLEN littlelen;
     register char *bigend;
     register I32 i;
 
-    if (SvREADONLY(bigstr))
-       croak(no_modify);
+    if (SvTHINKFIRST(bigstr)) {
+       if (SvREADONLY(bigstr))
+           croak(no_modify);
+       if (SvROK(bigstr))
+           sv_unref(bigstr);
+    }
     SvPOK_only(bigstr);
 
     i = littlelen - len;
@@ -1606,8 +1698,12 @@ register SV *sv;
 register SV *nsv;
 {
     U32 refcnt = SvREFCNT(sv);
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvREFCNT(nsv) != 1)
        warn("Reference miscount in sv_replace()");
     if (SvMAGICAL(sv)) {
@@ -1631,12 +1727,12 @@ register SV *sv;
     assert(sv);
     assert(SvREFCNT(sv) == 0);
 
-    if (SvSTORAGE(sv) == 'O') {
+    if (SvOBJECT(sv)) {
        dSP;
        BINOP myop;             /* fake syntax tree node */
        GV* destructor;
 
-       SvSTORAGE(sv) = 0;              /* Curse the object. */
+       SvOBJECT_off(sv);               /* Curse the object. */
 
        ENTER;
        SAVETMPS;
@@ -1648,8 +1744,9 @@ register SV *sv;
 
        if (destructor && GvCV(destructor)) {
            SV* ref = sv_mortalcopy(&sv_undef);
-           sv_upgrade(ref, SVt_REF);
-           SvANY(ref) = (void*)sv_ref(sv);
+           sv_upgrade(ref, SVt_RV);
+           SvRV(ref) = sv_ref(sv);
+           SvROK_on(ref);
 
            op = (OP*)&myop;
            Zero(op, 1, OP);
@@ -1707,8 +1804,8 @@ register SV *sv;
        break;
     case SVt_IV:
        break;
-    case SVt_REF:
-       sv_free((SV*)SvANY(sv));
+    case SVt_RV:
+       sv_free(SvRV(sv));
        break;
     case SVt_NULL:
        break;
@@ -1717,14 +1814,15 @@ register SV *sv;
     switch (SvTYPE(sv)) {
     case SVt_NULL:
        break;
-    case SVt_REF:
-       break;
     case SVt_IV:
        del_XIV(SvANY(sv));
        break;
     case SVt_NV:
        del_XNV(SvANY(sv));
        break;
+    case SVt_RV:
+       del_XRV(SvANY(sv));
+       break;
     case SVt_PV:
        del_XPV(SvANY(sv));
        break;
@@ -1777,9 +1875,11 @@ SV *sv;
 {
     if (!sv)
        return;
-    if (SvREADONLY(sv)) {
-       if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
-           return;
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv)) {
+           if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
+               return;
+       }
     }
     if (SvREFCNT(sv) == 0) {
        warn("Attempt to free unreferenced scalar");
@@ -1900,8 +2000,12 @@ I32 append;
     STRLEN bpx;
     I32 shortbuffered;
 
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (!SvUPGRADE(sv, SVt_PV))
        return;
     if (rspara) {              /* have to do this both before and after */
@@ -2036,8 +2140,12 @@ register SV *sv;
 
     if (!sv)
        return;
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvMAGICAL(sv)) {
        mg_get(sv);
        flags = SvPRIVATE(sv);
@@ -2101,8 +2209,12 @@ register SV *sv;
 
     if (!sv)
        return;
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (SvMAGICAL(sv)) {
        mg_get(sv);
        flags = SvPRIVATE(sv);
@@ -2167,8 +2279,12 @@ register SV *sv;
 {
     if (!sv)
        return sv;
-    if (SvREADONLY(sv))
-       croak(no_modify);
+    if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       if (SvROK(sv))
+           sv_unref(sv);
+    }
     if (++tmps_ix > tmps_max) {
        tmps_max = tmps_ix;
        if (!(tmps_max & 127)) {
@@ -2329,8 +2445,9 @@ I32 lref;
     if (!sv)
        return *gvp = Nullgv, Nullcv;
     switch (SvTYPE(sv)) {
-    case SVt_REF:
-       cv = (CV*)SvANY(sv);
+    case SVt_RV:
+      is_rv:
+       cv = (CV*)SvRV(sv);
        if (SvTYPE(cv) != SVt_PVCV)
            croak("Not a subroutine reference");
        *gvp = Nullgv;
@@ -2345,6 +2462,8 @@ I32 lref;
        *gvp = Nullgv;
        return Nullcv;
     default:
+       if (SvROK(sv))
+           goto is_rv;
        if (isGV(sv))
            gv = (GV*)sv;
        else
@@ -2416,10 +2535,10 @@ sv_isa(sv, name)
 SV *sv;
 char *name;
 {
-    if (SvTYPE(sv) != SVt_REF)
+    if (!SvROK(sv))
        return 0;
-    sv = (SV*)SvANY(sv);
-    if (SvSTORAGE(sv) != 'O')
+    sv = (SV*)SvRV(sv);
+    if (!SvOBJECT(sv))
        return 0;
 
     return strEQ(HvNAME(SvSTASH(sv)), name);
@@ -2441,14 +2560,25 @@ char *name;
     Zero(sv, 1, SV);
     SvREFCNT(sv)++;
     sv_setnv(sv, (double)(unsigned long)ptr);
-    sv_upgrade(rv, SVt_REF);
-    SvANY(rv) = (void*)sv_ref(sv);
+    sv_upgrade(rv, SVt_RV);
+    SvRV(rv) = sv_ref(sv);
+    SvROK_on(rv);
 
     stash = fetch_stash(newSVpv(name,0), TRUE);
-    SvSTORAGE(sv) = 'O';
+    SvOBJECT_on(sv);
     SvUPGRADE(sv, SVt_PVMG);
     SvSTASH(sv) = stash;
 
     return rv;
 }
 
+void
+sv_unref(sv)
+SV* sv;
+{
+    sv_free(SvRV(sv));
+    SvRV(sv) = 0;
+    SvROK_off(sv);
+    if (!SvREADONLY(sv))
+       SvTHINKFIRST_off(sv);
+}
diff --git a/sv.h b/sv.h
index 132a908..5ebb337 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -29,9 +29,9 @@
 
 typedef enum {
        SVt_NULL,
-       SVt_REF,
        SVt_IV,
        SVt_NV,
+       SVt_RV,
        SVt_PV,
        SVt_PVIV,
        SVt_PVNV,
@@ -112,10 +112,19 @@ struct hv {
 #define SVf_NOK                2               /* has valid numeric value */
 #define SVf_POK                4               /* has valid pointer value */
 #define SVf_OOK                8               /* has valid offset value */
-#define SVf_MAGICAL    16              /* has special methods */
+#define SVf_ROK                16              /* has a valid reference pointer */
 #define SVf_OK         32              /* has defined value */
-#define SVf_TEMP       64              /* eventually in sv_private? */
-#define SVf_READONLY   128             /* may not be modified */
+#define SVf_MAGICAL    64              /* has special methods */
+#define SVf_THINKFIRST 128             /* may not be changed without thought */
+
+#define SVs_PADBUSY    1               /* reserved for tmp or my already */
+#define SVs_PADTMP     2               /* in use as tmp */
+#define SVs_PADMY      4               /* in use a "my" variable */
+#define SVs_8          8
+#define SVs_16         16
+#define SVs_TEMP       32              /* string is stealable? */
+#define SVs_OBJECT     64              /* is "blessed" */
+#define SVs_READONLY   128             /* may not be modified */
 
 #define SVp_IOK                1               /* has valid non-public integer value */
 #define SVp_NOK                2               /* has valid non-public numeric value */
@@ -131,43 +140,47 @@ struct hv {
 
 #define SVpgv_MULTI    128
 
+struct xrv {
+    SV *       xrv_rv;         /* pointer to another SV */
+};
+
 struct xpv {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
 };
 
 struct xpviv {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
 };
 
 struct xpvnv {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
 };
 
 struct xpvmg {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
 };
 
 struct xpvlv {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
     STRLEN     xlv_targoff;
@@ -177,11 +190,11 @@ struct xpvlv {
 };
 
 struct xpvgv {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
     GP*                xgv_gp;
@@ -191,11 +204,11 @@ struct xpvgv {
 };
 
 struct xpvbm {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
     I32                xbm_useful;     /* is this constant pattern being useful? */
@@ -204,11 +217,11 @@ struct xpvbm {
 };
 
 struct xpvfm {
-    char *      xpv_pv;                /* pointer to malloced string */
-    STRLEN      xpv_cur;       /* length of xpv_pv as a C string */
-    STRLEN      xpv_len;       /* allocated size */
+    char *     xpv_pv;         /* pointer to malloced string */
+    STRLEN     xpv_cur;        /* length of xpv_pv as a C string */
+    STRLEN     xpv_len;        /* allocated size */
     I32                xiv_iv;         /* integer value or pv offset */
-    double      xnv_nv;                /* numeric value, if any */
+    double     xnv_nv;         /* numeric value, if any */
     MAGIC*     xmg_magic;      /* linked list of magicalness */
     HV*                xmg_stash;      /* class package */
     HV *       xcv_stash;
@@ -223,6 +236,8 @@ struct xpvfm {
     I32                xfm_lines;
 };
 
+/* The following macros define implementation-independent predicates on SVs. */
+
 #define SvNIOK(sv)             (SvFLAGS(sv) & (SVf_IOK|SVf_NOK))
 
 #define SvOK(sv)               (SvFLAGS(sv) & SVf_OK)
@@ -258,22 +273,44 @@ struct xpvfm {
 #define SvOOK_on(sv)           (SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
 #define SvOOK_off(sv)          (SvOOK(sv) && sv_backoff(sv))
 
-#define SvREADONLY(sv)         (SvFLAGS(sv) & SVf_READONLY)
-#define SvREADONLY_on(sv)      (SvFLAGS(sv) |= SVf_READONLY)
-#define SvREADONLY_off(sv)     (SvFLAGS(sv) &= ~SVf_READONLY)
+#define SvROK(sv)              (SvFLAGS(sv) & SVf_ROK)
+#define SvROK_on(sv)           (SvFLAGS(sv) |= SVf_ROK|SVf_THINKFIRST|SVf_OK)
+#define SvROK_off(sv)          (SvFLAGS(sv) &= ~SVf_ROK)
 
 #define SvMAGICAL(sv)          (SvFLAGS(sv) & SVf_MAGICAL)
 #define SvMAGICAL_on(sv)       (SvFLAGS(sv) |= SVf_MAGICAL)
 #define SvMAGICAL_off(sv)      (SvFLAGS(sv) &= ~SVf_MAGICAL)
 
+#define SvTHINKFIRST(sv)       (SvFLAGS(sv) & SVf_THINKFIRST)
+#define SvTHINKFIRST_on(sv)    (SvFLAGS(sv) |= SVf_THINKFIRST)
+#define SvTHINKFIRST_off(sv)   (SvFLAGS(sv) &= ~SVf_THINKFIRST)
+
+#define SvPADBUSY(sv)          (SvSTORAGE(sv) & SVs_PADBUSY)
+
+#define SvPADTMP(sv)           (SvSTORAGE(sv) & SVs_PADTMP)
+#define SvPADTMP_on(sv)                (SvSTORAGE(sv) |= SVs_PADTMP|SVs_PADBUSY)
+#define SvPADTMP_off(sv)       (SvSTORAGE(sv) &= ~SVs_PADTMP)
+
+#define SvPADMY(sv)            (SvSTORAGE(sv) & SVs_PADMY)
+#define SvPADMY_on(sv)         (SvSTORAGE(sv) |= SVs_PADMY|SVs_PADBUSY)
+
+#define SvTEMP(sv)             (SvSTORAGE(sv) & SVs_TEMP)
+#define SvTEMP_on(sv)          (SvSTORAGE(sv) |= SVs_TEMP)
+#define SvTEMP_off(sv)         (SvSTORAGE(sv) &= ~SVs_TEMP)
+
+#define SvOBJECT(sv)           (SvSTORAGE(sv) & SVs_OBJECT)
+#define SvOBJECT_on(sv)                (SvSTORAGE(sv) |= SVs_OBJECT)
+#define SvOBJECT_off(sv)       (SvSTORAGE(sv) &= ~SVs_OBJECT)
+
+#define SvREADONLY(sv)         (SvSTORAGE(sv) & SVs_READONLY)
+#define SvREADONLY_on(sv)      (SvSTORAGE(sv) |= SVs_READONLY, \
+                                       SvTHINKFIRST_on(sv))
+#define SvREADONLY_off(sv)     (SvSTORAGE(sv) &= ~SVs_READONLY)
+
 #define SvSCREAM(sv)           (SvPRIVATE(sv) & SVp_SCREAM)
 #define SvSCREAM_on(sv)                (SvPRIVATE(sv) |= SVp_SCREAM)
 #define SvSCREAM_off(sv)       (SvPRIVATE(sv) &= ~SVp_SCREAM)
 
-#define SvTEMP(sv)             (SvFLAGS(sv) & SVf_TEMP)
-#define SvTEMP_on(sv)          (SvFLAGS(sv) |= SVf_TEMP)
-#define SvTEMP_off(sv)         (SvFLAGS(sv) &= ~SVf_TEMP)
-
 #define SvCOMPILED(sv)         (SvPRIVATE(sv) & SVpfm_COMPILED)
 #define SvCOMPILED_on(sv)      (SvPRIVATE(sv) |= SVpfm_COMPILED)
 #define SvCOMPILED_off(sv)     (SvPRIVATE(sv) &= ~SVpfm_COMPILED)
@@ -294,6 +331,9 @@ struct xpvfm {
 #define SvMULTI_on(sv)         (SvPRIVATE(sv) |= SVpgv_MULTI)
 #define SvMULTI_off(sv)                (SvPRIVATE(sv) &= ~SVpgv_MULTI)
 
+#define SvRV(sv) ((XRV*)  SvANY(sv))->xrv_rv
+#define SvRVx(sv) SvRV(sv)
+
 #define SvIVX(sv) ((XPVIV*)  SvANY(sv))->xiv_iv
 #define SvIVXx(sv) SvIVX(sv)
 #define SvNVX(sv)  ((XPVNV*)SvANY(sv))->xnv_nv
diff --git a/t/foo b/t/foo
new file mode 100755 (executable)
index 0000000..ace796d
--- /dev/null
+++ b/t/foo
@@ -0,0 +1,4 @@
+#!./perl -Dst
+
+$ref = [[],2,[3,4,5,]];
+print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
index 83420d2..3243c62 100755 (executable)
@@ -4,7 +4,7 @@
 
 $| = 1;                # command buffering
 
-print "1..5\n";
+print "1..6\n";
 
 eval '$ENV{"foo"} = "hi there";';      # check that ENV is inited inside eval
 if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
@@ -40,3 +40,6 @@ END
 @val2 = values(%ENV);
 
 print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
+
+print @val1 > 1 ? "ok 6\n" : "not ok 6\n";
+
index b0619cb..ead65b5 100755 (executable)
@@ -134,7 +134,8 @@ print ref $object2  eq MYHASH  ? "ok 32\n" : "not ok 32\n";
 
 sub mymethod {
     local($THIS, @ARGS) = @_;
-    die "Not a MYHASH" unless ref $THIS eq MYHASH;
+    die 'Got a "' . ref($THIS). '" instead of a MYHASH'
+       unless ref $THIS eq MYHASH;
     print $THIS->{FOO} eq BAR  ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
 }
 
@@ -146,7 +147,7 @@ $string = "ok 34\n";
 $main'anonhash2 = "foo";
 $string = "not ok 34\n";
 
-sub DESTROY {
+DESTROY {
     print $string;
 
     # Test that the object has already been "cursed".
similarity index 100%
rename from t/op/s.t
rename to t/op/subst.t
diff --git a/t/perl5a1.tar b/t/perl5a1.tar
deleted file mode 100644 (file)
index 0c0b43c..0000000
Binary files a/t/perl5a1.tar and /dev/null differ
diff --git a/toke.c b/toke.c
index da48c57..9790edf 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -168,6 +168,8 @@ no_op(what)
 char *what;
 {
     warn("%s found where operator expected", what);
+    if (bufptr == SvPVX(linestr))
+       warn("\t(Missing semicolon on previous line?)\n", what);
 }
 
 void
@@ -433,7 +435,7 @@ SV *sv;
     if (s == send)
        return sv;
     d = s;
-    delim = SvSTORAGE(sv);
+    delim = SvIVX(sv);
     while (s < send) {
        if (*s == '\\') {
            if (s + 1 < send && (s[1] == '\\' || s[1] == delim))
@@ -569,7 +571,7 @@ char *start;
     SV *sv = NEWSV(93, send - start);
     register char *s = start;
     register char *d = SvPVX(sv);
-    char delim = SvSTORAGE(linestr);
+    char delim = SvIVX(linestr);
     bool dorange = FALSE;
     I32 len;
     char *leave =
@@ -951,7 +953,7 @@ yylex()
        if (bufptr == bufend)
            return sublex_done();
 
-       if (SvSTORAGE(linestr) == '\'') {
+       if (SvIVX(linestr) == '\'') {
            SV *sv = newSVsv(linestr);
            if (!lex_inpat)
                sv = q(sv);
@@ -1257,14 +1259,14 @@ yylex()
                if (in_my) {
                    if (strchr(tokenbuf,':'))
                        croak("\"my\" variable %s can't be in a package",tokenbuf);
-                   nextval[nexttoke].opval = newOP(OP_PADHV, 0);
+                   nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                    nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
                    force_next(PRIVATEREF);
                    TERM('%');
                }
                if (!strchr(tokenbuf,':')) {
                    if (tmp = pad_findmy(tokenbuf)) {
-                       nextval[nexttoke].opval = newOP(OP_PADHV, 0);
+                       nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                        nextval[nexttoke].opval->op_targ = tmp;
                        force_next(PRIVATEREF);
                        TERM('%');
@@ -1506,22 +1508,17 @@ yylex()
            if (in_my) {
                if (strchr(tokenbuf,':'))
                    croak("\"my\" variable %s can't be in a package",tokenbuf);
-               nextval[nexttoke].opval = newOP(OP_PADSV, 0);
+               nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
                force_next(PRIVATEREF);
            }
            else if (!strchr(tokenbuf,':')) {
-               I32 optype = OP_PADSV;
-               if (*s == '[') {
+               if (*s == '[')
                    tokenbuf[0] = '@';
-                   optype = OP_PADAV;
-               }
-               else if (*s == '{') {
+               else if (*s == '{')
                    tokenbuf[0] = '%';
-                   optype = OP_PADHV;
-               }
                if (tmp = pad_findmy(tokenbuf)) {
-                   nextval[nexttoke].opval = newOP(optype, 0);
+                   nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                    nextval[nexttoke].opval->op_targ = tmp;
                    force_next(PRIVATEREF);
                }
@@ -1548,19 +1545,16 @@ yylex()
            if (in_my) {
                if (strchr(tokenbuf,':'))
                    croak("\"my\" variable %s can't be in a package",tokenbuf);
-               nextval[nexttoke].opval = newOP(OP_PADAV, 0);
+               nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
                force_next(PRIVATEREF);
                TERM('@');
            }
            else if (!strchr(tokenbuf,':')) {
-               I32 optype = OP_PADAV;
-               if (*s == '{') {
+               if (*s == '{')
                    tokenbuf[0] = '%';
-                   optype = OP_PADHV;
-               }
                if (tmp = pad_findmy(tokenbuf)) {
-                   nextval[nexttoke].opval = newOP(optype, 0);
+                   nextval[nexttoke].opval = newOP(OP_PADANY, 0);
                    nextval[nexttoke].opval->op_targ = tmp;
                    force_next(PRIVATEREF);
                    TERM('@');
@@ -1843,6 +1837,7 @@ yylex()
            goto fake_eof;
        }
 
+       case KEY_DESTROY:
        case KEY_BEGIN:
        case KEY_END:
            s = skipspace(s);
@@ -2275,8 +2270,8 @@ yylex()
            if (!s)
                croak("EOF in string");
            yylval.ival = OP_SCALAR;
-           if (SvSTORAGE(lex_stuff) == '\'')
-               SvSTORAGE(lex_stuff) = 0;       /* qq'$foo' should intepolate */
+           if (SvIVX(lex_stuff) == '\'')
+               SvIVX(lex_stuff) = 0;   /* qq'$foo' should intepolate */
            TERM(sublex_start());
 
        case KEY_qx:
@@ -2690,6 +2685,9 @@ I32 len;
            break;
        }
        break;
+    case 'D':
+       if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
+       break;
     case 'd':
        switch (len) {
        case 2:
@@ -3834,8 +3832,8 @@ char *start;
     multi_close = term;
 
     sv = NEWSV(87,80);
-    sv_upgrade(sv, SVt_PV);
-    SvSTORAGE(sv) = term;
+    sv_upgrade(sv, SVt_PVIV);
+    SvIVX(sv) = term;
     SvPOK_only(sv);            /* validate pointer */
     s++;
     for (;;) {
@@ -4000,7 +3998,7 @@ char *start;
        *d = '\0';
        sv = NEWSV(92,0);
        value = atof(tokenbuf);
-       tryi32 = (I32)value;
+       tryi32 = I_32(value);
        if (!floatit && (double)tryi32 == value)
            sv_setiv(sv,tryi32);
        else
index dc593c6..31871ff 100644 (file)
--- a/unixish.h
+++ b/unixish.h
 #define HAS_PASSWD
 #endif
 
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+# include <signal.h>
+#endif
+
 #ifndef SIGABRT
 #    define SIGABRT SIGILL
 #endif
diff --git a/util.c b/util.c
index 576641d..f528cd5 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1500,6 +1500,24 @@ double f;
     along = (long)f;
     return (unsigned long)along;
 }
+# undef BIGDOUBLE
+#endif
+
+#ifndef CASTI32
+I32
+cast_i32(f)
+double f;
+{
+#   define BIGDOUBLE 2147483648.0        /* Assume 32 bit int's ! */
+#   define BIGNEGDOUBLE (-2147483648.0)
+    if (f >= BIGDOUBLE)
+       return (I32)fmod(f, BIGDOUBLE);
+    if (f <= BIGNEGDOUBLE)
+       return (I32)fmod(f, BIGNEGDOUBLE);
+    return (I32) f;
+}
+# undef BIGDOUBLE
+# undef BIGNEGDOUBLE
 #endif
 
 #ifndef HAS_RENAME