summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--h2pl/eg/sysexits.pl16
-rw-r--r--h2pl/tcbreak17
-rw-r--r--h2pl/tcbreak217
-rw-r--r--lib/stat.pl4
-rw-r--r--lib/syslog.pl5
-rw-r--r--lib/termcap.pl6
-rw-r--r--os2/eg/syscalls.pl16
-rw-r--r--os2/suffix.c146
-rw-r--r--patchlevel.h2
-rw-r--r--stab.h7
-rw-r--r--str.c82
-rw-r--r--str.h22
-rw-r--r--toke.c234
13 files changed, 439 insertions, 135 deletions
diff --git a/h2pl/eg/sysexits.pl b/h2pl/eg/sysexits.pl
new file mode 100644
index 0000000000..f4cb777ee9
--- /dev/null
+++ b/h2pl/eg/sysexits.pl
@@ -0,0 +1,16 @@
+$EX_OK = 0x0;
+$EX__BASE = 0x40;
+$EX_USAGE = 0x40;
+$EX_DATAERR = 0x41;
+$EX_NOINPUT = 0x42;
+$EX_NOUSER = 0x43;
+$EX_NOHOST = 0x44;
+$EX_UNAVAILABLE = 0x45;
+$EX_SOFTWARE = 0x46;
+$EX_OSERR = 0x47;
+$EX_OSFILE = 0x48;
+$EX_CANTCREAT = 0x49;
+$EX_IOERR = 0x4A;
+$EX_TEMPFAIL = 0x4B;
+$EX_PROTOCOL = 0x4C;
+$EX_NOPERM = 0x4D;
diff --git a/h2pl/tcbreak b/h2pl/tcbreak
new file mode 100644
index 0000000000..2677cc982b
--- /dev/null
+++ b/h2pl/tcbreak
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/h2pl/tcbreak2 b/h2pl/tcbreak2
new file mode 100644
index 0000000000..fcbf926516
--- /dev/null
+++ b/h2pl/tcbreak2
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak2.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/lib/stat.pl b/lib/stat.pl
index 8cf0bde193..df9e1dba5b 100644
--- a/lib/stat.pl
+++ b/lib/stat.pl
@@ -1,6 +1,7 @@
-;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $
+;# $Header: stat.pl,v 3.0.1.1 90/08/09 04:01:34 lwall Locked $
;# Usage:
+;# require 'stat.pl';
;# @ary = stat(foo);
;# $st_dev = @ary[$ST_DEV];
;#
@@ -19,6 +20,7 @@ $ST_BLKSIZE = 11 + $[;
$ST_BLOCKS = 12 + $[;
;# Usage:
+;# require 'stat.pl';
;# do Stat('foo'); # sets st_* as a side effect
;#
sub Stat {
diff --git a/lib/syslog.pl b/lib/syslog.pl
index 46c8c86eda..c98baf32e3 100644
--- a/lib/syslog.pl
+++ b/lib/syslog.pl
@@ -8,7 +8,7 @@
# call syslog() with a string priority and a list of printf() args
# like syslog(3)
#
-# usage: do 'syslog.pl' || die "syslog.pl: $@";
+# usage: require 'syslog.pl';
#
# then (put these all in a script to test function)
#
@@ -29,8 +29,7 @@ package syslog;
$host = 'localhost' unless $host; # set $syslog'host to change
-do '/usr/local/lib/perl/syslog.h'
- || die "syslog: Can't do syslog.h: ",($@||$!),"\n";
+require 'syslog.ph';
sub main'openlog {
($ident, $logopt, $facility) = @_; # package vars
diff --git a/lib/termcap.pl b/lib/termcap.pl
index 35b5ec0655..d64852667c 100644
--- a/lib/termcap.pl
+++ b/lib/termcap.pl
@@ -1,10 +1,10 @@
-;# $Header: termcap.pl,v 3.0.1.2 90/03/14 12:28:28 lwall Locked $
+;# $Header: termcap.pl,v 3.0.1.3 90/08/09 04:02:53 lwall Locked $
;#
;# Usage:
-;# do 'ioctl.pl';
+;# require 'ioctl.pl';
;# ioctl(TTY,$TIOCGETP,$foo);
;# ($ispeed,$ospeed) = unpack('cc',$foo);
-;# do 'termcap.pl' || die "Can't get termcap.pl";
+;# require 'termcap.pl';
;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
diff --git a/os2/eg/syscalls.pl b/os2/eg/syscalls.pl
new file mode 100644
index 0000000000..2356f2e478
--- /dev/null
+++ b/os2/eg/syscalls.pl
@@ -0,0 +1,16 @@
+# OS/2 syscall values
+
+$OS2_GetVersion = 0;
+$OS2_Shutdown = 1;
+$OS2_Beep = 2;
+$OS2_PhysicalDisk = 3;
+$OS2_Config = 4;
+$OS2_IOCtl = 5;
+$OS2_QCurDisk = 6;
+$OS2_SelectDisk = 7;
+$OS2_SetMaxFH = 8;
+$OS2_Sleep = 9;
+$OS2_StartSession = 10;
+$OS2_StopSession = 11;
+$OS2_SelectSession = 12;
+1;
diff --git a/os2/suffix.c b/os2/suffix.c
new file mode 100644
index 0000000000..2dbb02b525
--- /dev/null
+++ b/os2/suffix.c
@@ -0,0 +1,146 @@
+/*
+ * Suffix appending for in-place editing under MS-DOS and OS/2.
+ *
+ * Here are the rules:
+ *
+ * Style 0: Append the suffix exactly as standard perl would do it.
+ * If the filesystem groks it, use it. (HPFS will always
+ * grok it. FAT will rarely accept it.)
+ *
+ * Style 1: The suffix begins with a '.'. The extension is replaced.
+ * If the name matches the original name, use the fallback method.
+ *
+ * Style 2: The suffix is a single character, not a '.'. Try to add the
+ * suffix to the following places, using the first one that works.
+ * [1] Append to extension.
+ * [2] Append to filename,
+ * [3] Replace end of extension,
+ * [4] Replace end of filename.
+ * If the name matches the original name, use the fallback method.
+ *
+ * Style 3: Any other case: Ignore the suffix completely and use the
+ * fallback method.
+ *
+ * Fallback method: Change the extension to ".$$$". If that matches the
+ * original name, then change the extension to ".~~~".
+ *
+ * If filename is more than 1000 characters long, we die a horrible
+ * death. Sorry.
+ *
+ * The filename restriction is a cheat so that we can use buf[] to store
+ * assorted temporary goo.
+ *
+ * Examples, assuming style 0 failed.
+ *
+ * suffix = ".bak" (style 1)
+ * foo.bar => foo.bak
+ * foo.bak => foo.$$$ (fallback)
+ * foo.$$$ => foo.~~~ (fallback)
+ * makefile => makefile.bak
+ *
+ * suffix = "~" (style 2)
+ * foo.c => foo.c~
+ * foo.c~ => foo.c~~
+ * foo.c~~ => foo~.c~~
+ * foo~.c~~ => foo~~.c~~
+ * foo~~~~~.c~~ => foo~~~~~.$$$ (fallback)
+ *
+ * foo.pas => foo~.pas
+ * makefile => makefile.~
+ * longname.fil => longname.fi~
+ * longname.fi~ => longnam~.fi~
+ * longnam~.fi~ => longnam~.$$$
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#ifdef OS2
+#define INCL_DOSFILEMGR
+#define INCL_DOSERRORS
+#include <os2.h>
+#endif /* OS2 */
+
+static char suffix1[] = ".$$$";
+static char suffix2[] = ".~~~";
+
+#define ext (&buf[1000])
+
+add_suffix(str,suffix)
+register STR *str;
+register char *suffix;
+{
+ int baselen;
+ int extlen;
+ char *s, *t, *p;
+ STRLEN slen;
+
+ if (!(str->str_pok)) (void)str_2ptr(str);
+ if (str->str_cur > 1000)
+ fatal("Cannot do inplace edit on long filename (%d characters)", str->str_cur);
+
+#ifdef OS2
+ /* Style 0 */
+ slen = str->str_cur;
+ str_cat(str, suffix);
+ if (valid_filename(str->str_ptr)) return;
+
+ /* Fooey, style 0 failed. Fix str before continuing. */
+ str->str_ptr[str->str_cur = slen] = '\0';
+#endif /* OS2 */
+
+ slen = strlen(suffix);
+ t = buf; baselen = 0; s = str->str_ptr;
+ while ( (*t = *s) && *s != '.') {
+ baselen++;
+ if (*s == '\\' || *s == '/') baselen = 0;
+ s++; t++;
+ }
+ p = t;
+
+ t = ext; extlen = 0;
+ while (*t++ = *s++) extlen++;
+ if (extlen == 0) { ext[0] = '.'; ext[1] = 0; extlen++; }
+
+ if (*suffix == '.') { /* Style 1 */
+ if (strEQ(ext, suffix)) goto fallback;
+ strcpy(p, suffix);
+ } else if (suffix[1] == '\0') { /* Style 2 */
+ if (extlen < 4) {
+ ext[extlen] = *suffix;
+ ext[++extlen] = '\0';
+ } else if (baselen < 8) {
+ *p++ = *suffix;
+ } else if (ext[3] != *suffix) {
+ ext[3] = *suffix;
+ } else if (buf[7] != *suffix) {
+ buf[7] = *suffix;
+ } else goto fallback;
+ strcpy(p, ext);
+ } else { /* Style 3: Panic */
+fallback:
+ (void)bcopy(strEQ(ext, suffix1) ? suffix2 : suffix1, p, 4+1);
+ }
+ str_set(str, buf);
+}
+
+#ifdef OS2
+int
+valid_filename(s)
+char *s;
+{
+ HFILE hf;
+ USHORT usAction;
+
+ switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN,
+ OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) {
+ case NO_ERROR:
+ DosClose(hf);
+ /*FALLTHROUGH*/
+ default:
+ return 1;
+ case ERROR_FILENAME_EXCED_RANGE:
+ return 0;
+ }
+}
+#endif /* OS2 */
diff --git a/patchlevel.h b/patchlevel.h
index 10c8c21b10..9705476214 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 25
+#define PATCHLEVEL 26
diff --git a/stab.h b/stab.h
index db2d60c36f..aeb7133700 100644
--- a/stab.h
+++ b/stab.h
@@ -1,4 +1,4 @@
-/* $Header: stab.h,v 3.0.1.2 90/03/12 17:00:43 lwall Locked $
+/* $Header: stab.h,v 3.0.1.3 90/08/09 05:18:42 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
@@ -6,6 +6,9 @@
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: stab.h,v $
+ * Revision 3.0.1.3 90/08/09 05:18:42 lwall
+ * patch19: Added support for linked-in C subroutines
+ *
* Revision 3.0.1.2 90/03/12 17:00:43 lwall
* patch13: did some ndir straightening up for Xenix
*
@@ -88,6 +91,8 @@ struct stio {
struct sub {
CMD *cmd;
+ int (*usersub)();
+ int userindex;
char *filename;
long depth; /* >= 2 indicates recursive call */
ARRAY *tosave;
diff --git a/str.c b/str.c
index 324e10065c..0b6dfea697 100644
--- a/str.c
+++ b/str.c
@@ -1,4 +1,4 @@
-/* $Header: str.c,v 3.0.1.7 90/03/27 16:24:11 lwall Locked $
+/* $Header: str.c,v 3.0.1.8 90/08/09 05:22:18 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
@@ -6,6 +6,10 @@
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.c,v $
+ * Revision 3.0.1.8 90/08/09 05:22:18 lwall
+ * patch19: the number to string converter wasn't allocating enough space
+ * patch19: tainting didn't work on setgid scripts
+ *
* Revision 3.0.1.7 90/03/27 16:24:11 lwall
* patch16: strings with prefix chopped off sometimes freed wrong
* patch16: taint check blows up on undefined array element
@@ -97,10 +101,20 @@ STR *Str;
char *
str_grow(str,newlen)
register STR *str;
+#ifndef MSDOS
register int newlen;
+#else
+unsigned long newlen;
+#endif
{
register char *s = str->str_ptr;
+#ifdef MSDOS
+ if (newlen >= 0x10000) {
+ fprintf(stderr, "Allocation too large: %lx\n", newlen);
+ exit(1);
+ }
+#endif /* MSDOS */
if (str->str_state == SS_INCR) { /* data before str_ptr? */
str->str_len += str->str_u.str_useful;
str->str_ptr -= str->str_u.str_useful;
@@ -129,7 +143,7 @@ double num;
if (str->str_pok) {
str->str_pok = 0; /* invalidate pointer */
if (str->str_state == SS_INCR)
- str_grow(str,0);
+ Str_Grow(str,0);
}
str->str_u.str_nval = num;
str->str_state = SS_NORM;
@@ -149,15 +163,7 @@ register STR *str;
if (!str)
return "";
if (str->str_nok) {
-/* this is a problem on the sun 4... 24 bytes is not always enough and the
- exponent blows away the malloc stack
- PEJ Wed Jan 31 18:41:34 CST 1990
-*/
-#ifdef sun4
STR_GROW(str, 30);
-#else
- STR_GROW(str, 24);
-#endif /* sun 4 */
s = str->str_ptr;
olderrno = errno; /* some Xenix systems wipe out errno here */
#if defined(scs) && defined(ns32000)
@@ -182,11 +188,7 @@ register STR *str;
return No;
if (dowarn)
warn("Use of uninitialized variable");
-#ifdef sun4
STR_GROW(str, 30);
-#else
- STR_GROW(str, 24);
-#endif
s = str->str_ptr;
}
*s = '\0';
@@ -206,7 +208,7 @@ register STR *str;
if (!str)
return 0.0;
if (str->str_state == SS_INCR)
- str_grow(str,0); /* just force copy down */
+ Str_Grow(str,0); /* just force copy down */
str->str_state = SS_NORM;
if (str->str_len && str->str_pok)
str->str_u.str_nval = atof(str->str_ptr);
@@ -257,7 +259,7 @@ register STR *sstr;
str_numset(dstr,sstr->str_u.str_nval);
else {
if (dstr->str_state == SS_INCR)
- str_grow(dstr,0); /* just force copy down */
+ Str_Grow(dstr,0); /* just force copy down */
#ifdef STRUCTCOPY
dstr->str_u = sstr->str_u;
@@ -271,7 +273,7 @@ register STR *sstr;
str_nset(str,ptr,len)
register STR *str;
register char *ptr;
-register int len;
+register STRLEN len;
{
STR_GROW(str, len + 1);
if (ptr)
@@ -289,7 +291,7 @@ str_set(str,ptr)
register STR *str;
register char *ptr;
{
- register int len;
+ register STRLEN len;
if (!ptr)
ptr = "";
@@ -308,7 +310,7 @@ str_chop(str,ptr) /* like set but assuming ptr is in str */
register STR *str;
register char *ptr;
{
- register int delta;
+ register STRLEN delta;
if (!(str->str_pok))
fatal("str_chop: internal inconsistency");
@@ -329,7 +331,7 @@ register char *ptr;
str_ncat(str,ptr,len)
register STR *str;
register char *ptr;
-register int len;
+register STRLEN len;
{
if (!(str->str_pok))
(void)str_2ptr(str);
@@ -363,7 +365,7 @@ str_cat(str,ptr)
register STR *str;
register char *ptr;
{
- register int len;
+ register STRLEN len;
if (!ptr)
return;
@@ -389,7 +391,7 @@ register int delim;
char *keeplist;
{
register char *to;
- register int len;
+ register STRLEN len;
if (!from)
return Nullch;
@@ -427,7 +429,7 @@ int x;
#else
str_new(len)
#endif
-int len;
+STRLEN len;
{
register STR *str;
@@ -451,7 +453,7 @@ register STR *str;
STAB *stab;
int how;
char *name;
-int namlen;
+STRLEN namlen;
{
if (str->str_magic)
return;
@@ -466,10 +468,10 @@ int namlen;
void
str_insert(bigstr,offset,len,little,littlelen)
STR *bigstr;
-int offset;
-int len;
+STRLEN offset;
+STRLEN len;
char *little;
-int littlelen;
+STRLEN littlelen;
{
register char *big;
register char *mid;
@@ -549,9 +551,9 @@ register STR *str;
register STR *nstr;
{
if (str->str_state == SS_INCR)
- str_grow(str,0); /* just force copy down */
+ Str_Grow(str,0); /* just force copy down */
if (nstr->str_state == SS_INCR)
- str_grow(nstr,0);
+ Str_Grow(nstr,0);
if (str->str_ptr)
Safefree(str->str_ptr);
str->str_ptr = nstr->str_ptr;
@@ -616,6 +618,7 @@ register STR *str;
#endif /* LEAKTEST */
}
+STRLEN
str_len(str)
register STR *str;
{
@@ -690,8 +693,8 @@ int append;
register STDCHAR *ptr; /* in the innermost loop into registers */
register int newline = record_separator;/* (assuming >= 6 registers) */
int i;
- int bpx;
- int obpx;
+ STRLEN bpx;
+ STRLEN obpx;
register int get_paragraph;
register char *oldbp;
@@ -786,9 +789,8 @@ STR *str;
{
register CMD *cmd;
register ARG *arg;
- line_t oldline = line;
+ CMD *oldcurcmd = curcmd;
int retval;
- char *tmps;
str_sset(linestr,str);
in_eval++;
@@ -812,14 +814,17 @@ STR *str;
}
#ifdef DEBUGGING
if (debug & 4) {
- tmps = loop_stack[loop_ptr].loop_label;
+ char *tmps = loop_stack[loop_ptr].loop_label;
deb("(Popping label #%d %s)\n",loop_ptr,
tmps ? tmps : "" );
}
#endif
loop_ptr--;
error_count = 0;
+ curcmd = &compiling;
+ curcmd->c_line = oldcurcmd->c_line;
retval = yyparse();
+ curcmd = oldcurcmd;
in_eval--;
if (retval || error_count)
fatal("Invalid component in string or format");
@@ -828,7 +833,6 @@ STR *str;
if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST)
fatal("panic: error in parselist %d %x %d", cmd->c_type,
cmd->c_next, arg ? arg->arg_type : -1);
- line = oldline;
Safefree(cmd);
return arg;
}
@@ -842,7 +846,7 @@ STR *src;
register STR *str;
register char *t;
STR *toparse;
- int len;
+ STRLEN len;
register int brackets;
register char *d;
STAB *stab;
@@ -1222,7 +1226,7 @@ register STR *str;
STR *
str_make(s,len)
char *s;
-int len;
+STRLEN len;
{
register STR *str = Str_new(79,0);
@@ -1257,7 +1261,7 @@ register STR *old;
return Nullstr;
}
if (old->str_state == SS_INCR && !(old->str_pok & 2))
- str_grow(old,0);
+ Str_Grow(old,0);
if (new->str_ptr)
Safefree(new->str_ptr);
Copy(old,new,1,STR);
@@ -1328,7 +1332,7 @@ char *s;
if (debug & 2048)
fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid);
#endif
- if (tainted && (!euid || euid != uid)) {
+ if (tainted && (!euid || euid != uid || egid != gid)) {
if (!unsafe)
fatal("%s", s);
else if (dowarn)
diff --git a/str.h b/str.h
index 2c14029c7e..cdc3d586b5 100644
--- a/str.h
+++ b/str.h
@@ -1,4 +1,4 @@
-/* $Header: str.h,v 3.0.1.1 89/10/26 23:24:42 lwall Locked $
+/* $Header: str.h,v 3.0.1.2 90/08/09 05:23:24 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
@@ -6,6 +6,9 @@
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: str.h,v $
+ * Revision 3.0.1.2 90/08/09 05:23:24 lwall
+ * patch19: various MSDOS and OS/2 patches folded in
+ *
* Revision 3.0.1.1 89/10/26 23:24:42 lwall
* patch1: rearranged some structures to align doubles better on Gould
*
@@ -16,7 +19,7 @@
struct string {
char * str_ptr; /* pointer to malloced string */
- int str_len; /* allocated size */
+ STRLEN str_len; /* allocated size */
union {
double str_nval; /* numeric value, if any */
STAB *str_stab; /* magic stab for magic "key" string */
@@ -25,8 +28,8 @@ struct string {
HASH *str_hash; /* string represents an assoc array (stab?) */
ARRAY *str_array; /* string represents an array */
} str_u;
- int str_cur; /* length of str_ptr as a C string */
- STR *str_magic; /* while free, link to next free str */
+ STRLEN str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
/* while in use, ptr to "key" for magic items */
char str_pok; /* state of str_ptr */
char str_nok; /* state of str_nval */
@@ -40,7 +43,7 @@ struct string {
struct stab { /* should be identical, except for str_ptr */
STBP * str_ptr; /* pointer to malloced string */
- int str_len; /* allocated size */
+ STRLEN str_len; /* allocated size */
union {
double str_nval; /* numeric value, if any */
STAB *str_stab; /* magic stab for magic "key" string */
@@ -49,8 +52,8 @@ struct stab { /* should be identical, except for str_ptr */
HASH *str_hash; /* string represents an assoc array (stab?) */
ARRAY *str_array; /* string represents an array */
} str_u;
- int str_cur; /* length of str_ptr as a C string */
- STR *str_magic; /* while free, link to next free str */
+ STRLEN str_cur; /* length of str_ptr as a C string */
+ STR *str_magic; /* while free, link to next free str */
/* while in use, ptr to "key" for magic items */
char str_pok; /* state of str_ptr */
char str_nok; /* state of str_nval */
@@ -66,8 +69,8 @@ struct stab { /* should be identical, except for str_ptr */
struct lstring {
struct string lstr;
- int lstr_offset;
- int lstr_len;
+ STRLEN lstr_offset;
+ STRLEN lstr_len;
};
/* These are the values of str_pok: */
@@ -127,3 +130,4 @@ int str_cmp();
int str_eq();
void str_magic();
void str_insert();
+STRLEN str_len();
diff --git a/toke.c b/toke.c
index 40df16ab6d..ec45b31fdd 100644
--- a/toke.c
+++ b/toke.c
@@ -1,4 +1,4 @@
-/* $Header: toke.c,v 3.0.1.7 90/03/27 16:32:37 lwall Locked $
+/* $Header: toke.c,v 3.0.1.8 90/08/09 05:39:58 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
@@ -6,6 +6,18 @@
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: toke.c,v $
+ * Revision 3.0.1.8 90/08/09 05:39:58 lwall
+ * patch19: added require operator
+ * patch19: added -x switch to extract script from input trash
+ * patch19: bare @name didn't add array to symbol table
+ * patch19: Added __LINE__ and __FILE__ tokens
+ * patch19: Added __END__ token
+ * patch19: Numeric literals are now stored only in floating point
+ * patch19: some support for FPS compiler misfunction
+ * patch19: "\\$foo" not handled right
+ * patch19: program and data can now both come from STDIN
+ * patch19: "here" strings caused warnings about uninitialized variables
+ *
* Revision 3.0.1.7 90/03/27 16:32:37 lwall
* patch16: MSDOS support
* patch16: formats didn't work inside eval
@@ -52,7 +64,7 @@ char *reparse; /* if non-null, scanreg found ${foo[$bar]} */
#ifdef CLINE
#undef CLINE
#endif
-#define CLINE (cmdline = (line < cmdline ? line : cmdline))
+#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))
#define META(c) ((c) | 128)
@@ -172,6 +184,15 @@ yylex()
else
fprintf(stderr,"Tokener at %s\n",s);
#endif
+#ifdef BADSWITCH
+ if (*s & 128) {
+ if ((*s & 127) == '(')
+ *s++ = '(';
+ else
+ warn("Unrecognized character \\%03o ignored", *s++);
+ goto retry;
+ }
+#endif
switch (*s) {
default:
if ((*s & 127) == '(')
@@ -179,6 +200,9 @@ yylex()
else
warn("Unrecognized character \\%03o ignored", *s++);
goto retry;
+ case 4:
+ case 26:
+ goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
if (!rsfp)
RETURN(0);
@@ -189,8 +213,7 @@ yylex()
if (minus_n || minus_p || perldb) {
str_set(linestr,"");
if (perldb)
- str_cat(linestr,
-"do 'perldb.pl' || die \"Can't find perldb.pl in @INC\"; print $@;");
+ str_cat(linestr, "require 'perldb.pl';");
if (minus_n || minus_p) {
str_cat(linestr,"line: while (<>) {");
if (minus_a)
@@ -207,33 +230,43 @@ yylex()
in_format = FALSE;
oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
bufend = linestr->str_ptr + linestr->str_cur;
- TERM(FORMLIST);
- }
- line++;
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
- if (preprocess)
- (void)mypclose(rsfp);
- else if (rsfp != stdin)
- (void)fclose(rsfp);
- rsfp = Nullfp;
- if (minus_n || minus_p) {
- str_set(linestr,minus_p ? ";}continue{print" : "");
- str_cat(linestr,";}");
+ OPERATOR(FORMLIST);
+ }
+ curcmd->c_line++;
+#ifdef CRYPTSCRIPT
+ cryptswitch();
+#endif /* CRYPTSCRIPT */
+ do {
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (preprocess)
+ (void)mypclose(rsfp);
+ else if (rsfp == stdin)
+ clearerr(stdin);
+ else
+ (void)fclose(rsfp);
+ rsfp = Nullfp;
+ if (minus_n || minus_p) {
+ str_set(linestr,minus_p ? ";}continue{print" : "");
+ str_cat(linestr,";}");
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ minus_n = minus_p = 0;
+ goto retry;
+ }
oldoldbufptr = oldbufptr = s = str_get(linestr);
- bufend = linestr->str_ptr + linestr->str_cur;
- minus_n = minus_p = 0;
- goto retry;
+ str_set(linestr,"");
+ RETURN(';'); /* not infinite loop because rsfp is NULL now */
}
- oldoldbufptr = oldbufptr = s = str_get(linestr);
- str_set(linestr,"");
- RETURN(';'); /* not infinite loop because rsfp is NULL now */
- }
+ if (doextract && *linestr->str_ptr == '#')
+ doextract = FALSE;
+ } while (doextract);
oldoldbufptr = oldbufptr = bufptr = s;
if (perldb) {
STR *str = Str_new(85,0);
str_sset(str,linestr);
- astore(lineary,(int)line,str);
+ astore(lineary,(int)curcmd->c_line,str);
}
#ifdef DEBUG
if (firstline) {
@@ -242,7 +275,7 @@ yylex()
}
#endif
bufend = linestr->str_ptr + linestr->str_cur;
- if (line == 1) {
+ if (curcmd->c_line == 1) {
if (*s == '#' && s[1] == '!') {
if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
char **newargv;
@@ -283,16 +316,13 @@ yylex()
case ' ': case '\t': case '\f':
s++;
goto retry;
- case '\n':
case '#':
if (preprocess && s == str_get(linestr) &&
s[1] == ' ' && isdigit(s[2])) {
- line = atoi(s+2)-1;
+ curcmd->c_line = atoi(s+2)-1;
for (s += 2; isdigit(*s); s++) ;
d = bufend;
while (s < d && isspace(*s)) s++;
- if (filename)
- Safefree(filename);
s[strlen(s)-1] = '\0'; /* wipe out newline */
if (*s == '"') {
s++;
@@ -301,9 +331,11 @@ yylex()
if (*s)
filename = savestr(s);
else
- filename = savestr(origfilename);
+ filename = origfilename;
oldoldbufptr = oldbufptr = s = str_get(linestr);
}
+ /* FALL THROUGH */
+ case '\n':
if (in_eval && !rsfp) {
d = bufend;
while (s < d && *s != '\n')
@@ -317,7 +349,7 @@ yylex()
oldoldbufptr = oldbufptr = s = bufptr + 1;
TERM(FORMLIST);
}
- line++;
+ curcmd->c_line++;
}
else {
*s = '\0';
@@ -412,8 +444,8 @@ yylex()
cmdline = NOLINE; /* invalidate current command line number */
OPERATOR(tmp);
case ';':
- if (line < cmdline)
- cmdline = line;
+ if (curcmd->c_line < cmdline)
+ cmdline = curcmd->c_line;
tmp = *s++;
OPERATOR(tmp);
case ')':
@@ -521,7 +553,7 @@ yylex()
s = scanreg(s,bufend,tokenbuf);
if (reparse)
goto do_reparse;
- yylval.stabval = stabent(tokenbuf,TRUE);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
TERM(ARY);
case '/': /* may either be division or pattern */
@@ -556,6 +588,23 @@ yylex()
/* FALL THROUGH */
case '_':
SNARFWORD;
+ if (d[1] == '_') {
+ if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
+ ARG *arg = op_new(1);
+
+ yylval.arg = arg;
+ arg->arg_type = O_ITEM;
+ if (d[2] == 'L')
+ (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
+ else
+ strcpy(tokenbuf, filename);
+ arg[1].arg_type = A_SINGLE;
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
+ TERM(RSTRING);
+ }
+ else if (strEQ(d,"__END__"))
+ goto fake_eof;
+ }
break;
case 'a': case 'A':
SNARFWORD;
@@ -630,7 +679,7 @@ yylex()
if (strEQ(d,"else"))
OPERATOR(ELSE);
if (strEQ(d,"elsif")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(ELSIF);
}
if (strEQ(d,"eq") || strEQ(d,"EQ"))
@@ -667,7 +716,7 @@ yylex()
case 'f': case 'F':
SNARFWORD;
if (strEQ(d,"for") || strEQ(d,"foreach")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(FOR);
}
if (strEQ(d,"format")) {
@@ -778,7 +827,7 @@ yylex()
case 'i': case 'I':
SNARFWORD;
if (strEQ(d,"if")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(IF);
}
if (strEQ(d,"index"))
@@ -897,6 +946,10 @@ yylex()
SNARFWORD;
if (strEQ(d,"return"))
OLDLOP(O_RETURN);
+ if (strEQ(d,"require")) {
+ allstabs = TRUE; /* must initialize everything since */
+ UNI(O_REQUIRE); /* we don't know what will be used */
+ }
if (strEQ(d,"reset"))
UNI(O_RESET);
if (strEQ(d,"redo"))
@@ -945,7 +998,7 @@ yylex()
break;
case 'e':
if (strEQ(d,"select"))
- OPERATOR(SELECT);
+ OPERATOR(SSELECT);
if (strEQ(d,"seek"))
FOP3(O_SEEK);
if (strEQ(d,"send"))
@@ -998,7 +1051,7 @@ yylex()
if (strEQ(d,"socket"))
FOP4(O_SOCKET);
if (strEQ(d,"socketpair"))
- FOP25(O_SOCKETPAIR);
+ FOP25(O_SOCKPAIR);
if (strEQ(d,"sort")) {
checkcomma(s,"subroutine name");
d = bufend;
@@ -1053,7 +1106,7 @@ yylex()
if (strEQ(d,"substr"))
FUN3(O_SUBSTR);
if (strEQ(d,"sub")) {
- subline = line;
+ subline = curcmd->c_line;
d = bufend;
while (s < d && isspace(*s))
s++;
@@ -1110,17 +1163,19 @@ yylex()
FUN0(O_TIME);
if (strEQ(d,"times"))
FUN0(O_TMS);
+ if (strEQ(d,"truncate"))
+ FOP2(O_TRUNCATE);
break;
case 'u': case 'U':
SNARFWORD;
if (strEQ(d,"using"))
OPERATOR(USING);
if (strEQ(d,"until")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(UNTIL);
}
if (strEQ(d,"unless")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(UNLESS);
}
if (strEQ(d,"unlink"))
@@ -1150,7 +1205,7 @@ yylex()
case 'w': case 'W':
SNARFWORD;
if (strEQ(d,"while")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(WHILE);
}
if (strEQ(d,"warn"))
@@ -1206,18 +1261,29 @@ checkcomma(s,what)
register char *s;
char *what;
{
+ char *word;
+
if (*s == '(')
s++;
while (s < bufend && isascii(*s) && isspace(*s))
s++;
if (isascii(*s) && (isalpha(*s) || *s == '_')) {
- s++;
+ word = s++;
while (isalpha(*s) || isdigit(*s) || *s == '_')
s++;
while (s < bufend && isspace(*s))
s++;
- if (*s == ',')
+ if (*s == ',') {
+ *s = '\0';
+ word = instr(
+ "tell eof times getlogin wait length shift umask getppid \
+ cos exp int log rand sin sqrt ord wantarray",
+ word);
+ *s = ',';
+ if (word)
+ return;
fatal("No comma allowed after %s", what);
+ }
}
}
@@ -1396,8 +1462,10 @@ register char *s;
}
e = tokenbuf + len;
for (d=tokenbuf; d < e; d++) {
- if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') ||
- (*d == '@' && d[-1] != '\\')) {
+ if (*d == '\\')
+ d++;
+ else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
+ (*d == '@')) {
register ARG *arg;
spat->spat_runtime = arg = op_new(1);
@@ -1408,11 +1476,13 @@ register char *s;
d = scanreg(d,bufend,buf);
(void)stabent(buf,TRUE); /* make sure it's created */
for (; d < e; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ if (*d == '\\')
+ d++;
+ else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
d = scanreg(d,bufend,buf);
(void)stabent(buf,TRUE);
}
- else if (*d == '@' && d[-1] != '\\') {
+ else if (*d == '@') {
d = scanreg(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
@@ -1448,7 +1518,7 @@ register char *s;
if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len,
- spat->spat_flags & SPAT_FOLD,1);
+ spat->spat_flags & SPAT_FOLD);
/* Note that this regexp can still be used if someone says
* something like /a/ && s//b/; so we can't delete it.
*/
@@ -1629,12 +1699,12 @@ register char *s;
int len;
int *retlen;
{
- char t[512];
+ char t[520];
register char *d = t;
register int i;
register char *send = s + len;
- while (s < send) {
+ while (s < send && d - t <= 256) {
if (s[1] == '-' && s+2 < send) {
for (i = s[0]; i <= s[2]; i++)
*d++ = i;
@@ -1711,6 +1781,7 @@ register char *s;
bool alwaysdollar = FALSE;
bool hereis = FALSE;
STR *herewas;
+ STR *str;
char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
int len;
@@ -1764,13 +1835,14 @@ register char *s;
}
}
out:
- (void)sprintf(tokenbuf,"%ld",i);
- arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
-#ifdef MICROPORT /* Microport 2.4 hack */
- { double zz = str_2num(arg[1].arg_ptr.arg_str); }
-#else
- (void)str_2num(arg[1].arg_ptr.arg_str);
-#endif /* Microport 2.4 hack */
+ str = Str_new(92,0);
+ str_numset(str,(double)i);
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = str->str_cur = 0;
+ }
+ arg[1].arg_ptr.arg_str = str;
}
break;
case '1': case '2': case '3': case '4': case '5':
@@ -1801,12 +1873,14 @@ register char *s;
*d++ = *s++;
}
*d = '\0';
- arg[1].arg_ptr.arg_str = str_make(tokenbuf, d - tokenbuf);
-#ifdef MICROPORT /* Microport 2.4 hack */
- { double zz = str_2num(arg[1].arg_ptr.arg_str); }
-#else
- (void)str_2num(arg[1].arg_ptr.arg_str);
-#endif /* Microport 2.4 hack */
+ str = Str_new(92,0);
+ str_numset(str,atof(tokenbuf));
+ if (str->str_ptr) {
+ Safefree(str->str_ptr);
+ str->str_ptr = Nullch;
+ str->str_len = str->str_cur = 0;
+ }
+ arg[1].arg_ptr.arg_str = str;
break;
case '<':
if (*++s == '<') {
@@ -1873,8 +1947,10 @@ register char *s;
}
else {
arg[1].arg_type = A_READ;
+#ifdef NOTDEF
if (rsfp == stdin && (strEQ(d,"stdin") || strEQ(d,"STDIN")))
yyerror("Can't get both program and data from <STDIN>");
+#endif
arg[1].arg_ptr.arg_stab = stabent(d,TRUE);
if (!stab_io(arg[1].arg_ptr.arg_stab))
stab_io(arg[1].arg_ptr.arg_stab) = stio_new();
@@ -1919,7 +1995,7 @@ register char *s;
STR *tmpstr;
char *tmps;
- multi_start = line;
+ multi_start = curcmd->c_line;
if (hereis)
multi_open = multi_close = '<';
else {
@@ -1936,10 +2012,10 @@ register char *s;
while (s < bufend &&
(*s != term || bcmp(s,tokenbuf,len) != 0) ) {
if (*s++ == '\n')
- line++;
+ curcmd->c_line++;
}
if (s >= bufend) {
- line = multi_start;
+ curcmd->c_line = multi_start;
fatal("EOF in string");
}
str_nset(tmpstr,d+1,s-d);
@@ -1950,21 +2026,23 @@ register char *s;
bufend = linestr->str_ptr + linestr->str_cur;
hereis = FALSE;
}
+ else
+ str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */
}
else
s = str_append_till(tmpstr,s+1,bufend,term,leave);
while (s >= bufend) { /* multiple line string? */
if (!rsfp ||
!(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
- line = multi_start;
+ curcmd->c_line = multi_start;
fatal("EOF in string");
}
- line++;
+ curcmd->c_line++;
if (perldb) {
STR *str = Str_new(88,0);
str_sset(str,linestr);
- astore(lineary,(int)line,str);
+ astore(lineary,(int)curcmd->c_line,str);
}
bufend = linestr->str_ptr + linestr->str_cur;
if (hereis) {
@@ -1982,7 +2060,7 @@ register char *s;
else
s = str_append_till(tmpstr,s,bufend,term,leave);
}
- multi_end = line;
+ multi_end = curcmd->c_line;
s++;
if (tmpstr->str_cur + 5 < tmpstr->str_len) {
tmpstr->str_len = tmpstr->str_cur + 1;
@@ -1997,7 +2075,7 @@ register char *s;
send = s + tmpstr->str_cur;
while (s < send) { /* see if we can make SINGLE */
if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
- !alwaysdollar )
+ !alwaysdollar && s[1] != '0')
*s = '$'; /* grandfather \digit in subst */
if ((*s == '$' || *s == '@') && s+1 < send &&
(alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
@@ -2100,12 +2178,12 @@ load_format()
Zero(&froot, 1, FCMD);
s = bufptr;
while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) {
- line++;
+ curcmd->c_line++;
if (perldb) {
STR *tmpstr = Str_new(89,0);
str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ astore(lineary,(int)curcmd->c_line,tmpstr);
}
if (in_eval && !rsfp) {
eol = index(s,'\n');
@@ -2188,12 +2266,12 @@ load_format()
again:
if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch)
goto badform;
- line++;
+ curcmd->c_line++;
if (perldb) {
STR *tmpstr = Str_new(90,0);
str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ astore(lineary,(int)curcmd->c_line,tmpstr);
}
if (in_eval && !rsfp) {
eol = index(s,'\n');
@@ -2214,7 +2292,7 @@ load_format()
str = flinebeg->f_unparsed = Str_new(91,eol - s);
str->str_u.str_hash = curstash;
str_nset(str,"(",1);
- flinebeg->f_line = line;
+ flinebeg->f_line = curcmd->c_line;
eol[-1] = '\0';
if (!flinebeg->f_next->f_type || index(s, ',')) {
eol[-1] = '\n';
View Lorry Controller Status