See patch #29.
-/*
- * 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 <os2.h>
+/*
+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 <stdio.h>
+#include <stdlib.h>
+#include <io.h>
+#include <string.h>
+#include <process.h>
+#include <errno.h>
+
+#define INCL_NOPM
+#define INCL_DOS
+#include <os2.h>
+
+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;
}
--- /dev/null
+extproc perl -x
+#!perl
+
+printf "
+This is a self-running perl script using the
+extproc feature of the OS/2 command processor.
+"
-#define PATCHLEVEL 33
+#define PATCHLEVEL 34
* 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
*
{
register regexp *r;
register char *scan;
- register STR *longest;
+ register STR *longish;
+ STR *longest;
register int len;
register char *first;
int flags;
* 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;
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);
}
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);
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? */
#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)");
* 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+$/
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) {
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. */
}
break;
case ALNUM:
- while (isALNUM(*scan))
+ while (scan < loceol && isALNUM(*scan))
scan++;
break;
case NALNUM:
scan++;
break;
case DIGIT:
- while (isDIGIT(*scan))
+ while (scan < loceol && isDIGIT(*scan))
scan++;
break;
case NDIGIT:
-/* $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
*
* 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
*
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) {
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;
}
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 */
#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;
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);
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;
}
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);
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 */
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 *
}
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;
}
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;
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;
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()
{
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);
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>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
#
$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/) {
}
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++;
$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) {
} else {
$lastlinewaslabel = '';
}
+
+ # Look for one or two address clauses
+
$addr1 = '';
$addr2 = '';
if (s/^([0-9]+)//) {
$addr1 = 'eof()';
}
elsif (s|^/||) {
- $addr1 = do fetchpat('/');
+ $addr1 = &fetchpat('/');
}
if (s/^,//) {
if (s/^([0-9]+)//) {
} 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;
} 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;
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 (<body>) {
- 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 (<BODY>) {
+ 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 (<body>) {
+EOT
+ open(BODY,"cc -E /tmp/sperl2$$.c |") ||
+ &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
/^# [0-9]/ && next;
/^[ \t]*$/ && next;
s/^<><>//;
}
}
-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;
}
{ # 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;
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]*//;
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]*//;
if ($change) {
$dseen++;
$change = "$_\n";
- $_ = "
+ chop($_ = <<"EOT");
<<--#ifdef PRINTIT
$space\$printit = '';
<<--#endif
-${space}next line;";
+${space}next LINE;
+EOT
}
last;
}
$c = substr($_,$i,1);
if ($c eq $delim) {
if ($inbracket) {
- $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+ substr($_, $i, 0) = '\\';
$i++;
$len++;
}
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';
}
}
$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/\$/\\$/;
$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;
}
if (/^w/) {
s/^w[ \t]*//;
- $fh = do make_filehandle($_);
+ $fh = &make_filehandle($_);
$_ = "print $fh \$_;";
next;
}
}
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;
}
}
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;";
}
}
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;
}
if (/^q/) {
- $_ =
-'close(ARGV);
+ chop($_ = <<'EOT');
+close(ARGV);
@ARGV = ();
-next line;';
+next LINE;
+EOT
next;
}
} continue {
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 '\\') {
$addr .= $prefix;
$addr .= $delim;
if ($delim eq $outer && !$inbracket) {
- last delim;
+ last DELIM;
}
}
$addr;
projects / p5sagit/p5-mst-13.2.git / commitdiff