-/* $Header: stab.c,v 3.0.1.9 90/10/16 10:32:05 lwall Locked $
+/* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:32:19 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: stab.c,v $
- * Revision 3.0.1.9 90/10/16 10:32:05 lwall
- * patch29: added -M, -A and -C
- * patch29: taintperl now checks for world writable PATH components
- * patch29: *foo now prints as *package'foo
- * patch29: scripts now run at almost full speed under the debugger
- * patch29: package behavior is now more consistent
+ * Revision 4.0.1.4 92/06/08 15:32:19 lwall
+ * patch20: fixed confusion between a *var's real name and its effective name
+ * patch20: the debugger now warns you on lines that can't set a breakpoint
+ * patch20: the debugger made perl forget the last pattern used by //
+ * patch20: paragraph mode now skips extra newlines automatically
+ * patch20: ($<,$>) = ... didn't work on some architectures
*
- * Revision 3.0.1.8 90/08/13 22:30:17 lwall
- * patch28: the NSIG hack didn't work right on Xenix
+ * Revision 4.0.1.3 91/11/05 18:35:33 lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
+ * patch11: *foo = undef coredumped
+ * patch11: solitary subroutine references no longer trigger typo warnings
+ * patch11: local(*FILEHANDLE) had a memory leak
*
- * Revision 3.0.1.7 90/08/09 05:17:48 lwall
- * patch19: fixed double include of <signal.h>
- * patch19: $' broke on embedded nulls
- * patch19: $< and $> better supported on machines without setreuid
- * patch19: Added support for linked-in C subroutines
- * patch19: %ENV wasn't forced to be global like it should
- * patch19: $| didn't work before the filehandle was opened
- * patch19: $! now returns "" in string context if errno == 0
+ * Revision 4.0.1.2 91/06/07 11:55:53 lwall
+ * patch4: new copyright notice
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: $` was busted inside s///
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: $^D |= 1024 now does syntax tree dump at run-time
*
- * Revision 3.0.1.6 90/03/27 16:22:11 lwall
- * patch16: support for machines that can't cast negative floats to unsigned ints
+ * Revision 4.0.1.1 91/04/12 09:10:24 lwall
+ * patch1: Configure now differentiates getgroups() type from getgid() type
+ * patch1: you may now use "die" and "caller" in a signal handler
*
- * Revision 3.0.1.5 90/03/12 17:00:11 lwall
- * patch13: undef $/ didn't work as advertised
- *
- * Revision 3.0.1.4 90/02/28 18:19:14 lwall
- * patch9: $0 is now always the command name
- * patch9: you may now undef $/ to have no input record separator
- * patch9: local($.) didn't work
- * patch9: sometimes perl thought ordinary data was a symbol table entry
- * patch9: stab_array() and stab_hash() weren't defined on MICROPORT
- *
- * Revision 3.0.1.3 89/12/21 20:18:40 lwall
- * patch7: ANSI strerror() is now supported
- * patch7: errno may now be a macro with an lvalue
- * patch7: in stab.c, sighandler() may now return either void or int
- *
- * Revision 3.0.1.2 89/11/17 15:35:37 lwall
- * patch5: sighandler() needed to be static
- *
- * Revision 3.0.1.1 89/11/11 04:55:07 lwall
- * patch2: sys_errlist[sys_nerr] is illegal
- *
- * Revision 3.0 89/10/18 15:23:23 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:39:41 lwall
+ * 4.0 baseline.
*
*/
#define handlertype int
#endif
+static handlertype sighandler();
+
+static int origalen = 0;
+
STR *
stab_str(str)
STR *str;
return stab_val(stab);
switch (*stab->str_magic->str_ptr) {
+ case '\004': /* ^D */
+#ifdef DEBUGGING
+ str_numset(stab_val(stab),(double)(debug & 32767));
+#endif
+ break;
+ case '\006': /* ^F */
+ str_numset(stab_val(stab),(double)maxsysfd);
+ break;
+ case '\t': /* ^I */
+ if (inplace)
+ str_set(stab_val(stab), inplace);
+ else
+ str_sset(stab_val(stab),&str_undef);
+ break;
+ case '\020': /* ^P */
+ str_numset(stab_val(stab),(double)perldb);
+ break;
case '\024': /* ^T */
str_numset(stab_val(stab),(double)basetime);
break;
+ case '\027': /* ^W */
+ str_numset(stab_val(stab),(double)dowarn);
+ break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curspat) {
- paren = atoi(stab_name(stab));
+ paren = atoi(stab_ename(stab));
getparen:
if (curspat->spat_regexp &&
paren <= curspat->spat_regexp->nparens &&
case '`':
if (curspat) {
if (curspat->spat_regexp &&
- (s = curspat->spat_regexp->subbase) ) {
+ (s = curspat->spat_regexp->subbeg) ) {
i = curspat->spat_regexp->startp[0] - s;
if (i >= 0)
str_nset(stab_val(stab),s,i);
break;
case '.':
#ifndef lint
- if (last_in_stab) {
+ if (last_in_stab && stab_io(last_in_stab)) {
str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
}
#endif
break;
case '^':
s = stab_io(curoutstab)->top_name;
- str_set(stab_val(stab),s);
+ if (s)
+ str_set(stab_val(stab),s);
+ else {
+ str_set(stab_val(stab),stab_ename(curoutstab));
+ str_cat(stab_val(stab),"_TOP");
+ }
break;
case '~':
s = stab_io(curoutstab)->fmt_name;
+ if (!s)
+ s = stab_ename(curoutstab);
str_set(stab_val(stab),s);
break;
#ifndef lint
str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
break;
#endif
+ case ':':
+ break;
case '/':
- if (record_separator != 12345) {
- *tokenbuf = record_separator;
- tokenbuf[1] = '\0';
- str_nset(stab_val(stab),tokenbuf,rslen);
- }
break;
case '[':
str_numset(stab_val(stab),(double)arybase);
(void)sprintf(s,"%d",(int)egid);
add_groups:
while (*s) s++;
-#ifdef GETGROUPS
+#ifdef HAS_GETGROUPS
#ifndef NGROUPS
#define NGROUPS 32
#endif
{
- GIDTYPE gary[NGROUPS];
+ GROUPSTYPE gary[NGROUPS];
i = getgroups(NGROUPS,gary);
while (--i >= 0) {
#endif
str_set(stab_val(stab),buf);
break;
+ case '*':
+ break;
+ case '0':
+ break;
default:
{
struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
return stab_val(stab);
}
+STRLEN
+stab_len(str)
+STR *str;
+{
+ STAB *stab = str->str_u.str_stab;
+ int paren;
+ int i;
+ char *s;
+
+ if (str->str_rare)
+ return str_len(stab_val(stab));
+
+ switch (*stab->str_magic->str_ptr) {
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (curspat) {
+ paren = atoi(stab_ename(stab));
+ getparen:
+ if (curspat->spat_regexp &&
+ paren <= curspat->spat_regexp->nparens &&
+ (s = curspat->spat_regexp->startp[paren]) ) {
+ i = curspat->spat_regexp->endp[paren] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '+':
+ if (curspat) {
+ paren = curspat->spat_regexp->lastparen;
+ goto getparen;
+ }
+ break;
+ case '`':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->subbeg) ) {
+ i = curspat->spat_regexp->startp[0] - s;
+ if (i >= 0)
+ return i;
+ else
+ return 0;
+ }
+ else
+ return 0;
+ }
+ break;
+ case '\'':
+ if (curspat) {
+ if (curspat->spat_regexp &&
+ (s = curspat->spat_regexp->endp[0]) ) {
+ return (STRLEN) (curspat->spat_regexp->subend - s);
+ }
+ else
+ return 0;
+ }
+ break;
+ case ',':
+ return (STRLEN)ofslen;
+ case '\\':
+ return (STRLEN)orslen;
+ default:
+ return str_len(stab_str(str));
+ }
+}
+
+void
stabset(mstr,str)
register STR *mstr;
STR *str;
{
- STAB *stab = mstr->str_u.str_stab;
- char *s;
+ STAB *stab;
+ register char *s;
int i;
- static handlertype sighandler();
switch (mstr->str_rare) {
case 'E':
- setenv(mstr->str_ptr,str_get(str));
+ my_setenv(mstr->str_ptr,str_get(str));
/* And you'll never guess what the dog had */
/* in its mouth... */
#ifdef TAINT
case 'S':
s = str_get(str);
i = whichsig(mstr->str_ptr); /* ...no, a brick */
+ if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
+ warn("No such signal: SIG%s", mstr->str_ptr);
if (strEQ(s,"IGNORE"))
#ifndef lint
(void)signal(i,SIG_IGN);
break;
#ifdef SOME_DBM
case 'D':
+ stab = mstr->str_u.str_stab;
hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
break;
#endif
{
CMD *cmd;
+ stab = mstr->str_u.str_stab;
i = str_true(str);
- str = afetch(stab_xarray(stab),atoi(mstr->str_ptr));
- cmd = str->str_magic->str_u.str_cmd;
- cmd->c_flags &= ~CF_OPTIMIZE;
- cmd->c_flags |= i? CFT_D1 : CFT_D0;
+ str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
+ if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) {
+ cmd->c_flags &= ~CF_OPTIMIZE;
+ cmd->c_flags |= i? CFT_D1 : CFT_D0;
+ }
+ else
+ warn("Can't break at that line\n");
}
break;
case '#':
+ stab = mstr->str_u.str_stab;
afill(stab_array(stab), (int)str_gnum(str) - arybase);
break;
case 'X': /* merely a copy of a * string */
break;
case '*':
- s = str_get(str);
+ s = str->str_pok ? str_get(str) : "";
if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
+ stab = mstr->str_u.str_stab;
if (!*s) {
STBP *stbp;
+ /*SUPPRESS 701*/
(void)savenostab(stab); /* schedule a free of this stab */
if (stab->str_len)
Safefree(stab->str_ptr);
strcpy(stab_magic(stab),"StB");
stab_val(stab) = Str_new(70,0);
stab_line(stab) = curcmd->c_line;
+ stab_estab(stab) = stab;
}
else {
stab = stabent(s,TRUE);
if (!stab_io(stab))
stab_io(stab) = stio_new();
}
- str_sset(str,stab);
+ str_sset(str, (STR*) stab);
}
break;
case 's': {
struct lstring *lstr = (struct lstring*)str;
+ char *tmps;
mstr->str_rare = 0;
str->str_magic = Nullstr;
+ tmps = str_get(str);
str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
- str->str_ptr,str->str_cur);
+ tmps,str->str_cur);
}
break;
break;
case 0:
+ /*SUPPRESS 560*/
+ if (!(stab = mstr->str_u.str_stab))
+ break;
switch (*stab->str_magic->str_ptr) {
+ case '\004': /* ^D */
+#ifdef DEBUGGING
+ debug = (int)(str_gnum(str)) | 32768;
+ if (debug & 1024)
+ dump_all();
+#endif
+ break;
+ case '\006': /* ^F */
+ maxsysfd = (int)str_gnum(str);
+ break;
+ case '\t': /* ^I */
+ if (inplace)
+ Safefree(inplace);
+ if (str->str_pok || str->str_nok)
+ inplace = savestr(str_get(str));
+ else
+ inplace = Nullch;
+ break;
+ case '\020': /* ^P */
+ i = (int)str_gnum(str);
+ if (i != perldb) {
+ static SPAT *oldlastspat;
+
+ if (perldb)
+ oldlastspat = lastspat;
+ else
+ lastspat = oldlastspat;
+ }
+ perldb = i;
+ break;
case '\024': /* ^T */
- basetime = (long)str_gnum(str);
+ basetime = (time_t)str_gnum(str);
+ break;
+ case '\027': /* ^W */
+ dowarn = (bool)str_gnum(str);
break;
case '.':
if (localizing)
break;
case '/':
if (str->str_pok) {
- record_separator = *str_get(str);
+ rs = str_get(str);
rslen = str->str_cur;
+ if (rspara = !rslen) {
+ rs = "\n\n";
+ rslen = 2;
+ }
+ rschar = rs[rslen - 1];
}
else {
- record_separator = 12345; /* fake a non-existent char */
+ rschar = 0777; /* fake a non-existent char */
rslen = 1;
}
break;
break;
case '<':
uid = (int)str_gnum(str);
-#ifdef SETREUID
if (delaymagic) {
- delaymagic |= DM_REUID;
+ delaymagic |= DM_RUID;
break; /* don't do magic till later */
}
-#endif /* SETREUID */
-#ifdef SETRUID
- if (setruid((UIDTYPE)uid) < 0)
- uid = (int)getuid();
+#ifdef HAS_SETRUID
+ (void)setruid((UIDTYPE)uid);
#else
-#ifdef SETREUID
- if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
- uid = (int)getuid();
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
#else
if (uid == euid) /* special case $< = $> */
- setuid(uid);
+ (void)setuid(uid);
else
fatal("setruid() not implemented");
#endif
#endif
+ uid = (int)getuid();
break;
case '>':
euid = (int)str_gnum(str);
-#ifdef SETREUID
if (delaymagic) {
- delaymagic |= DM_REUID;
+ delaymagic |= DM_EUID;
break; /* don't do magic till later */
}
-#endif /* SETREUID */
-#ifdef SETEUID
- if (seteuid((UIDTYPE)euid) < 0)
- euid = (int)geteuid();
+#ifdef HAS_SETEUID
+ (void)seteuid((UIDTYPE)euid);
#else
-#ifdef SETREUID
- if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
- euid = (int)geteuid();
+#ifdef HAS_SETREUID
+ (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
#else
if (euid == uid) /* special case $> = $< */
setuid(euid);
fatal("seteuid() not implemented");
#endif
#endif
+ euid = (int)geteuid();
break;
case '(':
gid = (int)str_gnum(str);
-#ifdef SETREGID
if (delaymagic) {
- delaymagic |= DM_REGID;
+ delaymagic |= DM_RGID;
break; /* don't do magic till later */
}
-#endif /* SETREGID */
-#ifdef SETRGID
+#ifdef HAS_SETRGID
(void)setrgid((GIDTYPE)gid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
#else
- fatal("setrgid() not implemented");
+ if (gid == egid) /* special case $( = $) */
+ (void)setgid(gid);
+ else
+ fatal("setrgid() not implemented");
#endif
#endif
+ gid = (int)getgid();
break;
case ')':
egid = (int)str_gnum(str);
-#ifdef SETREGID
if (delaymagic) {
- delaymagic |= DM_REGID;
+ delaymagic |= DM_EGID;
break; /* don't do magic till later */
}
-#endif /* SETREGID */
-#ifdef SETEGID
+#ifdef HAS_SETEGID
(void)setegid((GIDTYPE)egid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
#else
- fatal("setegid() not implemented");
+ if (egid == gid) /* special case $) = $( */
+ (void)setgid(egid);
+ else
+ fatal("setegid() not implemented");
#endif
#endif
+ egid = (int)getegid();
break;
case ':':
chopset = str_get(str);
break;
+ case '0':
+ if (!origalen) {
+ s = origargv[0];
+ s += strlen(s);
+ /* See if all the arguments are contiguous in memory */
+ for (i = 1; i < origargc; i++) {
+ if (origargv[i] == s + 1)
+ s += strlen(++s); /* this one is ok too */
+ }
+ if (origenviron[0] == s + 1) { /* can grab env area too? */
+ my_setenv("NoNeSuCh", Nullch);
+ /* force copy of environment */
+ for (i = 0; origenviron[i]; i++)
+ if (origenviron[i] == s + 1)
+ s += strlen(++s);
+ }
+ origalen = s - origargv[0];
+ }
+ s = str_get(str);
+ i = str->str_cur;
+ if (i >= origalen) {
+ i = origalen;
+ str->str_cur = i;
+ str->str_ptr[i] = '\0';
+ Copy(s, origargv[0], i, char);
+ }
+ else {
+ Copy(s, origargv[0], i, char);
+ s = origargv[0]+i;
+ *s++ = '\0';
+ while (++i < origalen)
+ *s++ = ' ';
+ }
+ break;
default:
{
struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
}
}
+int
whichsig(sig)
char *sig;
{
int sig;
{
STAB *stab;
- ARRAY *savearray;
STR *str;
- CMD *oldcurcmd = curcmd;
int oldsave = savestack->ary_fill;
- ARRAY *oldstack = stack;
- CSV *oldcurcsv = curcsv;
+ int oldtmps_base = tmps_base;
+ register CSV *csv;
SUBR *sub;
#ifdef OS2 /* or anybody else who requires SIG_ACK */
signal(sig, SIG_ACK);
#endif
- curcsv = Nullcsv;
stab = stabent(
str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
TRUE)), TRUE);
if (!sub) {
if (dowarn)
warn("SIG%s handler \"%s\" not defined.\n",
- sig_name[sig], stab_name(stab) );
+ sig_name[sig], stab_ename(stab) );
return;
}
- savearray = stab_xarray(defstab);
- stab_xarray(defstab) = stack = anew(defstab);
+ /*SUPPRESS 701*/
+ saveaptr(&stack);
+ str = Str_new(15, sizeof(CSV));
+ str->str_state = SS_SCSV;
+ (void)apush(savestack,str);
+ csv = (CSV*)str->str_ptr;
+ csv->sub = sub;
+ csv->stab = stab;
+ csv->curcsv = curcsv;
+ csv->curcmd = curcmd;
+ csv->depth = sub->depth;
+ csv->wantarray = G_SCALAR;
+ csv->hasargs = TRUE;
+ csv->savearray = stab_xarray(defstab);
+ csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
stack->ary_flags = 0;
- str = Str_new(71,0);
+ curcsv = csv;
+ str = str_mortal(&str_undef);
str_set(str,sig_name[sig]);
(void)apush(stab_xarray(defstab),str);
sub->depth++;
if (sub->depth >= 2) { /* save temporaries on recursion? */
if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
+ warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
}
- (void)cmd_exec(sub->cmd,G_SCALAR,1); /* so do it already */
-
- sub->depth--; /* assuming no longjumps out of here */
- str_free(stack->ary_array[0]); /* free the one real string */
- afree(stab_xarray(defstab)); /* put back old $_[] */
- stab_xarray(defstab) = savearray;
- stack = oldstack;
- if (savestack->ary_fill > oldsave)
- restorelist(oldsave);
- curcmd = oldcurcmd;
- curcsv = oldcurcsv;
+ tmps_base = tmps_max; /* protect our mortal string */
+ (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */
+ tmps_base = oldtmps_base;
+
+ restorelist(oldsave); /* put everything back */
}
STAB *
char *prevquote = Nullch;
bool global = FALSE;
- if (isascii(*name) && isupper(*name)) {
+ if (isUPPER(*name)) {
if (*name > 'I') {
if (*name == 'S' && (
strEQ(name, "SIG") ||
sawquote = Nullch;
name++;
}
- else if (!isalpha(*name) || global)
+ else if (!isALPHA(*name) || global)
stash = defstash;
- else if (curcmd == &compiling)
+ else if ((CMD*)curcmd == &compiling)
stash = curstash;
else
stash = curcmd->c_stash;
char *s, *d;
*sawquote = '\0';
+ /*SUPPRESS 560*/
if (s = prevquote) {
strncpy(tmpbuf,name,s-name+1);
d = tmpbuf+(s-name+1);
strcpy(stab_magic(stab),"StB");
stab_val(stab) = Str_new(72,0);
stab_line(stab) = curcmd->c_line;
- str_magic(stab,stab,'*',name,len);
+ stab_estab(stab) = stab;
+ str_magic((STR*)stab, stab, '*', name, len);
stab_stash(stab) = stash;
+ if (isDIGIT(*name) && *name != '0') {
+ stab_flags(stab) = SF_VMAGIC;
+ str_magic(stab_val(stab), stab, 0, Nullch, 0);
+ }
+ if (add & 2)
+ stab->str_pok |= SP_MULTI;
return stab;
}
}
+void
stab_fullname(str,stab)
STR *str;
STAB *stab;
{
- str_set(str,stab_stash(stab)->tbl_name);
+ HASH *tb = stab_stash(stab);
+
+ if (!tb)
+ return;
+ str_set(str,tb->tbl_name);
str_ncat(str,"'", 1);
str_scat(str,stab->str_magic);
}
+void
+stab_efullname(str,stab)
+STR *str;
+STAB *stab;
+{
+ HASH *tb = stab_estash(stab);
+
+ if (!tb)
+ return;
+ str_set(str,tb->tbl_name);
+ str_ncat(str,"'", 1);
+ str_scat(str,stab_estab(stab)->str_magic);
+}
+
STIO *
stio_new()
{
return stio;
}
+void
stab_check(min,max)
int min;
register int max;
STIO *stio;
SUBR *sub;
+ if (!stab || !stab->str_ptr)
+ return;
afree(stab_xarray(stab));
+ stab_xarray(stab) = Null(ARRAY*);
(void)hfree(stab_xhash(stab), FALSE);
+ stab_xhash(stab) = Null(HASH*);
str_free(stab_val(stab));
+ stab_val(stab) = Nullstr;
+ /*SUPPRESS 560*/
if (stio = stab_io(stab)) {
do_close(stab,FALSE);
Safefree(stio->top_name);
Safefree(stio->fmt_name);
+ Safefree(stio);
}
+ /*SUPPRESS 560*/
if (sub = stab_sub(stab)) {
afree(sub->tosave);
cmd_free(sub->cmd);
projects / p5sagit/p5-mst-13.2.git / blobdiff