+++ /dev/null
-: 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'
--- /dev/null
+print( STDOUT "hello\n" )
--- /dev/null
+Return-Path: Martin.Ward@durham.ac.uk
+Return-Path: <Martin.Ward@durham.ac.uk>
+Received: from scalpel.netlabs.com by netlabs.com (4.1/SMI-4.1)
+ id AA01931; Thu, 20 Jan 94 03:56:39 PST
+Received: from netlabs.com (vaccine-eng1.netlabs.com) by scalpel.netlabs.com (4.1/SMI-4.1)
+ id AA09639; Thu, 20 Jan 94 03:56:36 PST
+Received: from sun2.nsfnet-relay.ac.uk by netlabs.com (4.1/SMI-4.1)
+ id AA01923; Thu, 20 Jan 94 03:56:01 PST
+Via: uk.ac.durham; Thu, 20 Jan 1994 11:47:16 +0000
+Received: from easby.dur.ac.uk by durham.ac.uk; Thu, 20 Jan 94 11:47:05 GMT
+Received: from ws-csm3.durham.ac.uk (ws-csm3.dur) by uk.ac.durham.easby;
+ Thu, 20 Jan 94 11:46:29 GMT
+From: Martin.Ward@durham.ac.uk (Martin Ward)
+Date: Thu, 20 Jan 94 11:46:27 GMT
+Message-Id: <AA00871.9401201146.ws-csm3@uk.ac.durham>
+To: des0mpw@easby.durham.ac.uk, lwall@scalpel.netlabs.com
+Subject: Re: My last message
+
+>: After saying I was stumped, I managed to track down the problem!
+>: The problem was caused by a line much higher up:
+>:
+>: $seqpat = "$bs[s]\000e\000q\000\{\000"; # } hack
+>:
+>: Changing this by adding {} gives:
+>:
+>: $seqpat = "${bs}[s]\000e\000q\000\{\000"; # } hack
+>:
+>: which worked! No idea why :-)
+>
+>It apparently intuited $bs[s] to be an array reference.
+
+Aha! I think the interpretation is:
+"$bs[ s] .....
+^^^^^ ^^
+array ref Therefore this is an expression, so "s]" is the start of
+ a pattern match/replace, so it scans for ...]....]
+
+I found the line by repeatedly chopping away everything after (and including)
+the line where perl _thought_ the error started. This gradually worked back
+through a nasty cascade of errors!
+
+>: No speed improvement this time (the improvement in user time was swamped
+>: by an increase in system time. This may be because it uses 5048k of
+>: data/stack space, compared with 985k for perl4).
+>
+>That doesn't sound good. I hope it's a bug. Does it grow continuously?
+>Hopefully it's just a memory leak.
+
+For perl4 the memory size (shown by top) grows by about 100-150k per 2 seconds,
+for perl5 it grows by about 1 - 1.5 Meg per 2 seconds. I don't use the script
+very often (and I have over 100 Meg of swap space) so its not a big problem.
+Still, with a 124k input file, the size for perl5 went up to 40 Meg!
+
+I have tracked down a memory leak, which is basically one line from the
+texqed script. Store this script in "tmp" and run "perl tmp /vmunix"
+(or some other large random file). Monitor the process using "top" in
+another window.
+
+Perl4 is OK but perl5 leaks like a leaky cistern.
+
+
+#!/usr/local/bin/perl
+
+# print a "." every $interval lines:
+$interval = 10;
+open (PAIRS, "$ARGV[0]");
+open (OUT, "> /dev/null");
+$bs = "\\\\" . "\000";
+for (;;) {
+ $line++;
+ if (($line % $interval) == 0) {
+ print STDERR ".";
+ }
+ read(PAIRS, $_, 20);
+ last if ($_ eq "");
+
+ s/$bs([_^\\])\000/\\\377$1\377/g;
+
+ print OUT ;
+}
+
+print STDERR "\n";
+
+
+
+I hope you find this useful!
+
+NB Changing the "s/.../.../g" to an "m/.../" (with the same pattern)
+makes the leak go away even on input files where the pattern NEVER matches!!
+
+ Martin.
+
+JANET: Martin.Ward@uk.ac.durham Internet (eg US): Martin.Ward@durham.ac.uk
+or if that fails: Martin.Ward%uk.ac.durham@nsfnet-relay.ac.uk
+or even: Martin.Ward%DURHAM.AC.UK@CUNYVM.CUNY.EDU
+BITNET: Martin.Ward%durham.ac.uk@UKACRL UUCP:...!uknet!durham!Martin.Ward
+[Last acked 0.7 days ago--not acked]
+
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 $.
-[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
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)
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);
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");
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");
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");
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");
}
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;
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);
}
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");
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");
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);
}
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
lexperl
Bundled perl preprocessor
FILEHANDLE methods
+ Make $[ compile-time instead of run-time
Optimizations
Make specialized allocators
rcatmaybe
Shrink opcode tables via multiple implementations selected in peep
Cache hash value?
+ Optimize away @_ where possible
sfio?
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
}
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) {
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')) {
}
strp++;
}
+ SvOK_on(av);
return av;
}
SvTEMP_off(*strp);
strp++;
}
+ SvOK_on(av);
return av;
}
+++ /dev/null
-#!./perl
-
-$o = {A,1};
-$r = \($o->{A});
-print $$r;
-$$r = foo;
-print $$r;
#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
#$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
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);
{
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);
}
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);
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);
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);
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);
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)))
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_
SDBM_File db
datum
-sdbm_nextkey(db, key)
+nextkey(db, key)
SDBM_File db
datum key
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
+++ /dev/null
-#!/usr/bin/perl
-# $Header$
-
-$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
-die $usage unless (@ARGV >= 2 && @ARGV <= 6);
-
-SWITCH: while ($ARGV[0] =~ /^-/) {
- $flag = shift @ARGV;
- $aflag = 1, next SWITCH if $flag =~ /^-a$/;
- $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
- $cflag = 1, next SWITCH if $flag =~ /^-c$/;
- $eflag = 1, next SWITCH if $flag =~ /^-e$/;
- die $usage;
-}
-
-$typemap = shift @ARGV;
-open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
-while (<TYPEMAP>) {
- next if /^\s*$/ || /^#/;
- chop;
- ($typename, $kind) = split(/\t+/, $_, 2);
- $type_kind{$typename} = $kind;
-}
-close(TYPEMAP);
-
-%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
-
-T_INT
- $var = (int)SvIVn($arg)
-T_ENUM
- $var = ($type)SvIVn($arg)
-T_U_INT
- $var = (unsigned int)SvIVn($arg)
-T_SHORT
- $var = (short)SvIVn($arg)
-T_U_SHORT
- $var = (unsigned short)SvIVn($arg)
-T_LONG
- $var = (long)SvIVn($arg)
-T_U_LONG
- $var = (unsigned long)SvIVn($arg)
-T_CHAR
- $var = (char)*SvPVn($arg,na)
-T_U_CHAR
- $var = (unsigned char)SvIVn($arg)
-T_FLOAT
- $var = (float)SvNVn($arg)
-T_DOUBLE
- $var = SvNVn($arg)
-T_STRING
- $var = SvPVn($arg,na)
-T_PTR
- $var = ($type)(unsigned long)SvNVn($arg)
-T_PTRREF
- if (SvTYPE($arg) == SVt_REF)
- $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
- else
- croak(\"$var is not a reference\")
-T_PTROBJ
- if (sv_isa($arg, \"${ntype}\"))
- $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
- else
- croak(\"$var is not of type ${ntype}\")
-T_PTRDESC
- if (sv_isa($arg, \"${ntype}\")) {
- ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNVn((SV*)SvANY($arg));
- $var = ${type}_desc->ptr;
- }
- else
- croak(\"$var is not of type ${ntype}\")
-T_REFREF
- if (SvTYPE($arg) == SVt_REF)
- $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
- else
- croak(\"$var is not a reference\")
-T_REFOBJ
- if (sv_isa($arg, \"${ntype}\"))
- $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
- else
- croak(\"$var is not of type ${ntype}\")
-T_OPAQUE
- $var NOT IMPLEMENTED
-T_OPAQUEPTR
- $var = ($type)SvPVn($arg,na)
-T_PACKED
- $var = XS_unpack_$ntype($arg)
-T_PACKEDARRAY
- $var = XS_unpack_$ntype($arg)
-T_CALLBACK
- $var = make_perl_cb_$type($arg)
-T_ARRAY
- $var = $ntype(items -= $argoff);
- U32 ix_$var = $argoff;
- while (items--) {
- DO_ARRAY_ELEM;
- }
-T_DATUM
- $var.dptr = SvPVn($arg, $var.dsize);
-T_GDATUM
- UNIMPLEMENTED
-T_PLACEHOLDER
-T_END
-
-$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
-T_INT
- sv_setiv($arg, (I32)$var);
-T_ENUM
- sv_setiv($arg, (I32)$var);
-T_U_INT
- sv_setiv($arg, (I32)$var);
-T_SHORT
- sv_setiv($arg, (I32)$var);
-T_U_SHORT
- sv_setiv($arg, (I32)$var);
-T_LONG
- sv_setiv($arg, (I32)$var);
-T_U_LONG
- sv_setiv($arg, (I32)$var);
-T_CHAR
- sv_setpvn($arg, (char *)&$var, 1);
-T_U_CHAR
- sv_setiv($arg, (I32)$var);
-T_FLOAT
- sv_setnv($arg, (double)$var);
-T_DOUBLE
- sv_setnv($arg, $var);
-T_STRING
- sv_setpv($arg, $var);
-T_PTR
- sv_setnv($arg, (double)(unsigned long)$var);
-T_PTRREF
- sv_setptrref($arg, $var);
-T_PTROBJ
- sv_setptrobj($arg, $var, \"${ntype}\");
-T_PTRDESC
- sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
-T_REFREF
- sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
- ($var ? (void*)new $ntype($var) : 0));
-T_REFOBJ
- NOT IMPLEMENTED
-T_OPAQUE
- sv_setpvn($arg, (char *)&$var, sizeof($var));
-T_OPAQUEPTR
- sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
-T_PACKED
- XS_pack_$ntype($arg, $var);
-T_PACKEDARRAY
- XS_pack_$ntype($arg, $var, count_$ntype);
-T_DATAUNIT
- sv_setpvn($arg, $var.chp(), $var.size());
-T_CALLBACK
- sv_setpvn($arg, $var.context.value().chp(),
- $var.context.value().size());
-T_ARRAY
- ST_EXTEND($var.size);
- for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
- ST(ix_$var) = sv_mortalcopy(&sv_undef);
- DO_ARRAY_ELEM
- }
- sp += $var.size - 1;
-T_DATUM
- sv_setpvn($arg, $var.dptr, $var.dsize);
-T_GDATUM
- sv_usepvn($arg, $var.dptr, $var.dsize);
-T_END
-
-$uvfile = shift @ARGV;
-open(F, $uvfile) || die "cannot open $uvfile\n";
-
-if ($eflag) {
- print qq|#include "cfm/basic.h"\n|;
-}
-
-while (<F>) {
- last if ($Module, $foo, $Package, $foo1, $Prefix) =
- /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
- print $_;
-}
-$Pack = $Package;
-$Package .= "::" if defined $Package && $Package ne "";
-$/ = "";
-
-while (<F>) {
- # parse paragraph
- chop;
- next if /^\s*$/;
- next if /^(#.*\n?)+$/;
- if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
- $Module = $1;
- $foo = $2;
- $Package = $3;
- $Pack = $Package;
- $foo1 = $4;
- $Prefix = $5;
- $Package .= "::" if defined $Package && $Package ne "";
- next;
- }
- split(/[\t ]*\n/);
-
- # initialize info arrays
- undef(%args_match);
- undef(%var_types);
- undef(%var_addr);
- undef(%defaults);
- undef($class);
- undef($static);
- undef($elipsis);
-
- # extract return type, function name and arguments
- $ret_type = shift(@_);
- if ($ret_type =~ /^static\s+(.*)$/) {
- $static = 1;
- $ret_type = $1;
- }
- $func_header = shift(@_);
- ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
- if ($func_name =~ /(.*)::(.*)/) {
- $class = $1;
- $func_name = $2;
- }
- ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
- push(@Func_name, "${Pack}_$func_name");
- push(@Func_pname, $pname);
- @args = split(/\s*,\s*/, $orig_args);
- if (defined($class) && !defined($static)) {
- unshift(@args, "THIS");
- $orig_args = "THIS, $orig_args";
- $orig_args =~ s/^THIS, $/THIS/;
- }
- $orig_args =~ s/"/\\"/g;
- $min_args = $num_args = @args;
- foreach $i (0..$num_args-1) {
- if ($args[$i] =~ s/\.\.\.//) {
- $elipsis = 1;
- $min_args--;
- if ($args[i] eq '' && $i == $num_args - 1) {
- pop(@args);
- last;
- }
- }
- if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
- $min_args--;
- $args[$i] = $1;
- $defaults{$args[$i]} = $2;
- $defaults{$args[$i]} =~ s/"/\\"/g;
- }
- }
- if (defined($class) && !defined($static)) {
- $func_args = join(", ", @args[1..$#args]);
- } else {
- $func_args = join(", ", @args);
- }
- @args_match{@args} = 1..@args;
-
- # print function header
- print <<"EOF" if $aflag;
-static int
-XS_${Pack}_$func_name(int, int sp, int items)
-EOF
- print <<"EOF" if !$aflag;
-static int
-XS_${Pack}_$func_name(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-EOF
- print <<"EOF" if $elipsis;
-{
- if (items < $min_args) {
- croak("Usage: $pname($orig_args)");
- }
-EOF
- print <<"EOF" if !$elipsis;
-{
- if (items < $min_args || items > $num_args) {
- croak("Usage: $pname($orig_args)");
- }
-EOF
-
-# Now do a block of some sort.
-
-$condnum = 0;
-if (!@_) {
- @_ = "CLEANUP:";
-}
-while (@_) {
- if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
- $cond = shift(@_);
- if ($condnum == 0) {
- print " if ($cond)\n";
- }
- elsif ($cond ne '') {
- print " else if ($cond)\n";
- }
- else {
- print " else\n";
- }
- $condnum++;
- }
-
- print <<"EOF" if $eflag;
- TRY {
-EOF
- print <<"EOF" if !$eflag;
- {
-EOF
-
- # do initialization of input variables
- $thisdone = 0;
- $retvaldone = 0;
- $deferred = "";
- while ($_ = shift(@_)) {
- last if /^\s*NOT_IMPLEMENTED_YET/;
- last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
- ($var_type, $var_name, $var_init) =
- /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
- if ($var_name =~ /^&/) {
- $var_name =~ s/^&//;
- $var_addr{$var_name} = 1;
- }
- $thisdone |= $var_name eq "THIS";
- $retvaldone |= $var_name eq "RETVAL";
- $var_types{$var_name} = $var_type;
- print "\t" . &map_type($var_type);
- $var_num = $args_match{$var_name};
- if ($var_addr{$var_name}) {
- $func_args =~ s/\b($var_name)\b/&\1/;
- }
- if ($var_init !~ /^=\s*NO_INIT\s*$/) {
- if ($var_init !~ /^\s*$/) {
- &output_init($var_type, $var_num,
- "$var_name $var_init");
- } elsif ($var_num) {
- # generate initialization code
- &generate_init($var_type, $var_num, $var_name);
- } else {
- print ";\n";
- }
- } else {
- print "\t$var_name;\n";
- }
- }
- if (!$thisdone && defined($class) && !defined($static)) {
- print "\t$class *";
- $var_types{"THIS"} = "$class *";
- &generate_init("$class *", 1, "THIS");
- }
-
- # do code
- if (/^\s*NOT_IMPLEMENTED_YET/) {
- print "\ncroak(\"$pname: not implemented yet\");\n";
- } else {
- if ($ret_type ne "void") {
- print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
- if !$retvaldone;
- $args_match{"RETVAL"} = 0;
- $var_types{"RETVAL"} = $ret_type;
- }
- print $deferred;
- if (/^\s*CODE:/) {
- while ($_ = shift(@_)) {
- last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
- print "$_\n";
- }
- } else {
- print "\n\t";
- if ($ret_type ne "void") {
- print "RETVAL = ";
- }
- if (defined($static)) {
- print "$class::";
- } elsif (defined($class)) {
- print "THIS->";
- }
- if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
- $func_name = $2;
- }
- print "$func_name($func_args);\n";
- &generate_output($ret_type, 0, "RETVAL")
- unless $ret_type eq "void";
- }
- }
-
- # do output variables
- if (/^\s*OUTPUT\s*:/) {
- while ($_ = shift(@_)) {
- last if /^\s*CLEANUP\s*:/;
- s/^\s+//;
- ($outarg, $outcode) = split(/\t+/);
- if ($outcode) {
- print "\t$outcode\n";
- } else {
- die "$outarg not an argument"
- unless defined($args_match{$outarg});
- $var_num = $args_match{$outarg};
- &generate_output($var_types{$outarg}, $var_num,
- $outarg);
- }
- }
- }
- # do cleanup
- if (/^\s*CLEANUP\s*:/) {
- while ($_ = shift(@_)) {
- last if /^\s*CASE\s*:/;
- print "$_\n";
- }
- }
- # print function trailer
- print <<EOF if $eflag;
- }
- BEGHANDLERS
- CATCHALL
- croak("%s: %s\\tpropagated", Xname, Xreason);
- ENDHANDLERS
-EOF
- print <<EOF if !$eflag;
- }
-EOF
- if (/^\s*CASE\s*:/) {
- unshift(@_, $_);
- }
-}
- print <<EOF;
- return sp;
-}
-
-EOF
-}
-
-# print initialization routine
-print qq/extern "C"\n/ if $cflag;
-print <<"EOF";
-int init_$Module(ix,sp,items)
-int ix;
-int sp;
-int items;
-{
- char* file = __FILE__;
-
-EOF
-
-for (@Func_name) {
- $pname = shift(@Func_pname);
- print " newXSUB(\"$pname\", 0, XS_$_, file);\n";
-}
-print "}\n";
-
-sub output_init {
- local($type, $num, $init) = @_;
- local($arg) = "ST($num)";
-
- eval qq/print " $init\\\n"/;
-}
-
-sub generate_init {
- local($type, $num, $var) = @_;
- local($arg) = "ST($num)";
- local($argoff) = $num - 1;
- local($ntype);
-
- die "$type not in typemap" if !defined($type_kind{$type});
- ($ntype = $type) =~ s/\s*\*/Ptr/g;
- $subtype = $ntype;
- $subtype =~ s/Ptr$//;
- $subtype =~ s/Array$//;
- $expr = $input_expr{$type_kind{$type}};
- if ($expr =~ /DO_ARRAY_ELEM/) {
- $subexpr = $input_expr{$type_kind{$subtype}};
- $subexpr =~ s/ntype/subtype/g;
- $subexpr =~ s/\$arg/ST(ix_$var)/g;
- $subexpr =~ s/\n\t/\n\t\t/g;
- $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
- $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
- $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
- }
- if (defined($defaults{$var})) {
- $expr =~ s/(\t+)/$1 /g;
- $expr =~ s/ /\t/g;
- eval qq/print "\\t$var;\\n"/;
- $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
- } elsif ($expr !~ /^\t\$var =/) {
- eval qq/print "\\t$var;\\n"/;
- $deferred .= eval qq/"\\n$expr;\\n"/;
- } else {
- eval qq/print "$expr;\\n"/;
- }
-}
-
-sub generate_output {
- local($type, $num, $var) = @_;
- local($arg) = "ST($num)";
- local($argoff) = $num - 1;
- local($ntype);
-
- if ($type =~ /^array\(([^,]*),(.*)\)/) {
- print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
- } else {
- die "$type not in typemap" if !defined($type_kind{$type});
- ($ntype = $type) =~ s/\s*\*/Ptr/g;
- $ntype =~ s/\(\)//g;
- $subtype = $ntype;
- $subtype =~ s/Ptr$//;
- $subtype =~ s/Array$//;
- $expr = $output_expr{$type_kind{$type}};
- if ($expr =~ /DO_ARRAY_ELEM/) {
- $subexpr = $output_expr{$type_kind{$subtype}};
- $subexpr =~ s/ntype/subtype/g;
- $subexpr =~ s/\$arg/ST(ix_$var)/g;
- $subexpr =~ s/\$var/${var}[ix_$var]/g;
- $subexpr =~ s/\n\t/\n\t\t/g;
- $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
- }
- elsif ($arg eq 'ST(0)') {
- print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
- }
- eval "print qq\f$expr\f";
- }
-}
-
-sub map_type {
- local($type) = @_;
-
- if ($type =~ /^array\(([^,]*),(.*)\)/) {
- return "$1 *";
- } else {
- return $type;
- }
-}
#!./perl
-# Test the singlequoted eval optimizer
+tie ( @a, TST_tie, "arg1", "arg2" );
+$a[2]=[1];
-for (1..1) { }
+package TST_tie;
+
+sub new { bless []; }
+
+sub fetch { print "store @_\n" }
+sub store { print "store @_\n" }
+sub delete { print "store @_\n" }
/* set up magic where warranted */
switch (*name) {
+ case 'a':
+ case 'b':
+ if (len == 1)
+ SvMULTI_on(gv);
+ break;
case 'I':
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
--- /dev/null
+Newsgroups: comp.lang.perl
+Subject: Re: perl5a4: tie ref restriction?
+Summary:
+Expires:
+References: <2h7b64$aai@jethro.Corp.Sun.COM>
+Sender:
+Followup-To:
+Distribution: world
+Organization: NetLabs, Inc.
+Keywords:
+
+In article <2h7b64$aai@jethro.Corp.Sun.COM> Eric.Arnold@Sun.COM writes:
+: Darn:
+: tie ( @a, TST_tie, "arg1", "arg2" );
+: $a[2]=[1];
+:
+: produces:
+:
+: Can't assign a reference to a magical variable at ./tsttie line 12.
+:
+: I'm all agog about the "tie" function, but ... if this restriction
+: wasn't there, I think I would be able to tie a top level
+: reference/variable to my own package, and then automatically tie in all
+: subsequently linked vars/references so that I could "tie" any arbitrary thing
+: like:
+: $r->{key}[el]{key}
+:
+: to a DBM or other type storage area.
+:
+: Is the restriction necessary?
+
+In the current storage scheme, yes, but as I mentioned in the other
+article, I can and probably should relax that. That code is some of
+the oldest Perl 5 code, and I didn't see some things then that I do
+now.
+
+Ok, let me explain some things about how values are stored. Consider
+this a little design document.
+
+Internally everything is unified to look like a scalar, regardless of
+its type. There's a type-invariant part of every value, and a
+type-variant part. When we modify the type of a value, we can do it in
+place because all references point to the invariant part. All we do is
+swap the variant part for a different part and change that ANY pointer
+in the invariant part to point to the new variant.
+
+The invariant part looks like this:
+
+struct sv {
+ void* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ SVTYPE sv_type; /* what sort of thing pointer points to */
+ U8 sv_flags; /* extra flags, some depending on type */
+ U8 sv_storage; /* storage class */
+ U8 sv_private; /* extra value, depending on type */
+};
+
+This is typedefed to SV. There are other structurally equivalent
+types, AV, HV and CV, that are there merely to help gdb know what kind
+of pointer sv_any is, and provide a little bit of C type-checking.
+Here's a key to Perl naming:
+
+ SV scalar value
+ AV array value
+ HV hash value
+ CV code value
+
+Additionally I often use names containing
+
+ IV integer value
+ NV numeric value (double)
+ PV pointer value
+ LV lvalue, such as a substr() or vec() being assigned to
+ BM a string containing a Boyer-Moore compiled pattern
+ FM a format line program
+
+You'll notice that in SV there's an sv_type field. This contains one
+of the following values, which gives the interpretation of sv_any.
+
+typedef enum {
+ SVt_NULL,
+ SVt_REF,
+ SVt_IV,
+ SVt_NV,
+ SVt_PV,
+ SVt_PVIV,
+ SVt_PVNV,
+ SVt_PVMG,
+ SVt_PVLV,
+ SVt_PVAV,
+ SVt_PVHV,
+ SVt_PVCV,
+ SVt_PVGV,
+ SVt_PVBM,
+ SVt_PVFM,
+} svtype;
+
+These are arranged ROUGHLY in order of increasing complexity, though
+there are some discontinuities. Many of them indicate that sv_any
+points to a struct of a similar name with an X on the front. They can
+be classified like this:
+
+ SVt_NULL
+ The sv_any doesn't point to anything meaningful.
+
+ SVt_REF
+ The sv_any points to another SV. (This is what we're talking
+ about changing to work more like IV and NV below.)
+
+ SVt_IV
+ SVt_NV
+ These are a little tricky in order to be efficient in both
+ memory and time. The sv_any pointer indicates the location of
+ a solitary integer(double), but not directly. The pointer is
+ really a pointer to an XPVIV(XPVNV), so that if there's a valid
+ integer(double) the same code works regardless of the type of
+ the SV. They have special allocators that guarantee that, even
+ though sv_any is pointing to a location several words earlier
+ than the integer(double), it never points to unallocated
+ memory. This does waste a few allocated integers(doubles) at
+ the beginning, but it's probably an overall win.
+
+ SVt_PV
+ SVt_PVIV
+ SVt_PVNV
+ SVt_PVMG
+ These are pretty ordinary, and each is "derived" from the
+ previous in the sense that it just adds more data to the
+ previous structure.
+
+ struct xpv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ };
+
+ This is your basic string scalar that is never used numerically
+ or magically.
+
+ struct xpviv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ };
+
+ This is a string scalar that has either been used as an
+ integer, or an integer that has been used in a string
+ context, or has had the front trimmed off of it, in which
+ case xiv_iv contains how far xpv_pv has been incremented
+ from the original allocated value.
+
+ struct xpvnv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ };
+
+ This is a string or integer scalar that has been used in a
+ numeric context, or a number that has been used in a string
+ or integer context.
+
+ struct xpvmg {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ I32 xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+ };
+
+ This is the top of the line for ordinary scalars. This scalar
+ has been charmed with one or more kinds of magical or object
+ behavior. In addition it can contain any or all of integer,
+ double or string.
+
+ SVt_PVLV
+ SVt_PVAV
+ SVt_PVHV
+ SVt_PVCV
+ SVt_PVGV
+ SVt_PVBM
+ SVt_PVFM
+ These are specialized forms that are never directly visible to
+ the Perl script. They are independent of each other, and may
+ not be promoted to any other type.
+
+There are several additional data values in the SV structure. The sv_refcnt
+gives the number of references to this SV. Some of these references may be
+actual Perl language references, but many other are just internal pointers,
+from a symbol table, or from the syntax tree, for example. When sv_refcnt
+goes to zero, the value can be safely deallocated.
+
+The sv_storage byte is not very well thought out, but tends to indicate
+something about where the scalar lives. It's used in allocating
+lexical storage, and at runtime contains an 'O' if the value has been
+blessed as an object. There may be some conflicts lurking in here, and
+I may eventually claim some of the bits for other purposes.
+
+The sv_flags are currently as follows. Most of these are set and cleared
+by macros to guarantee their consistency, and you should always use the
+proper macro rather than accessing them directly.
+
+#define SVf_IOK 1 /* has valid integer value */
+#define SVf_NOK 2 /* has valid numeric value */
+#define SVf_POK 4 /* has valid pointer value */
+ These tell whether an integer, double or string value is
+ immediately available without further consideration. All tainting
+ and magic (but not objecthood) works by turning off these bits and
+ forcing a routine to be executed to discover the real value. The
+ SvIV(), SvNV() and SvPV() macros that fetch values are smart about
+ all this, and should always be used if possible. Most of the stuff
+ mentioned below you really don't have to deal with directly. (Values
+ aren't stored using macros, but using functions sv_setiv(), sv_setnv()
+ and sv_setpv(), plus variants. You should never have to explicitly
+ follow the sv_any pointer to any X structure in your code.)
+
+#define SVf_OOK 8 /* has valid offset value */
+ This is only on when SVf_IOK is off, and indicates that the unused
+ integer storage is holding an offset for the string pointer value
+ because you've done something like s/^prefix//.
+
+#define SVf_MAGICAL 16 /* has special methods */
+ This indicates not only that sv_type is at least SVt_PVMG, but
+ also that the linked list of magical behaviors is not empty.
+
+#define SVf_OK 32 /* has defined value */
+ This indicates that the value is defined. Currently it means either
+ that the type if SVt_REF or that one of SVf_IOK, SVf_NOK, or SVf_POK
+ is set.
+
+#define SVf_TEMP 64 /* eventually in sv_private? */
+ This indicates that the string is a temporary allocated by one of
+ the sv_mortal functions, and that any string value may be stolen
+ from it without copying. (It's important not to steal the value if
+ the temporary will continue to require the value, however.)
+
+#define SVf_READONLY 128 /* may not be modified */
+ This scalar value may not be modified. Any function that might modify
+ a scalar should check for this first, and reject the operation when
+ inappropriate. Currently only the builtin values for sv_undef, sv_yes
+ and sv_no are marked readonly, but eventually we may provide a language
+ to set this bit.
+
+The sv_private byte contains some additional bits that apply across the
+board. Really private bits (that depend on the type) are allocated from
+128 down.
+
+#define SVp_IOK 1 /* has valid non-public integer value */
+#define SVp_NOK 2 /* has valid non-public numeric value */
+#define SVp_POK 4 /* has valid non-public pointer value */
+ These shadow the bits in sv_flags for tainted variables, indicated that
+ there really is a valid value available, but you have to set the global
+ tainted flag if you acces them.
+
+#define SVp_SCREAM 8 /* has been studied? */
+ Indicates that a study was done on this string. A studied string is
+ magical and automatically unstudies itself when modified.
+
+#define SVp_TAINTEDDIR 16 /* PATH component is a security risk */
+ A special flag for $ENV{PATH} that indicates that, while the value
+ as a whole may be untainted, some path component names an insecure
+ directory.
+
+#define SVpfm_COMPILED 128
+ For a format, whether its picture has been "compiled" yet. This
+ cannot be done until runtime because the user has access to the
+ internal formline function, and may supply a variable as the
+ picture.
+
+#define SVpbm_VALID 128
+#define SVpbm_CASEFOLD 64
+#define SVpbm_TAIL 32
+ For a Boyer-Moore pattern, whether the search string has been invalidated
+ by modification (can happen to $pat between calls to index($string,$pat)),
+ whether case folding is in force for regexp matching, and whether we're
+ trying to match something like /foo$/.
+
+#define SVpgv_MULTI 128
+ For a symbol table entry, set when we've decided that this symbol is
+ probably not a typo. Suspected typos can be reported by -w.
+
+
+Well, that's probably enough for now. As you can see, we could turn
+references into something more like an integer or a pointer value. In
+fact, I suspect the right thing to do is say that a reference is just
+a funny type of string pointer that isn't allocated the same way.
+This would let us not only have references to scalars, but might provide
+a way to have scalars that point to non-malloced memory. Hmm. I'll
+have to think about that s'more. You can think about it too.
+
+Larry
#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
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) {
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";
$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/;
}
}
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)/;
! -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.
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; };
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;
}
}
}
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 {
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) . ')' : '';
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~";
# The following takes its argument via $evalarg to preserve current @_
sub eval {
- eval "$usercontext $evalarg; &DB'save";
+ eval "$usercontext $evalarg; &DB::save";
print OUT $@;
}
$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;
while (<TERMCAP>) {
next if /^#/;
next if /^\t/;
- if (/(^|\\|)$TERM[:\\|]/) {
+ if (/(^|\\|)$TERM\[:\\|]/) {
chop;
while (chop eq '\\\\') {
\$_ .= <TERMCAP>;
make: Warning: Both `makefile' and `Makefile' exists
-`sh cflags taint.o` taint.c
+`sh cflags perl.o` perl.c
CCCMD = cc -c -DDEBUGGING -DHAS_SDBM -g
-`sh cflags NDBM_File.o` NDBM_File.c
+`sh cflags op.o` op.c
CCCMD = cc -c -DDEBUGGING -DHAS_SDBM -g
-`sh cflags ODBM_File.o` ODBM_File.c
+`sh cflags mg.o` mg.c
CCCMD = cc -c -DDEBUGGING -DHAS_SDBM -g
-`sh cflags SDBM_File.o` SDBM_File.c
+`sh cflags toke.o` toke.c
CCCMD = cc -c -DDEBUGGING -DHAS_SDBM -g
cc -Bstatic main.o perly.o perl.o av.o scope.o op.o doop.o doio.o dump.o hv.o malloc.o mg.o pp.o regcomp.o regexec.o gv.o sv.o taint.o toke.o util.o deb.o run.o NDBM_File.o ODBM_File.o SDBM_File.o -ldbm -lm -lposix ext/dbm/sdbm/libsdbm.a -o perl
echo "\a"
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;
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;
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;
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;
s = origargv[0]+i;
*s++ = '\0';
while (++i < origalen)
- *s++ = ' ';
+ *s++ = '\0';
+ for (i = 1; i < origargc; i++)
+ origargv[i] = NULL;
}
break;
}
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);
av_store(comppad, off, (SV*)newAV());
else if (*name == '%')
av_store(comppad, off, (SV*)newHV());
+ SvPADMY_on(curpad[off]);
return off;
}
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);
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;
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;
}
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;
}
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;
}
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 ||
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;
}
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);
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);
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;
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);
}
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);
}
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);
}
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);
}
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);
}
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)
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;
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);
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;
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;
}
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;
}
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));
}
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));
}
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));
}
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;
OP *op;
{
register OP *kid;
+ PMOP* pm;
if (op->op_flags & OPf_STACKED)
return no_fh_allowed(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];
/* 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
};
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[];
"private variable",
"private array",
"private hash",
+ "private something",
"push regexp",
"ref-to-glob cast",
"scalar value length",
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));
pp_padsv,
pp_padav,
pp_padhv,
+ pp_padany,
pp_pushre,
pp_rv2gv,
pp_sv2len,
ck_null, /* padsv */
ck_null, /* padav */
ck_null, /* padhv */
+ ck_null, /* padany */
ck_null, /* pushre */
ck_rvconst, /* rv2gv */
ck_null, /* sv2len */
0x00000000, /* padsv */
0x00000000, /* padav */
0x00000000, /* padhv */
+ 0x00000000, /* padany */
0x00000000, /* pushre */
0x00000044, /* rv2gv */
0x0000001c, /* sv2len */
0x0001111d, /* semget */
0x0011111d, /* semctl */
0x0001111d, /* semop */
- 0x00000140, /* require */
+ 0x00000940, /* require */
0x00000140, /* dofile */
0x00000140, /* entereval */
0x00000100, /* leaveeval */
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
# 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
--- /dev/null
+#!./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"
+}
/* Init the real globals? */
if (!linestr) {
linestr = NEWSV(65,80);
+ sv_upgrade(linestr,SVt_PVIV);
SvREADONLY_on(&sv_undef);
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
#endif
#include <errno.h>
+#ifdef HAS_SOCKET
+# ifndef ENOTSOCK
+# include <net/errno.h>
+# endif
+#endif
+
#ifndef MSDOS
# ifndef errno
extern int errno; /* ANSI allows errno to be an lvalue expr */
typedef struct block BLOCK;
typedef struct magic MAGIC;
+typedef struct xrv XRV;
typedef struct xpv XPV;
typedef struct xpviv XPVIV;
typedef struct xpvnv XPVNV;
#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;
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
{
#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)
{
#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)
{
{
#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;
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);
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];
{
#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;
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
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)
{
-*** perly.c.byacc Tue Oct 5 15:44:31 1993
---- perly.c Tue Oct 5 16:23:53 1993
+*** perly.c.orig Fri Jan 14 03:56:26 1994
+--- perly.c Sun Jan 16 18:29:19 1994
***************
-*** 1396,1408 ****
+*** 1635,1647 ****
int yynerrs;
int yyerrflag;
int yychar;
- short yyss[YYSTACKSIZE];
- YYSTYPE yyvs[YYSTACKSIZE];
- #define yystacksize YYSTACKSIZE
- #line 573 "perly.y"
+ #line 605 "perly.y"
/* PROGRAM */
- #line 1409 "y.tab.c"
---- 1396,1403 ----
+ #line 1648 "y.tab.c"
+--- 1635,1642 ----
***************
-*** 1413,1418 ****
---- 1408,1426 ----
+*** 1652,1657 ****
+--- 1647,1665 ----
yyparse()
{
register int yym, yyn, yystate;
register char *yys;
extern char *getenv();
***************
-*** 1429,1434 ****
---- 1437,1450 ----
+*** 1668,1673 ****
+--- 1676,1689 ----
yyerrflag = 0;
yychar = (-1);
yyvsp = yyvs;
*yyssp = yystate = 0;
***************
-*** 1459,1465 ****
+*** 1683,1689 ****
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+ #endif
+--- 1699,1705 ----
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+ #endif
+***************
+*** 1693,1704 ****
+ {
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
---- 1475,1493 ----
+--- 1709,1732 ----
+ {
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
-*** 1500,1506 ****
+*** 1734,1745 ****
+ {
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, error recovery shifting\
+! to state %d\n", *yyssp, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
---- 1528,1548 ----
+--- 1762,1788 ----
+ {
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr,
+! "yydebug: state %d, error recovery shifting to state %d\n",
+! *yyssp, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
-*** 2281,2295 ****
+*** 1749,1756 ****
+ {
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: error recovery discarding state %d\n",
+! *yyssp);
+ #endif
+ if (yyssp <= yyss) goto yyabort;
+ --yyssp;
+--- 1792,1800 ----
+ {
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr,
+! "yydebug: error recovery discarding state %d\n",
+! *yyssp);
+ #endif
+ if (yyssp <= yyss) goto yyabort;
+ --yyssp;
+***************
+*** 1767,1774 ****
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, error recovery discards token %d (%s)\n",
+! yystate, yychar, yys);
+ }
+ #endif
+ yychar = (-1);
+--- 1811,1819 ----
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! fprintf(stderr,
+! "yydebug: state %d, error recovery discards token %d (%s)\n",
+! yystate, yychar, yys);
+ }
+ #endif
+ yychar = (-1);
+***************
+*** 1777,1783 ****
+ yyreduce:
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+ #endif
+ yym = yylen[yyn];
+--- 1822,1828 ----
+ yyreduce:
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+ #endif
+ yym = yylen[yyn];
+***************
+*** 2529,2536 ****
+ {
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: after reduction, shifting from state 0 to\
+! state %d\n", YYFINAL);
+ #endif
+ yystate = YYFINAL;
+ *++yyssp = YYFINAL;
+--- 2574,2582 ----
+ {
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr,
+! "yydebug: after reduction, shifting from state 0 to state %d\n",
+! YYFINAL);
+ #endif
+ yystate = YYFINAL;
+ *++yyssp = YYFINAL;
+***************
+*** 2544,2550 ****
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+ #endif
+--- 2590,2596 ----
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+ #endif
+***************
+*** 2559,2578 ****
+ yystate = yydgoto[yym];
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: after reduction, shifting from state %d \
+! to state %d\n", *yyssp, yystate);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
yyaccept:
! return (0);
}
---- 2323,2357 ----
+--- 2605,2645 ----
+ yystate = yydgoto[yym];
+ #if YYDEBUG
+ if (yydebug)
+! fprintf(stderr,
+! "yydebug: after reduction, shifting from state %d to state %d\n",
+! *yyssp, yystate);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
return pp_rv2hv();
}
+PP(pp_padany)
+{
+ DIE("NOT IMPL LINE %d",__LINE__);
+}
+
PP(pp_pushre)
{
dSP;
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");
}
{
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:
}
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;
}
}
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;
}
}
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;
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;
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);
}
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) {
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;
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;
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);
}
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;
SV *sv = TOPs;
register char *s;
- if (SvSTORAGE(sv) != 'T') {
+ if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
sv = TARG;
SV *sv = TOPs;
register char *s;
- if (SvSTORAGE(sv) != 'T') {
+ if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
sv = TARG;
register char *send;
STRLEN len;
- if (SvSTORAGE(sv) != 'T') {
+ if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
sv = TARG;
register char *send;
STRLEN len;
- if (SvSTORAGE(sv) != 'T') {
+ if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
sv = TARG;
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) {
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);
}
}
}
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) {
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);
}
}
}
*MARK = &sv_undef;
SP = MARK;
}
+ else if (op->op_private & OPpLIST_GUESSED) /* didn't need that pushmark */
+ markstack_ptr--;
RETURN;
}
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;
(void)hv_store(hv,tmps,SvCUROK(key),val,0);
}
SP = ORIGMARK;
+ SvOK_on(hv);
XPUSHs((SV*)hv);
RETURN;
}
EXTEND(sp,2);
gv = 0;
- if (SvTYPE(sv) != SVt_REF) {
+ if (SvROK(sv))
+ ob = SvRV(sv);
+ else {
GV* iogv;
IO* io;
}
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);
}
RETPUSHNO;
sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix];
+ SvTEMP_off(sv);
*cx->blk_loop.itervar = sv ? sv : &sv_undef;
RETPUSHYES;
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);
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 */
}
{
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)
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));
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));
+++ /dev/null
-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;
-}
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();
#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
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;
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);
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;
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;
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;
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);
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;
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)
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);
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
*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;
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)) &&
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;
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)
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);
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
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;
{
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;
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) {
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);
{
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);
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);
{
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;
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;
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)) {
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;
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);
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;
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;
{
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");
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 */
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);
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);
{
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)) {
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;
*gvp = Nullgv;
return Nullcv;
default:
+ if (SvROK(sv))
+ goto is_rv;
if (isGV(sv))
gv = (GV*)sv;
else
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);
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);
+}
typedef enum {
SVt_NULL,
- SVt_REF,
SVt_IV,
SVt_NV,
+ SVt_RV,
SVt_PV,
SVt_PVIV,
SVt_PVNV,
#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 */
#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;
};
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;
};
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? */
};
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;
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)
#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)
#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
--- /dev/null
+#!./perl -Dst
+
+$ref = [[],2,[3,4,5,]];
+print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
$| = 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";}
@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";
+
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";
}
$main'anonhash2 = "foo";
$string = "not ok 34\n";
-sub DESTROY {
+DESTROY {
print $string;
# Test that the object has already been "cursed".
char *what;
{
warn("%s found where operator expected", what);
+ if (bufptr == SvPVX(linestr))
+ warn("\t(Missing semicolon on previous line?)\n", what);
}
void
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))
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 =
if (bufptr == bufend)
return sublex_done();
- if (SvSTORAGE(linestr) == '\'') {
+ if (SvIVX(linestr) == '\'') {
SV *sv = newSVsv(linestr);
if (!lex_inpat)
sv = q(sv);
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('%');
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);
}
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('@');
goto fake_eof;
}
+ case KEY_DESTROY:
case KEY_BEGIN:
case KEY_END:
s = skipspace(s);
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:
break;
}
break;
+ case 'D':
+ if (strEQ(d,"DESTROY")) return KEY_DESTROY;
+ break;
case 'd':
switch (len) {
case 2:
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 (;;) {
*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
#define HAS_PASSWD
#endif
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+# include <signal.h>
+#endif
+
#ifndef SIGABRT
# define SIGABRT SIGILL
#endif
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
projects / p5sagit/p5-mst-13.2.git / commitdiff