From: Larry Wall Date: Mon, 15 Oct 1990 23:06:41 +0000 (+0000) Subject: perl 3.0 patch #34 patch #29, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a12ae7dee71b6eb0609c35185096ab75c95b2da;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #34 patch #29, continued See patch #29. --- diff --git a/os2/popen.c b/os2/popen.c index 7c71ccc..15c1112 100644 --- a/os2/popen.c +++ b/os2/popen.c @@ -1,210 +1,237 @@ -/* - * Pipe support for OS/2. - * - * WARNING: I am guilty of chumminess with the runtime library because - * I had no choice. Details to follow. - * +/* added real/protect mode branch at runtime and real mode version + * names changed for perl + * Kai Uwe Rommel */ -#include "EXTERN.h" -#include "perl.h" -#define INCL_DOSPROCESS -#define INCL_DOSQUEUES -#define INCL_DOSMISC -#define INCL_DOSMEMMGR -#include +/* +Several people in the past have asked about having Unix-like pipe +calls in OS/2. The following source file, adapted from 4.3 BSD Unix, +uses a #define to give you a pipe(2) call, and contains function +definitions for popen(3) and pclose(3). Anyone with problems should +send mail to me; they seem to work fine. -extern char **environ; +Mark Towfigh +Racal Interlan, Inc. +----------------------------------cut-here------------------------------------ +*/ -/* This mysterious array _osfile is used internally by the runtime - * library to remember assorted things about open file handles. - * The problem is that we are creating file handles via DosMakePipe, - * rather than via the runtime library. This means that we have - * to fake the runtime library into thinking that the handles we've - * created are honest file handles. So just before doing the fdopen, - * we poke in a magic value that fools the library functions into - * thinking that the handle is already open in text mode. +/* + * The following code segment is derived from BSD 4.3 Unix. See + * copyright below. Any bugs, questions, improvements, or problems + * should be sent to Mark Towfigh (towfiq@interlan.interlan.com). * - * This might not work for your compiler, so beware. + * Racal InterLan Inc. */ -extern char _osfile[]; -/* The maximum number of simultaneously open pipes. We create an - * array of this size to record information about each open pipe. +/* + * Copyright (c) 1980 Regents of the University of California. + * All rights reserved. The Berkeley software License Agreement + * specifies the terms and conditions for redistribution. */ -#define MAXPIPES 5 -/* Information to remember about each open pipe. - * The (FILE *) that popen returns is stored because that's the only - * way we can keep track of the pipes. +#include +#include +#include +#include +#include +#include + +#define INCL_NOPM +#define INCL_DOS +#include + +static FILE *dos_popen(const char *cmd, const char *flags); +static int dos_pclose(FILE *pipe); + +/* + * emulate Unix pipe(2) call */ -typedef struct pipeinfo { - FILE *pfId; /* Which FILE we're talking about */ - HFILE hfMe; /* handle I should close at pclose */ - PID pidChild; /* Child's PID */ - CHAR fReading; /* A read or write pipe? */ -} PIPEINFO, *PPIPEINFO; /* pi and ppi */ -static PIPEINFO PipeInfo[MAXPIPES]; +#define tst(a,b) (*mode == 'r'? (b) : (a)) +#define READH 0 +#define WRITEH 1 + +static int popen_pid[20]; -FILE *mypopen(const char *command, const char *t) +FILE *mypopen(char *cmd, char *mode) { - typedef char *PSZZ; - PSZZ pszzPipeArgs = 0; - PSZZ pszzEnviron = 0; - PSZ *ppsz; - PSZ psz; - FILE *f; - HFILE hfMe, hfYou; - HFILE hf, hfSave; - RESULTCODES rc; - USHORT us; - PPIPEINFO ppi; - UINT i; - - /* Validate pipe type */ - if (*t != 'w' && *t != 'r') fatal("Unknown pipe type"); - - /* Room for another pipe? */ - for (ppi = &PipeInfo[0]; ppi < &PipeInfo[MAXPIPES]; ppi++) - if (ppi->pfId == 0) goto foundone; - return NULL; - -foundone: - - /* Make the pipe */ - if (DosMakePipe(&hfMe, &hfYou, 0)) return NULL; - - /* Build the environment. First compute its length, then copy - * the environment strings into it. - */ - i = 0; - for (ppsz = environ; *ppsz; ppsz++) i += 1 + strlen(*ppsz); - New(1204, pszzEnviron, 1+i, CHAR); - - psz = pszzEnviron; - for (ppsz = environ; *ppsz; ppsz++) { - strcpy(psz, *ppsz); - psz += 1 + strlen(*ppsz); + int p[2]; + register myside, hisside, save_stream; + char *shell = getenv("COMPSPEC"); + + if ( shell == NULL ) + shell = "C:\\OS2\\CMD.EXE"; + + if ( _osmode == DOS_MODE ) + return dos_popen(cmd, mode); + + if (DosMakePipe((PHFILE) &p[0], (PHFILE) &p[1], 4096) < 0) + return NULL; + + myside = tst(p[WRITEH], p[READH]); + hisside = tst(p[READH], p[WRITEH]); + + /* set up file descriptors for remote function */ + save_stream = dup(tst(0, 1)); /* don't lose stdin/out! */ + if (dup2(hisside, tst(0, 1)) < 0) + { + perror("dup2"); + return NULL; } - *psz = 0; + close(hisside); - /* Build the command string to execute. - * 6 = length(0 "/c " 0 0) + /* + * make sure that we can close our side of the pipe, by + * preventing it from being inherited! */ - if (DosScanEnv("COMSPEC", &psz)) psz = "C:\\OS2\\cmd.exe"; -#if 0 - New(1203, pszzPipeArgs, strlen(psz) + strlen(command) + 6, CHAR); -#else -#define pszzPipeArgs buf -#endif - sprintf(pszzPipeArgs, "%s%c/c %s%c", psz, 0, command, 0); - - /* Now some stuff that depends on what kind of pipe we're doing. - * We pull a sneaky trick; namely, that stdin = 0 = false, - * and stdout = 1 = true. The end result is that if the - * pipe is a read pipe, then hf = 1; if it's a write pipe, then - * hf = 0 and Me and You are reversed. - */ - if (!(hf = (*t == 'r'))) { - /* The meaning of Me and You is reversed for write pipes. */ - hfSave = hfYou; hfYou = hfMe; hfMe = hfSave; - } - ppi->fReading = hf; + /* set no-inheritance flag */ + DosSetFHandState(myside, OPEN_FLAGS_NOINHERIT); - /* Trick number 1: Fooling the runtime library into thinking - * that the file handle is legit. - * - * Trick number 2: Don't let my handle go over to the child! - * Since the child never closes it (why should it?), I'd better - * make sure he never sees it in the first place. Otherwise, - * we are in deadlock city. - */ - _osfile[hfMe] = 0x81; /* Danger, Will Robinson! */ - if (!(ppi->pfId = fdopen(hfMe, t))) goto no_fdopen; - DosSetFHandState(hfMe, OPEN_FLAGS_NOINHERIT); + /* execute the command: it will inherit our other file descriptors */ + popen_pid[myside] = spawnlp(P_NOWAIT, shell, shell, "/C", cmd, NULL); + + /* now restore our previous file descriptors */ + if (dup2(save_stream, tst(0, 1)) < 0) /* retrieve stdin/out */ + { + perror("dup2"); + return NULL; + } + close(save_stream); - /* Save the original handle because we're going to diddle it */ - hfSave = 0xFFFF; - if (DosDupHandle(hf, &hfSave)) goto no_dup_init; + return fdopen(myside, mode); /* return a FILE pointer */ +} - /* Force the child's handle onto the stdio handle */ - if (DosDupHandle(hfYou, &hf)) goto no_force_dup; - DosClose(hfYou); +int mypclose(FILE *ptr) +{ + register f; + int status; - /* Now run the guy servicing the pipe */ - us = DosExecPgm(NULL, 0, EXEC_ASYNCRESULT, pszzPipeArgs, pszzEnviron, - &rc, pszzPipeArgs); + if ( _osmode == DOS_MODE ) + return dos_pclose(ptr); - /* Restore stdio handle, even if exec failed. */ - DosDupHandle(hfSave, &hf); close(hfSave); + f = fileno(ptr); + fclose(ptr); - /* See if the exec succeeded. */ - if (us) goto no_exec_pgm; + /* wait for process to terminate */ + cwait(&status, popen_pid[f], WAIT_GRANDCHILD); - /* Remember the child's PID */ - ppi->pidChild = rc.codeTerminate; + return status; +} - Safefree(pszzEnviron); - /* Phew. */ - return ppi->pfId; +int pipe(int *filedes) +{ + int res; + + if ( res = DosMakePipe((PHFILE) &filedes[0], (PHFILE) &filedes[1], 4096) ) + return res; - /* Here is where we clean up after an error. */ -no_exec_pgm: ; -no_force_dup: close(hfSave); -no_dup_init: fclose(f); -no_fdopen: - DosClose(hfMe); DosClose(hfYou); - ppi->pfId = 0; - Safefree(pszzEnviron); - return NULL; + DosSetFHandState(filedes[0], OPEN_FLAGS_NOINHERIT); + DosSetFHandState(filedes[1], OPEN_FLAGS_NOINHERIT); + return 0; } -/* mypclose: Closes the pipe associated with the file handle. - * After waiting for the child process to terminate, its return - * code is returned. If the stream was not associated with a pipe, - * we return -1. - */ -int -mypclose(FILE *f) +/* this is the MS-DOS version */ + +typedef enum { unopened = 0, reading, writing } pipemode; + +static struct { - PPIPEINFO ppi; - RESULTCODES rc; - USHORT us; - - /* Find the pipe this (FILE *) refers to */ - for (ppi = &PipeInfo[0]; ppi < &PipeInfo[MAXPIPES]; ppi++) - if (ppi->pfId == f) goto foundit; - return -1; -foundit: - if (ppi->fReading && !DosRead(fileno(f), &rc, 1, &us) && us > 0) { - DosKillProcess(DKP_PROCESSTREE, ppi->pidChild); - } - fclose(f); - DosCwait(DCWA_PROCESS, DCWW_WAIT, &rc, &ppi->pidChild, ppi->pidChild); - ppi->pfId = 0; - return rc.codeResult; + char *name; + char *command; + pipemode pmode; } +pipes[_NFILE]; -/* pipe: The only tricky thing is letting the runtime library know about - * our two new file descriptors. - */ -int pipe(int filedes[2]) +static FILE *dos_popen(const char *command, const char *mode) { - HFILE hfRead, hfWrite; - USHORT usResult; - - usResult = DosMakePipe(&hfRead, &hfWrite, 0); - if (usResult) { - /* Error 4 == ERROR_TOO_MANY_OPEN_FILES */ - errno = (usResult == 4) ? ENFILE : ENOMEM; - return -1; - } - _osfile[hfRead] = _osfile[hfWrite] = 0x81;/* Danger, Will Robinson! */ - filedes[0] = hfRead; - filedes[1] = hfWrite; - return 0; + FILE *current; + char name[128]; + int cur; + pipemode curmode; + + /* + ** decide on mode. + */ + if(strchr(mode, 'r') != NULL) + curmode = reading; + else if(strchr(mode, 'w') != NULL) + curmode = writing; + else + return NULL; + + /* + ** get a name to use. + */ + strcpy(name, "piXXXXXX"); + Mktemp(name); + + /* + ** If we're reading, just call system to get a file filled with + ** output. + */ + if(curmode == reading) + { + char cmd[256]; + sprintf(cmd,"%s > %s", command, name); + system(cmd); + + if((current = fopen(name, mode)) == NULL) + return NULL; + } + else + { + if((current = fopen(name, mode)) == NULL) + return NULL; + } + + cur = fileno(current); + pipes[cur].name = strdup(name); + pipes[cur].command = strdup(command); + pipes[cur].pmode = curmode; + + return current; +} + +static int dos_pclose(FILE * current) +{ + int cur = fileno(current), rval; + char command[256]; + + /* + ** check for an open file. + */ + if(pipes[cur].pmode == unopened) + return -1; + + if(pipes[cur].pmode == reading) + { + /* + ** input pipes are just files we're done with. + */ + rval = fclose(current); + unlink(pipes[cur].name); + } + else + { + /* + ** output pipes are temporary files we have + ** to cram down the throats of programs. + */ + fclose(current); + sprintf(command,"%s < %s", pipes[cur].command, pipes[cur].name); + rval = system(command); + unlink(pipes[cur].name); + } + + /* + ** clean up current pipe. + */ + free(pipes[cur].name); + free(pipes[cur].command); + pipes[cur].pmode = unopened; + + return rval; } diff --git a/os2/selfrun.cmd b/os2/selfrun.cmd new file mode 100644 index 0000000..471a959 --- /dev/null +++ b/os2/selfrun.cmd @@ -0,0 +1,7 @@ +extproc perl -x +#!perl + +printf " +This is a self-running perl script using the +extproc feature of the OS/2 command processor. +" diff --git a/patchlevel.h b/patchlevel.h index 1d5b76f..3b47b47 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 33 +#define PATCHLEVEL 34 diff --git a/regcomp.c b/regcomp.c index e3ef1ba..04d62c3 100644 --- a/regcomp.c +++ b/regcomp.c @@ -7,9 +7,12 @@ * blame Henry for some of the lack of readability. */ -/* $Header: regcomp.c,v 3.0.1.5 90/08/13 22:23:29 lwall Locked $ +/* $Header: regcomp.c,v 3.0.1.6 90/10/16 10:17:33 lwall Locked $ * * $Log: regcomp.c,v $ + * Revision 3.0.1.6 90/10/16 10:17:33 lwall + * patch29: patterns with multiple short literal strings sometimes failed + * * Revision 3.0.1.5 90/08/13 22:23:29 lwall * patch28: /x{m}/ didn't work right * @@ -138,7 +141,8 @@ int fold; { register regexp *r; register char *scan; - register STR *longest; + register STR *longish; + STR *longest; register int len; register char *first; int flags; @@ -241,6 +245,7 @@ int fold; * it happens that curback has been invalidated, since the * earlier string may buy us something the later one won't.] */ + longish = str_make("",0); longest = str_make("",0); len = 0; curback = 0; @@ -260,7 +265,7 @@ int fold; while (OP(regnext(scan)) >= CLOSE) scan = regnext(scan); if (curback - back == len) { - str_ncat(longest, OPERAND(first)+1, + str_ncat(longish, OPERAND(first)+1, *OPERAND(first)); len += *OPERAND(first); curback += *OPERAND(first); @@ -268,7 +273,7 @@ int fold; } else if (*OPERAND(first) >= len + (curback >= 0)) { len = *OPERAND(first); - str_nset(longest, OPERAND(first)+1,len); + str_nset(longish, OPERAND(first)+1,len); back = curback; curback += len; first = regnext(scan); @@ -276,18 +281,27 @@ int fold; else curback += *OPERAND(first); } - else if (index(varies,OP(scan))) - curback = -30000; + else if (index(varies,OP(scan))) { + curback = -30000; + len = 0; + if (longish->str_cur > longest->str_cur) + str_sset(longest,longish); + str_nset(longish,"",0); + } else if (index(simple,OP(scan))) - curback++; + curback++; scan = regnext(scan); } - if (len) { + if (longish->str_cur > longest->str_cur) + str_sset(longest,longish); + str_free(longish); + if (longest->str_cur) { r->regmust = longest; if (back < 0) back = -1; r->regback = back; - if (len > !(sawstudy||fold||OP(first)==EOL)) + if (longest->str_cur + > !(sawstudy || fold || OP(first) == EOL) ) fbmcompile(r->regmust,fold); r->regmust->str_u.str_useful = 100; if (OP(first) == EOL) /* is match anchored to EOL? */ @@ -1123,6 +1137,8 @@ regexp *r; #endif op = OP(s); fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */ + if (op == CURLY) + s += 4; next = regnext(s); if (next == NULL) /* Next ptr. */ fprintf(stderr,"(0)"); diff --git a/regexec.c b/regexec.c index 61439ea..b0b8fa1 100644 --- a/regexec.c +++ b/regexec.c @@ -7,9 +7,14 @@ * blame Henry for some of the lack of readability. */ -/* $Header: regexec.c,v 3.0.1.4 90/08/09 05:12:03 lwall Locked $ +/* $Header: regexec.c,v 3.0.1.5 90/10/16 10:25:36 lwall Locked $ * * $Log: regexec.c,v $ + * Revision 3.0.1.5 90/10/16 10:25:36 lwall + * patch29: /^pat/ occasionally matched in middle of string when $* = 0 + * patch29: /.{n,m}$/ could match with fewer than n characters remaining + * patch29: /\d{9}/ could match more than 9 characters + * * Revision 3.0.1.4 90/08/09 05:12:03 lwall * patch19: sped up /x+y/ patterns greatly by not retrying on every x * patch19: inhibited backoff on patterns anchored to the end like /\s+$/ @@ -139,8 +144,11 @@ int safebase; /* no need to remember string in subbase */ if (string == strbeg) /* is ^ valid at stringarg? */ regprev = '\n'; - else + else { regprev = stringarg[-1]; + if (!multiline && regprev == '\n') + regprev = '\0'; /* force ^ to NOT match */ + } regprecomp = prog->precomp; /* Check validity of program. */ if (UCHARAT(prog->program) != MAGIC) { @@ -771,7 +779,7 @@ char *prog; nextchar = -1000; reginput = locinput; n = regrepeat(scan, n); - if (!multiline && OP(next) == EOL) + if (!multiline && OP(next) == EOL && ln < n) ln = n; /* why back off? */ while (n >= ln) { /* If it could work, try it. */ @@ -845,7 +853,7 @@ int max; } break; case ALNUM: - while (isALNUM(*scan)) + while (scan < loceol && isALNUM(*scan)) scan++; break; case NALNUM: @@ -861,7 +869,7 @@ int max; scan++; break; case DIGIT: - while (isDIGIT(*scan)) + while (scan < loceol && isDIGIT(*scan)) scan++; break; case NDIGIT: diff --git a/stab.c b/stab.c index 00cee82..f968dfc 100644 --- a/stab.c +++ b/stab.c @@ -1,4 +1,4 @@ -/* $Header: stab.c,v 3.0.1.8 90/08/13 22:30:17 lwall Locked $ +/* $Header: stab.c,v 3.0.1.9 90/10/16 10:32:05 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,13 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $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 3.0.1.8 90/08/13 22:30:17 lwall * patch28: the NSIG hack didn't work right on Xenix * @@ -77,6 +84,9 @@ STR *str; return stab_val(stab); switch (*stab->str_magic->str_ptr) { + case '\024': /* ^T */ + str_numset(stab_val(stab),(double)basetime); + break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (curspat) { @@ -220,7 +230,7 @@ STR *str; struct ufuncs *uf = (struct ufuncs *)str->str_ptr; if (uf && uf->uf_val) - uf->uf_val(uf->uf_index, stab_val(stab)); + (*uf->uf_val)(uf->uf_index, stab_val(stab)); } break; } @@ -240,7 +250,22 @@ STR *str; case 'E': setenv(mstr->str_ptr,str_get(str)); /* And you'll never guess what the dog had */ - break; /* in its mouth... */ + /* in its mouth... */ +#ifdef TAINT + if (strEQ(mstr->str_ptr,"PATH")) { + char *strend = str->str_ptr + str->str_cur; + + s = str->str_ptr; + while (s < strend) { + s = cpytill(tokenbuf,s,strend,':',&i); + s++; + if (*tokenbuf != '/' + || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) + str->str_tainted = 2; + } + } +#endif + break; case 'S': s = str_get(str); i = whichsig(mstr->str_ptr); /* ...no, a brick */ @@ -252,14 +277,30 @@ STR *str; #endif else if (strEQ(s,"DEFAULT") || !*s) (void)signal(i,SIG_DFL); - else + else { (void)signal(i,sighandler); + if (!index(s,'\'')) { + sprintf(tokenbuf, "main'%s",s); + str_set(str,tokenbuf); + } + } break; #ifdef SOME_DBM case 'D': hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str); break; #endif + case 'L': + { + CMD *cmd; + + 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; + } + break; case '#': afill(stab_array(stab), (int)str_gnum(str) - arybase); break; @@ -310,6 +351,9 @@ STR *str; case 0: switch (*stab->str_magic->str_ptr) { + case '\024': /* ^T */ + basetime = (long)str_gnum(str); + break; case '.': if (localizing) savesptr((STR**)&last_in_stab); @@ -473,7 +517,7 @@ STR *str; struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr; if (uf && uf->uf_set) - uf->uf_set(uf->uf_index, str); + (*uf->uf_set)(uf->uf_index, str); } break; } @@ -507,14 +551,16 @@ int sig; STAB *stab; ARRAY *savearray; STR *str; - char *oldfile = filename; + CMD *oldcurcmd = curcmd; int oldsave = savestack->ary_fill; ARRAY *oldstack = stack; + CSV *oldcurcsv = curcsv; 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); @@ -546,7 +592,6 @@ int sig; warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); savelist(sub->tosave->ary_array,sub->tosave->ary_fill); } - filename = sub->filename; (void)cmd_exec(sub->cmd,G_SCALAR,1); /* so do it already */ @@ -555,9 +600,10 @@ int sig; afree(stab_xarray(defstab)); /* put back old $_[] */ stab_xarray(defstab) = savearray; stack = oldstack; - filename = oldfile; if (savestack->ary_fill > oldsave) restorelist(oldsave); + curcmd = oldcurcmd; + curcsv = oldcurcsv; } STAB * @@ -579,6 +625,21 @@ register STAB *stab; } STAB * +fstab(name) +char *name; +{ + char tmpbuf[1200]; + STAB *stab; + + sprintf(tmpbuf,"'_<%s", name); + stab = stabent(tmpbuf, TRUE); + str_set(stab_val(stab), name); + if (perldb) + (void)hadd(aadd(stab)); + return stab; +} + +STAB * stabent(name,add) register char *name; int add; @@ -625,8 +686,10 @@ int add; } else if (!isalpha(*name) || global) stash = defstash; - else + else if (curcmd == &compiling) stash = curstash; + else + stash = curcmd->c_stash; if (sawquote) { char tmpbuf[256]; char *s, *d; @@ -645,12 +708,14 @@ int add; stab = stabent(tmpbuf,TRUE); if (!(stash = stab_xhash(stab))) stash = stab_xhash(stab) = hnew(0); + if (!stash->tbl_name) + stash->tbl_name = savestr(name); name = sawquote+1; *sawquote = '\''; } len = namend - name; stab = (STAB*)hfetch(stash,name,len,add); - if (!stab) + if (stab == (STAB*)&str_undef) return Nullstab; if (stab->str_pok) { stab->str_pok |= SP_MULTI; @@ -667,10 +732,20 @@ int add; stab_val(stab) = Str_new(72,0); stab_line(stab) = curcmd->c_line; str_magic(stab,stab,'*',name,len); + stab_stash(stab) = stash; return stab; } } +stab_fullname(str,stab) +STR *str; +STAB *stab; +{ + str_set(str,stab_stash(stab)->tbl_name); + str_ncat(str,"'", 1); + str_scat(str,stab->str_magic); +} + STIO * stio_new() { @@ -719,7 +794,7 @@ register STAB *stab; SUBR *sub; afree(stab_xarray(stab)); - (void)hfree(stab_xhash(stab)); + (void)hfree(stab_xhash(stab), FALSE); str_free(stab_val(stab)); if (stio = stab_io(stab)) { do_close(stab,FALSE); diff --git a/x2p/s2p.SH b/x2p/s2p.SH index 66d7b72..553cfd6 100644 --- a/x2p/s2p.SH +++ b/x2p/s2p.SH @@ -28,9 +28,12 @@ $spitshell >s2p <>s2p <<'!NO!SUBS!' -# $Header: s2p.SH,v 3.0.1.4 90/08/09 05:50:43 lwall Locked $ +# $Header: s2p.SH,v 3.0.1.5 90/10/16 11:32:40 lwall Locked $ # # $Log: s2p.SH,v $ +# Revision 3.0.1.5 90/10/16 11:32:40 lwall +# patch29: s2p modernized +# # Revision 3.0.1.4 90/08/09 05:50:43 lwall # patch19: s2p didn't translate \n right # @@ -59,14 +62,13 @@ $spitshell >>s2p <<'!NO!SUBS!' $indent = 4; $shiftwidth = 4; $l = '{'; $r = '}'; -$tempvar = '1'; -while ($ARGV[0] =~ '^-') { +while ($ARGV[0] =~ /^-/) { $_ = shift; last if /^--/; if (/^-D/) { $debug++; - open(body,'>-'); + open(BODY,'>-'); next; } if (/^-n/) { @@ -81,25 +83,27 @@ while ($ARGV[0] =~ '^-') { } unless ($debug) { - open(body,">/tmp/sperl$$") || do Die("Can't open temp file"); + open(BODY,">/tmp/sperl$$") || + &Die("Can't open temp file: $!\n"); } if (!$assumen && !$assumep) { - print body -'while ($ARGV[0] =~ /^-/) { + print BODY <<'EOT'; +while ($ARGV[0] =~ /^-/) { $_ = shift; last if /^--/; if (/^-n/) { $nflag++; next; } - die "I don\'t recognize this switch: $_\\n"; + die "I don't recognize this switch: $_\\n"; } -'; +EOT } -print body ' +print BODY <<'EOT'; + #ifdef PRINTIT #ifdef ASSUMEP $printit++; @@ -107,21 +111,27 @@ $printit++; $printit++ unless $nflag; #endif #endif -line: while (<>) { -'; +LINE: while (<>) { +EOT + +LINE: while (<>) { + + # Wipe out surrounding whitespace. -line: while (<>) { s/[ \t]*(.*)\n$/$1/; + + # Perhaps it's a label/comment. + if (/^:/) { s/^:[ \t]*//; - $label = do make_label($_); + $label = &make_label($_); if ($. == 1) { $toplabel = $label; } $_ = "$label:"; if ($lastlinewaslabel++) { $indent += 4; - print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; + print BODY &tab, ";\n"; $indent -= 4; } if ($indent >= 2) { @@ -132,6 +142,9 @@ line: while (<>) { } else { $lastlinewaslabel = ''; } + + # Look for one or two address clauses + $addr1 = ''; $addr2 = ''; if (s/^([0-9]+)//) { @@ -141,7 +154,7 @@ line: while (<>) { $addr1 = 'eof()'; } elsif (s|^/||) { - $addr1 = do fetchpat('/'); + $addr1 = &fetchpat('/'); } if (s/^,//) { if (s/^([0-9]+)//) { @@ -149,14 +162,18 @@ line: while (<>) { } elsif (s/^\$//) { $addr2 = "eof()"; } elsif (s|^/||) { - $addr2 = do fetchpat('/'); + $addr2 = &fetchpat('/'); } else { - do Die("Invalid second address at line $.\n"); + &Die("Invalid second address at line $.\n"); } $addr1 .= " .. $addr2"; } - # a { to keep vi happy + + # Now we check for metacommands {, }, and ! and worry + # about indentation. + s/^[ \t]+//; + # a { to keep vi happy if ($_ eq '}') { $indent -= 4; next; @@ -180,55 +197,59 @@ line: while (<>) { } else { $space = ''; } - $_ = do transmogrify(); + $_ = &transmogrify(); } + # See if we can optimize to modifier form. + if ($addr1) { if ($_ !~ /[\n{}]/ && $rmaybe && !$change && $_ !~ / if / && $_ !~ / unless /) { s/;$/ $if $addr1;/; $_ = substr($_,$shiftwidth,1000); } else { - $command = $_; - $_ = "$if ($addr1) $l\n$change$command$rmaybe"; + $_ = "$if ($addr1) $l\n$change$_$rmaybe"; } $change = ''; - next line; + next LINE; } } continue { @lines = split(/\n/,$_); - while ($#lines >= 0) { - $_ = shift(lines); + for (@lines) { unless (s/^ *<<--//) { - print body "\t" x ($indent / 8), ' ' x ($indent % 8); + print BODY &tab; } - print body $_, "\n"; + print BODY $_, "\n"; } $indent += $indmod; $indmod = 0; if ($redo) { $_ = $redo; $redo = ''; - redo line; + redo LINE; } } if ($lastlinewaslabel++) { $indent += 4; - print body "\t" x ($indent / 8), ' ' x ($indent % 8), ";\n"; + print BODY &tab, ";\n"; $indent -= 4; } -print body "}\n"; +print BODY "}\n"; if ($appendseen || $tseen || !$assumen) { $printit++ if $dseen || (!$assumen && !$assumep); - print body ' + print BODY <<'EOT'; + continue { #ifdef PRINTIT #ifdef DSEEN #ifdef ASSUMEP print if $printit++; #else - if ($printit) { print;} else { $printit++ unless $nflag; } + if ($printit) + { print; } + else + { $printit++ unless $nflag; } #endif #else print if $printit; @@ -237,40 +258,43 @@ continue { print; #endif #ifdef TSEEN - $tflag = \'\'; + $tflag = ''; #endif #ifdef APPENDSEEN - if ($atext) { print $atext; $atext = \'\'; } + if ($atext) { print $atext; $atext = ''; } #endif } -'; +EOT } -close body; +close BODY; unless ($debug) { - open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2"); - print head "#define PRINTIT\n" if ($printit); - print head "#define APPENDSEEN\n" if ($appendseen); - print head "#define TSEEN\n" if ($tseen); - print head "#define DSEEN\n" if ($dseen); - print head "#define ASSUMEN\n" if ($assumen); - print head "#define ASSUMEP\n" if ($assumep); - if ($opens) {print head "$opens\n";} - open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file"); - while () { - print head $_; + open(HEAD,">/tmp/sperl2$$.c") + || &Die("Can't open temp file 2: $!\n"); + print HEAD "#define PRINTIT\n" if ($printit); + print HEAD "#define APPENDSEEN\n" if ($appendseen); + print HEAD "#define TSEEN\n" if ($tseen); + print HEAD "#define DSEEN\n" if ($dseen); + print HEAD "#define ASSUMEN\n" if ($assumen); + print HEAD "#define ASSUMEP\n" if ($assumep); + if ($opens) {print HEAD "$opens\n";} + open(BODY,"/tmp/sperl$$") + || &Die("Can't reopen temp file: $!\n"); + while () { + print HEAD $_; } - close head; + close HEAD; - print "#!$bin/perl -eval \"exec $bin/perl -S \$0 \$*\" + print <<"EOT"; +#!$bin/perl +eval 'exec $bin/perl -S \$0 \$*' if \$running_under_some_shell; -"; - open(body,"cc -E /tmp/sperl2$$.c |") || - do Die("Can't reopen temp file"); - while () { +EOT + open(BODY,"cc -E /tmp/sperl2$$.c |") || + &Die("Can't reopen temp file: $!\n"); + while () { /^# [0-9]/ && next; /^[ \t]*$/ && next; s/^<><>//; @@ -278,39 +302,44 @@ eval \"exec $bin/perl -S \$0 \$*\" } } -unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; +&Cleanup; +exit; +sub Cleanup { + chdir "/tmp"; + unlink "sperl$$", "sperl2$$", "sperl2$$.c"; +} sub Die { - unlink "/tmp/sperl$$", "/tmp/sperl2$$", "/tmp/sperl2$$.c"; + &Cleanup; die $_[0]; } +sub tab { + "\t" x ($indent / 8) . ' ' x ($indent % 8); +} sub make_filehandle { - $fname = $_ = $_[0]; + local($_) = $_[0]; + local($fname) = $_; s/[^a-zA-Z]/_/g; s/^_*//; - if (/^([a-z])([a-z]*)$/) { - $first = $1; - $rest = $2; - $first =~ y/a-z/A-Z/; - $_ = $first . $rest; - } + substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/; if (!$seen{$_}) { - $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n"; + $opens .= <<"EOT"; +open($_,'>$fname') || die "Can't create $fname"; +EOT } $seen{$_} = $_; } sub make_label { - $label = $_[0]; + local($label) = @_; $label =~ s/[^a-zA-Z0-9]/_/g; if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } $label = substr($label,0,8); - if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word - $first = $1; - $rest = $2; - $first =~ y/a-z/A-Z/; # so capitalize it - $label = $first . $rest; - } + + # Could be a reserved word, so capitalize it. + substr($label,0,1) =~ y/a-z/A-Z/ + if $label =~ /^[a-z]/; + $label; } @@ -318,22 +347,26 @@ sub transmogrify { { # case if (/^d/) { $dseen++; - $_ = ' + chop($_ = <<'EOT'); <<--#ifdef PRINTIT -$printit = \'\'; +$printit = ''; <<--#endif -next line;'; +next LINE; +EOT next; } if (/^n/) { - $_ = -'<<--#ifdef PRINTIT + chop($_ = <<'EOT'); +<<--#ifdef PRINTIT <<--#ifdef DSEEN <<--#ifdef ASSUMEP print if $printit++; <<--#else -if ($printit) { print;} else { $printit++ unless $nflag; } +if ($printit) + { print; } +else + { $printit++ unless $nflag; } <<--#endif <<--#else print if $printit; @@ -342,18 +375,19 @@ print if $printit; print; <<--#endif <<--#ifdef APPENDSEEN -if ($atext) {print $atext; $atext = \'\';} +if ($atext) {print $atext; $atext = '';} <<--#endif $_ = <>; <<--#ifdef TSEEN -$tflag = \'\'; -<<--#endif'; +$tflag = ''; +<<--#endif +EOT next; } if (/^a/) { $appendseen++; - $command = $space . '$atext .=' . "\n<<--'"; + $command = $space . '$atext .=' . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; @@ -372,7 +406,8 @@ $tflag = \'\'; if (/^[ic]/) { if (/^c/) { $change = 1; } $addr1 = '$iter = (' . $addr1 . ')'; - $command = $space . 'if ($iter == 1) { print' . "\n<<--'"; + $command = $space . 'if ($iter == 1) { print' + . "\n<<--'"; $lastline = 0; while (<>) { s/^[ \t]*//; @@ -388,11 +423,12 @@ $tflag = \'\'; if ($change) { $dseen++; $change = "$_\n"; - $_ = " + chop($_ = <<"EOT"); <<--#ifdef PRINTIT $space\$printit = ''; <<--#endif -${space}next line;"; +${space}next LINE; +EOT } last; } @@ -406,7 +442,7 @@ ${space}next line;"; $c = substr($_,$i,1); if ($c eq $delim) { if ($inbracket) { - $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); + substr($_, $i, 0) = '\\'; $i++; $len++; } @@ -430,12 +466,14 @@ ${space}next line;"; elsif (substr($_,$i,1) =~ /^[n]$/) { ; } - elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) { + elsif (!$repl && + substr($_,$i,1) =~ /^[(){}\w]$/) { $i--; $len--; - $_ = substr($_,0,$i) . substr($_,$i+1,10000); + substr($_, $i, 1) = ''; } - elsif (!$repl && substr($_,$i,1) =~ /^[<>]$/) { + elsif (!$repl && + substr($_,$i,1) =~ /^[<>]$/) { substr($_,$i,1) = 'b'; } } @@ -448,14 +486,15 @@ ${space}next line;"; $inbracket = 0; } elsif (!$repl && index("()+",$c) >= 0) { - $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000); + substr($_, $i, 0) = '\\'; $i++; $len++; } } - do Die("Malformed substitution at line $.\n") unless $end; + &Die("Malformed substitution at line $.\n") + unless $end; $pat = substr($_, 0, $repl + 1); - $repl = substr($_, $repl + 1, $end - $repl - 1); + $repl = substr($_, $repl+1, $end-$repl-1); $end = substr($_, $end + 1, 1000); $dol = '$'; $repl =~ s/\$/\\$/; @@ -464,22 +503,30 @@ ${space}next line;"; $subst = "$pat$repl$delim"; $cmd = ''; while ($end) { - if ($end =~ s/^g//) { $subst .= 'g'; next; } - if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; } + if ($end =~ s/^g//) { + $subst .= 'g'; + next; + } + if ($end =~ s/^p//) { + $cmd .= ' && (print)'; + next; + } if ($end =~ s/^w[ \t]*//) { - $fh = do make_filehandle($end); + $fh = &make_filehandle($end); $cmd .= " && (print $fh \$_)"; $end = ''; next; } - do Die("Unrecognized substitution command ($end) at line $.\n"); + &Die("Unrecognized substitution command". + "($end) at line $.\n"); } - $_ = -"<<--#ifdef TSEEN + chop ($_ = <<"EOT"); +<<--#ifdef TSEEN $subst && \$tflag++$cmd; <<--#else $subst$cmd; -<<--#endif"; +<<--#endif +EOT next; } @@ -490,7 +537,7 @@ $subst$cmd; if (/^w/) { s/^w[ \t]*//; - $fh = do make_filehandle($_); + $fh = &make_filehandle($_); $_ = "print $fh \$_;"; next; } @@ -509,19 +556,21 @@ $subst$cmd; } if (/^D/) { - $_ = -'s/^.*\n//; -redo line if $_; -next line;'; + chop($_ = <<'EOT'); +s/^.*\n//; +redo LINE if $_; +next LINE; +EOT next; } if (/^N/) { - $_ = ' + chop($_ = <<'EOT'); $_ .= <>; <<--#ifdef TSEEN -$tflag = \'\'; -<<--#endif'; +$tflag = ''; +<<--#endif +EOT next; } @@ -551,15 +600,15 @@ $tflag = \'\'; } if (/^b$/) { - $_ = 'next line;'; + $_ = 'next LINE;'; next; } if (/^b/) { s/^b[ \t]*//; - $lab = do make_label($_); + $lab = &make_label($_); if ($lab eq $toplabel) { - $_ = 'redo line;'; + $_ = 'redo LINE;'; } else { $_ = "goto $lab;"; } @@ -567,18 +616,19 @@ $tflag = \'\'; } if (/^t$/) { - $_ = 'next line if $tflag;'; + $_ = 'next LINE if $tflag;'; $tseen++; next; } if (/^t/) { s/^t[ \t]*//; - $lab = do make_label($_); + $lab = &make_label($_); + $_ = q/if ($tflag) {$tflag = ''; /; if ($lab eq $toplabel) { - $_ = 'if ($tflag) {$tflag = \'\'; redo line;}'; + $_ .= 'redo LINE;}'; } else { - $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}"; + $_ .= "goto $lab;}"; } $tseen++; next; @@ -590,10 +640,11 @@ $tflag = \'\'; } if (/^q/) { - $_ = -'close(ARGV); + chop($_ = <<'EOT'); +close(ARGV); @ARGV = (); -next line;'; +next LINE; +EOT next; } } continue { @@ -612,7 +663,9 @@ sub fetchpat { local($inbracket); local($prefix,$delim,$ch); - delim: while (s:^([^\]+(|)[\\/]*)([]+(|)[\\/])::) { + # Process pattern one potential delimiter at a time. + + DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { $prefix = $1; $delim = $2; if ($delim eq '\\') { @@ -636,7 +689,7 @@ sub fetchpat { $addr .= $prefix; $addr .= $delim; if ($delim eq $outer && !$inbracket) { - last delim; + last DELIM; } } $addr;