From ed6116ce9b9d13712ea252ee248b0400653db7f9 Mon Sep 17 00:00:00 2001 From: Larry Wall Date: Fri, 10 Dec 1993 00:00:00 +0000 Subject: [PATCH] perl 5.0 alpha 5 [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] --- .package | 16 -- Bugs/mislex | 1 + Bugs/substleak | 98 ++++++++ Changes | 4 + README | 17 +- SDBM_File.c | 23 +- Todo | 13 +- av.c | 20 +- bar | 7 - config.h | 6 + config_h.SH | 6 + doio.c | 27 ++- doop.c | 16 +- dump.c | 2 +- ext/dbm/SDBM_File.xs | 3 +- ext/xsubpp | 14 +- ext/xsubpp.bak | 529 ------------------------------------------ foo | 11 +- gv.c | 5 + internals | 295 ++++++++++++++++++++++++ keywords.h | 447 ++++++++++++++++++------------------ lib/bigint.pl | 4 +- lib/perldb.pl | 65 +++--- lib/termcap.pl | 2 +- make.out | 8 +- mg.c | 12 +- op.c | 130 +++++++---- op.h | 3 + opcode.h | 618 +++++++++++++++++++++++++------------------------- opcode.pl | 3 +- peek | 31 +++ perl.c | 3 +- perl.h | 14 ++ perly.c | 33 +-- perly.c.diff | 175 ++++++++++++-- pp.c | 192 ++++++++++------ proto.h | 3 +- save_ary.bad | 44 ---- sv.c | 486 ++++++++++++++++++++++++--------------- sv.h | 122 ++++++---- t/foo | 4 + t/op/magic.t | 5 +- t/op/ref.t | 5 +- t/op/{s.t => subst.t} | 0 t/perl5a1.tar | Bin 8192 -> 0 bytes toke.c | 48 ++-- unixish.h | 5 + util.c | 18 ++ 48 files changed, 1985 insertions(+), 1608 deletions(-) delete mode 100644 .package create mode 100644 Bugs/mislex create mode 100644 Bugs/substleak delete mode 100755 bar delete mode 100755 ext/xsubpp.bak create mode 100644 internals create mode 100755 peek delete mode 100644 save_ary.bad create mode 100755 t/foo rename t/op/{s.t => subst.t} (100%) delete mode 100644 t/perl5a1.tar diff --git a/.package b/.package deleted file mode 100644 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 index 0000000..07d972b --- /dev/null +++ b/Bugs/mislex @@ -0,0 +1 @@ +print( STDOUT "hello\n" ) diff --git a/Bugs/substleak b/Bugs/substleak new file mode 100644 index 0000000..ff14446 --- /dev/null +++ b/Bugs/substleak @@ -0,0 +1,98 @@ +Return-Path: Martin.Ward@durham.ac.uk +Return-Path: +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: +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 --- 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 --- 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 diff --git a/SDBM_File.c b/SDBM_File.c index 23b8356..d6e08c4 100644 --- a/SDBM_File.c +++ b/SDBM_File.c @@ -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 --- 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 --- 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 index 43ada97..0000000 --- a/bar +++ /dev/null @@ -1,7 +0,0 @@ -#!./perl - -$o = {A,1}; -$r = \($o->{A}); -print $$r; -$$r = foo; -print $$r; diff --git a/config.h b/config.h index 376fa77..09dd7ca 100644 --- a/config.h +++ b/config.h @@ -106,6 +106,12 @@ #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 diff --git a/config_h.SH b/config_h.SH index 03667bd..d1747d4 100755 --- a/config_h.SH +++ b/config_h.SH @@ -121,6 +121,12 @@ sed <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 --- 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 --- 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 --- 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))) diff --git a/ext/dbm/SDBM_File.xs b/ext/dbm/SDBM_File.xs index 0b898ad..25cb67c 100644 --- a/ext/dbm/SDBM_File.xs +++ b/ext/dbm/SDBM_File.xs @@ -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 diff --git a/ext/xsubpp b/ext/xsubpp index 2cc1486..e7a710b 100755 --- a/ext/xsubpp +++ b/ext/xsubpp @@ -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 index 0f309e3..0000000 --- a/ext/xsubpp.bak +++ /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 () { - 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 () { - 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 () { - # 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 < +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 diff --git a/keywords.h b/keywords.h index 09af786..b075a84 100644 --- a/keywords.h +++ b/keywords.h @@ -3,226 +3,227 @@ #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 diff --git a/lib/bigint.pl b/lib/bigint.pl index a2a0da9..45ffe1d 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -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) { diff --git a/lib/perldb.pl b/lib/perldb.pl index ff73d81..deeef8a 100644 --- a/lib/perldb.pl +++ b/lib/perldb.pl @@ -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; diff --git a/lib/termcap.pl b/lib/termcap.pl index 5b48d71..22c1817 100644 --- a/lib/termcap.pl +++ b/lib/termcap.pl @@ -33,7 +33,7 @@ sub Tgetent { while () { next if /^#/; next if /^\t/; - if (/(^|\\|)$TERM[:\\|]/) { + if (/(^|\\|)$TERM\[:\\|]/) { chop; while (chop eq '\\\\') { \$_ .= ; diff --git a/make.out b/make.out index f4d95b6..bebbb6a 100644 --- 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 "" diff --git a/mg.c b/mg.c index 07a0dfe..3196673 100644 --- 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 --- 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 --- 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 }; diff --git a/opcode.h b/opcode.h index cbfa0a7..e9bbcca 100644 --- 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 */ diff --git a/opcode.pl b/opcode.pl index 06a729b..321188e 100755 --- 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 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 --- 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 --- a/perl.h +++ b/perl.h @@ -272,6 +272,12 @@ char Error[1]; #endif #include +#ifdef HAS_SOCKET +# ifndef ENOTSOCK +# include +# 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 --- 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) { diff --git a/perly.c.diff b/perly.c.diff index 06a8b6c..4d81353 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -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; @@ -12,13 +12,13 @@ - 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); @@ -56,7 +56,29 @@ 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) { @@ -64,7 +86,12 @@ } *++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) { @@ -85,7 +112,12 @@ *++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) { @@ -93,7 +125,13 @@ } *++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) { @@ -116,7 +154,106 @@ *++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) { @@ -132,7 +269,13 @@ 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 --- 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 --- 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 index 807e339..0000000 --- a/save_ary.bad +++ /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 --- 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 --- 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 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"; diff --git a/t/op/magic.t b/t/op/magic.t index 83420d2..3243c62 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -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"; + diff --git a/t/op/ref.t b/t/op/ref.t index b0619cb..ead65b5 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -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". diff --git a/t/op/s.t b/t/op/subst.t 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 index 0c0b43ce1be74dcfcd49477f72a47084ea4738ec..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8192 zcmeIuF%bYT3677K!5-N0t5&UAV7cs0RjXF U5Fl_bko%+}0RjXF5Fk(`u*~uRy8r+H diff --git a/toke.c b/toke.c index da48c57..9790edf 100644 --- 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 diff --git a/unixish.h b/unixish.h index dc593c6..31871ff 100644 --- a/unixish.h +++ b/unixish.h @@ -28,6 +28,11 @@ #define HAS_PASSWD #endif + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +# include +#endif + #ifndef SIGABRT # define SIGABRT SIGILL #endif diff --git a/util.c b/util.c index 576641d..f528cd5 100644 --- 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 -- 1.8.3.1