From: Larry Wall Date: Wed, 8 Aug 1990 17:06:25 +0000 (+0000) Subject: perl 3.0 patch #26 patch #19, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e929a76b14922a7077596a747fc1fcd1bdd6b9ea;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #26 patch #19, continued See patch #19. --- diff --git a/h2pl/eg/sysexits.pl b/h2pl/eg/sysexits.pl new file mode 100644 index 0000000..f4cb777 --- /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 0000000..2677cc9 --- /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 0000000..fcbf926 --- /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 8cf0bde..df9e1db 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 46c8c86..c98baf3 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 35b5ec0..d648526 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 0000000..2356f2e --- /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 0000000..2dbb02b --- /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 +#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 10c8c21..9705476 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 25 +#define PATCHLEVEL 26 diff --git a/stab.h b/stab.h index db2d60c..aeb7133 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 324e100..0b6dfea 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 2c14029..cdc3d58 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 40df16a..ec45b31 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 "); +#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';