From: Larry Wall Date: Mon, 15 Oct 1990 23:05:15 +0000 (+0000) Subject: perl 3.0 patch #35 patch #29, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=395c379347344a50494d2458b3a5e38ebdeac851;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #35 patch #29, continued See patch #29. --- diff --git a/lib/syslog.pl b/lib/syslog.pl index c98baf3..1d7becf 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -1,6 +1,31 @@ # # syslog.pl # +# $Log: syslog.pl,v $ +Revision 3.0.1.3 90/10/15 17:42:18 lwall +patch29: various portability fixes + +# Revision 3.0.1.1 90/08/09 03:57:17 lwall +# patch19: Initial revision +# +# Revision 1.2 90/06/11 18:45:30 18:45:30 root () +# - Changed 'warn' to 'mail|warning' in test call (to give example of +# facility specification, and because 'warn' didn't work on HP-UX). +# - Fixed typo in &openlog ("ncons" should be "cons"). +# - Added (package-global) $maskpri, and &setlogmask. +# - In &syslog: +# - put argument test ahead of &connect (why waste cycles?), +# - allowed facility to be specified in &syslog's first arg (temporarily +# overrides any $facility set in &openlog), just as in syslog(3C), +# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)), +# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog' +# (in that order) when $ident is null, +# - made PID logging consistent with syslog(3C) and subject to $lo_pid only, +# - fixed typo in "print CONS" statement ($ # modified to use sockets by Larry Wall # NOTE: openlog now takes three arguments, just like openlog(3) @@ -15,7 +40,7 @@ # # do openlog($program,'cons,pid','user'); # do syslog('info','this is another test'); -# do syslog('warn','this is a better test: %d', time); +# do syslog('mail|warning','this is a better test: %d', time); # do closelog(); # # do syslog('debug','this is the last test'); @@ -29,13 +54,15 @@ package syslog; $host = 'localhost' unless $host; # set $syslog'host to change -require 'syslog.ph'; +require '/usr/local/lib/perl/syslog.ph'; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); sub main'openlog { ($ident, $logopt, $facility) = @_; # package vars $lo_pid = $logopt =~ /\bpid\b/; $lo_ndelay = $logopt =~ /\bndelay\b/; - $lo_cons = $logopt =~ /\bncons\b/; + $lo_cons = $logopt =~ /\bcons\b/; $lo_nowait = $logopt =~ /\bnowait\b/; &connect if $lo_ndelay; } @@ -44,33 +71,71 @@ sub main'closelog { $facility = $ident = ''; &disconnect; } + +sub main'setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} sub main'syslog { local($priority) = shift; local($mask) = shift; local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. - &connect unless $connected; + die "syslog: expected both priority and mask" unless $mask && $priority; - $whoami = $ident; + @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + undef $numpri; + undef $numfac; + foreach (@words) { + $num = &xlate($_); # Translate word to number. + if (/^kern$/ || $num < 0) { + die "syslog: invalid level/facility: $_\n"; + } + elsif ($num <= &LOG_PRIMASK) { + die "syslog: too many levels given: $_\n" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + die "syslog: too many facilities given: $_\n" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } - die "syslog: expected both priority and mask" unless $mask && $priority; + die "syslog: level must be given\n" unless defined($numpri); + + if (!defined($numfac)) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = &xlate($facility); + } + + &connect unless $connected; - $facility = "user" unless $facility; + $whoami = $ident; if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { $whoami = $1; $mask = $2; } - $whoami .= " [$$]" if $lo_pid; + + unless ($whoami) { + ($whoami = getlogin) || + ($whoami = getpwuid($<)) || + ($whoami = 'syslog'); + } + + $whoami .= "[$$]" if $lo_pid; $mask =~ s/%m/$!/g; $mask .= "\n" unless $mask =~ /\n$/; $message = sprintf ($mask, @_); - $whoami = sprintf ("%s %d",$ENV{'USER'}||$ENV{'LOGNAME'},$$) unless $whoami; - - $sum = &xlate($priority) + &xlate($facility); + $sum = $numpri + $numfac; unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { if ($lo_cons) { if ($pid = fork) { @@ -80,7 +145,7 @@ sub main'syslog { } else { open(CONS,">/dev/console"); - print CONS "$$whoami: $message\n"; + print CONS "<$facility.$priority>$whoami: $message\r"; exit if defined $pid; # if fork failed, we're parent close CONS; } @@ -93,7 +158,7 @@ sub xlate { $name =~ y/a-z/A-Z/; $name = "LOG_$name" unless $name =~ /^LOG_/; $name = "syslog'$name"; - &$name; + eval &$name || -1; } sub connect { diff --git a/patchlevel.h b/patchlevel.h index 3b47b47..68fcfef 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 34 +#define PATCHLEVEL 35 diff --git a/str.c b/str.c index 0b6dfea..e376ce6 100644 --- a/str.c +++ b/str.c @@ -1,4 +1,4 @@ -/* $Header: str.c,v 3.0.1.8 90/08/09 05:22:18 lwall Locked $ +/* $Header: str.c,v 3.0.1.9 90/10/16 10:41:21 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.c,v $ + * Revision 3.0.1.9 90/10/16 10:41:21 lwall + * patch29: the undefined value could get defined by devious means + * patch29: undefined values compared inconsistently + * patch29: taintperl now checks for world writable PATH components + * * 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 @@ -235,7 +240,7 @@ register STR *sstr; if (sstr) tainted |= sstr->str_tainted; #endif - if (sstr == dstr) + if (sstr == dstr || dstr == &str_undef) return; if (!sstr) dstr->str_pok = dstr->str_nok = 0; @@ -250,8 +255,10 @@ register STR *sstr; char *tmps = sstr->str_ptr; if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) { - dstr->str_magic = str_smake(sstr->str_magic); - dstr->str_magic->str_rare = 'X'; + if (!dstr->str_magic) { + dstr->str_magic = str_smake(sstr->str_magic); + dstr->str_magic->str_rare = 'X'; + } } } } @@ -275,6 +282,8 @@ register STR *str; register char *ptr; register STRLEN len; { + if (str == &str_undef) + return; STR_GROW(str, len + 1); if (ptr) (void)bcopy(ptr,str->str_ptr,len); @@ -293,6 +302,8 @@ register char *ptr; { register STRLEN len; + if (str == &str_undef) + return; if (!ptr) ptr = ""; len = strlen(ptr); @@ -333,6 +344,8 @@ register STR *str; register char *ptr; register STRLEN len; { + if (str == &str_undef) + return; if (!(str->str_pok)) (void)str_2ptr(str); STR_GROW(str, str->str_cur + len + 1); @@ -367,6 +380,8 @@ register char *ptr; { register STRLEN len; + if (str == &str_undef) + return; if (!ptr) return; if (!(str->str_pok)) @@ -393,6 +408,8 @@ char *keeplist; register char *to; register STRLEN len; + if (str == &str_undef) + return Nullch; if (!from) return Nullch; len = fromend - from; @@ -455,7 +472,7 @@ int how; char *name; STRLEN namlen; { - if (str->str_magic) + if (str == &str_undef || str->str_magic) return; str->str_magic = Str_new(75,namlen); str = str->str_magic; @@ -479,6 +496,8 @@ STRLEN littlelen; register char *bigend; register int i; + if (bigstr == &str_undef) + return; bigstr->str_nok = 0; bigstr->str_pok = SP_VALID; /* disable possible screamer */ @@ -550,6 +569,8 @@ str_replace(str,nstr) register STR *str; register STR *nstr; { + if (str == &str_undef) + return; if (str->str_state == SS_INCR) Str_Grow(str,0); /* just force copy down */ if (nstr->str_state == SS_INCR) @@ -576,7 +597,7 @@ void str_free(str) register STR *str; { - if (!str) + if (!str || str == &str_undef) return; if (str->str_state) { if (str->str_state == SS_FREE) /* already freed */ @@ -636,10 +657,10 @@ str_eq(str1,str2) register STR *str1; register STR *str2; { - if (!str1) - return str2 == Nullstr; - if (!str2) - return 0; + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur); + if (!str2 || str2 == &str_undef) + return !str1->str_cur; if (!str1->str_pok) (void)str_2ptr(str1); @@ -658,10 +679,10 @@ register STR *str2; { int retval; - if (!str1) - return str2 == Nullstr; - if (!str2) - return 0; + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1; + if (!str2 || str2 == &str_undef) + return str1->str_cur != 0; if (!str1->str_pok) (void)str_2ptr(str1); @@ -698,12 +719,13 @@ int append; register int get_paragraph; register char *oldbp; + if (str == &str_undef) + return Nullch; if (get_paragraph = !rslen) { /* yes, that's an assignment */ newline = '\n'; oldbp = Nullch; /* remember last \n position (none) */ } #ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ - cnt = fp->_cnt; /* get count into register */ str->str_nok = 0; /* invalidate number */ str->str_pok = 1; /* validate pointer */ @@ -790,8 +812,10 @@ STR *str; register CMD *cmd; register ARG *arg; CMD *oldcurcmd = curcmd; + int oldperldb = perldb; int retval; + perldb = 0; str_sset(linestr,str); in_eval++; oldoldbufptr = oldbufptr = bufptr = str_get(linestr); @@ -810,6 +834,7 @@ STR *str; if (setjmp(loop_stack[loop_ptr].loop_env)) { in_eval--; loop_ptr--; + perldb = oldperldb; fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr); } #ifdef DEBUGGING @@ -825,6 +850,7 @@ STR *str; curcmd->c_line = oldcurcmd->c_line; retval = yyparse(); curcmd = oldcurcmd; + perldb = oldperldb; in_eval--; if (retval || error_count) fatal("Invalid component in string or format"); @@ -994,7 +1020,8 @@ STR *src; weight += 100; break; case '-': - if (last_un_char < d[1] || d[1] == '\\') { + if (last_un_char < (unsigned char) d[1] + || d[1] == '\\') { if (index("aA01! ",last_un_char)) weight += 30; if (index("zZ79~",d[1])) @@ -1068,11 +1095,13 @@ int sp; register char *send; register STR **elem; + if (str == &str_undef) + return Nullstr; if (!(src->str_pok & SP_INTRP)) { int oldsave = savestack->ary_fill; (void)savehptr(&curstash); - curstash = src->str_u.str_hash; /* so stabent knows right package */ + curstash = curcmd->c_stash; /* so stabent knows right package */ intrpcompile(src); restorelist(oldsave); } @@ -1113,7 +1142,7 @@ register STR *str; { register char *d; - if (!str) + if (!str || str == &str_undef) return; if (str->str_nok) { str->str_u.str_nval += 1.0; @@ -1162,7 +1191,7 @@ void str_dec(str) register STR *str; { - if (!str) + if (!str || str == &str_undef) return; if (str->str_nok) { str->str_u.str_nval -= 1.0; @@ -1210,6 +1239,8 @@ STR * str_2static(str) register STR *str; { + if (str == &str_undef) + return str; if (++tmps_max > tmps_size) { tmps_size = tmps_max; if (!(tmps_size & 127)) { @@ -1292,6 +1323,8 @@ HASH *stash; /* reset variables */ + if (!stash->tbl_array) + return; while (*s) { i = *s; if (s[1] == '-') { @@ -1315,7 +1348,7 @@ HASH *stash; aclear(stab_xarray(stab)); } if (stab_xhash(stab)) { - hclear(stab_xhash(stab)); + hclear(stab_xhash(stab), FALSE); if (stab == envstab) environ[0] = Nullch; } @@ -1345,12 +1378,15 @@ taintenv() register STR *envstr; envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE); - if (!envstr || envstr->str_tainted) { + if (envstr == &str_undef || envstr->str_tainted) { tainted = 1; - taintproper("Insecure PATH"); + if (envstr->str_tainted == 2) + taintproper("Insecure directory in PATH"); + else + taintproper("Insecure PATH"); } envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE); - if (envstr && envstr->str_tainted) { + if (envstr != &str_undef && envstr->str_tainted) { tainted = 1; taintproper("Insecure IFS"); } diff --git a/str.h b/str.h index cdc3d58..1592c05 100644 --- a/str.h +++ b/str.h @@ -1,4 +1,4 @@ -/* $Header: str.h,v 3.0.1.2 90/08/09 05:23:24 lwall Locked $ +/* $Header: str.h,v 3.0.1.3 90/10/16 10:44:04 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.h,v $ + * Revision 3.0.1.3 90/10/16 10:44:04 lwall + * patch29: added caller + * patch29: scripts now run at almost full speed under the debugger + * * Revision 3.0.1.2 90/08/09 05:23:24 lwall * patch19: various MSDOS and OS/2 patches folded in * @@ -27,6 +31,7 @@ struct string { ARG *str_args; /* list of args for interpreted string */ HASH *str_hash; /* string represents an assoc array (stab?) */ ARRAY *str_array; /* string represents an array */ + CMD *str_cmd; /* command for this source line */ } str_u; STRLEN str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ @@ -51,6 +56,7 @@ struct stab { /* should be identical, except for str_ptr */ ARG *str_args; /* list of args for interpreted string */ HASH *str_hash; /* string represents an assoc array (stab?) */ ARRAY *str_array; /* string represents an array */ + CMD *str_cmd; /* command for this source line */ } str_u; STRLEN str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ @@ -94,6 +100,7 @@ struct lstring { #define SS_SSTRP 6 /* STR* on save stack */ #define SS_SHPTR 7 /* HASH* on save stack */ #define SS_SNSTAB 8 /* non-stab on save stack */ +#define SS_SCSV 9 /* callsave structure on save stack */ #define SS_HASH 253 /* carrying an hash */ #define SS_ARY 254 /* carrying an array */ #define SS_FREE 255 /* in free list */ diff --git a/toke.c b/toke.c index 2b88b1a..2d13b7c 100644 --- a/toke.c +++ b/toke.c @@ -1,4 +1,4 @@ -/* $Header: toke.c,v 3.0.1.9 90/08/13 22:37:25 lwall Locked $ +/* $Header: toke.c,v 3.0.1.10 90/10/16 11:20:46 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,21 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: toke.c,v $ + * Revision 3.0.1.10 90/10/16 11:20:46 lwall + * patch29: the length of a search pattern was limited + * patch29: added DATA filehandle to read stuff after __END__ + * patch29: added -M, -A and -C + * patch29: added cmp and <=> + * patch29: added caller + * patch29: added scalar + * patch29: added sysread and syswrite + * patch29: added SysV IPC + * patch29: added waitpid + * patch29: tr/// now understands c, d and s options, and handles nulls right + * patch29: 0x80000000 now makes unsigned value + * patch29: Null could not be used as a delimiter + * patch29: added @###.## fields to format + * * Revision 3.0.1.9 90/08/13 22:37:25 lwall * patch28: defined(@array) and defined(%array) didn't work right * @@ -62,6 +77,14 @@ #include "perl.h" #include "perly.h" +#ifdef I_FCNTL +#include +#endif + +/* which backslash sequences to keep in m// or s// */ + +static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}"; + char *reparse; /* if non-null, scanreg found ${foo[$bar]} */ #ifdef CLINE @@ -79,13 +102,15 @@ char *reparse; /* if non-null, scanreg found ${foo[$bar]} */ #define FUN0(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC0) #define FUN1(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC1) #define FUN2(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2) +#define FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x) #define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3) +#define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4) +#define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5) #define FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST) #define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2) #define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN) #define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3) #define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN) -#define LFUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)LFUNC4) #define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP) #define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP) #define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP) @@ -215,8 +240,13 @@ yylex() firstline = FALSE; if (minus_n || minus_p || perldb) { str_set(linestr,""); - if (perldb) - str_cat(linestr, "require 'perldb.pl';"); + if (perldb) { + char *getenv(); + char *pdb = getenv("PERLDB"); + + str_cat(linestr, pdb ? pdb : "require 'perldb.pl'"); + str_cat(linestr, ";"); + } if (minus_n || minus_p) { str_cat(linestr,"line: while (<>) {"); if (minus_a) @@ -242,13 +272,15 @@ yylex() 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 (rsfp) { + 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,";}"); @@ -269,7 +301,7 @@ yylex() STR *str = Str_new(85,0); str_sset(str,linestr); - astore(lineary,(int)curcmd->c_line,str); + astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str); } #ifdef DEBUG if (firstline) { @@ -332,9 +364,9 @@ yylex() s[strlen(s)-1] = '\0'; /* wipe out trailing quote */ } if (*s) - filename = savestr(s); + curcmd->c_filestab = fstab(s); else - filename = origfilename; + curcmd->c_filestab = fstab(origfilename); oldoldbufptr = oldbufptr = s = str_get(linestr); } /* FALL THROUGH */ @@ -345,6 +377,13 @@ yylex() s++; if (s < d) s++; + if (perldb) { + STR *str = Str_new(85,0); + + str_nset(str,linestr->str_ptr, s - linestr->str_ptr); + astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str); + str_chop(linestr, s); + } if (in_format) { bufptr = s; yylval.formval = load_format(); @@ -387,6 +426,9 @@ yylex() case 't': FTST(O_FTTTY); case 'T': FTST(O_FTTEXT); case 'B': FTST(O_FTBINARY); + case 'M': stabent("\024",TRUE); FTST(O_FTMTIME); + case 'A': stabent("\024",TRUE); FTST(O_FTATIME); + case 'C': stabent("\024",TRUE); FTST(O_FTCTIME); default: s -= 2; break; @@ -507,8 +549,13 @@ yylex() tmp = *s++; if (tmp == '<') OPERATOR(LS); - if (tmp == '=') + if (tmp == '=') { + tmp = *s++; + if (tmp == '>') + EOP(O_NCMP); + s--; ROP(O_LE); + } s--; ROP(O_LT); case '>': @@ -600,13 +647,35 @@ yylex() if (d[2] == 'L') (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line); else - strcpy(tokenbuf, filename); + strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr); arg[1].arg_type = A_SINGLE; arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf)); TERM(RSTRING); } - else if (strEQ(d,"__END__")) + else if (strEQ(d,"__END__")) { +#ifndef TAINT + STAB *stab; + int fd; + + if (stab = stabent("DATA",FALSE)) { + stab->str_pok |= SP_MULTI; + stab_io(stab) = stio_new(); + stab_io(stab)->ifp = rsfp; +#if defined(FCNTL) && defined(F_SETFD) + fd = fileno(rsfp); + fcntl(fd,F_SETFD,fd >= 3); +#endif + if (preprocess) + stab_io(stab)->type = '|'; + else if (rsfp == stdin) + stab_io(stab)->type = '-'; + else + stab_io(stab)->type = '<'; + rsfp = Nullfp; + } +#endif goto fake_eof; + } } break; case 'a': case 'A': @@ -637,6 +706,10 @@ yylex() FOP(O_CLOSE); if (strEQ(d,"closedir")) FOP(O_CLOSEDIR); + if (strEQ(d,"cmp")) + EOP(O_SCMP); + if (strEQ(d,"caller")) + UNI(O_CALLER); if (strEQ(d,"crypt")) { #ifdef FCRYPT init_des(); @@ -701,7 +774,7 @@ yylex() HFUN(O_EACH); if (strEQ(d,"exec")) { set_csh(); - LOP(O_EXEC); + LOP(O_EXEC_OP); } if (strEQ(d,"endhostent")) FUN0(O_EHOSTENT); @@ -834,7 +907,7 @@ yylex() OPERATOR(IF); } if (strEQ(d,"index")) - FUN2(O_INDEX); + FUN2x(O_INDEX); if (strEQ(d,"int")) UNI(O_INT); if (strEQ(d,"ioctl")) @@ -890,8 +963,22 @@ yylex() else RETURN(1); /* force error */ } - if (strEQ(d,"mkdir")) - FUN2(O_MKDIR); + switch (d[1]) { + case 'k': + if (strEQ(d,"mkdir")) + FUN2(O_MKDIR); + break; + case 's': + if (strEQ(d,"msgctl")) + FUN3(O_MSGCTL); + if (strEQ(d,"msgget")) + FUN2(O_MSGGET); + if (strEQ(d,"msgrcv")) + FUN5(O_MSGRCV); + if (strEQ(d,"msgsnd")) + FUN3(O_MSGSND); + break; + } break; case 'n': case 'N': SNARFWORD; @@ -964,7 +1051,7 @@ yylex() if (strEQ(d,"rmdir")) UNI(O_RMDIR); if (strEQ(d,"rindex")) - FUN2(O_RINDEX); + FUN2x(O_RINDEX); if (strEQ(d,"read")) FOP3(O_READ); if (strEQ(d,"readdir")) @@ -996,7 +1083,11 @@ yylex() switch (d[1]) { case 'a': case 'b': + break; case 'c': + if (strEQ(d,"scalar")) + UNI(O_SCALAR); + break; case 'd': break; case 'e': @@ -1004,6 +1095,12 @@ yylex() OPERATOR(SSELECT); if (strEQ(d,"seek")) FOP3(O_SEEK); + if (strEQ(d,"semctl")) + FUN4(O_SEMCTL); + if (strEQ(d,"semget")) + FUN3(O_SEMGET); + if (strEQ(d,"semop")) + FUN2(O_SEMOP); if (strEQ(d,"send")) FOP3(O_SEND); if (strEQ(d,"setpgrp")) @@ -1033,6 +1130,14 @@ yylex() case 'h': if (strEQ(d,"shift")) TERM(SHIFT); + if (strEQ(d,"shmctl")) + FUN3(O_SHMCTL); + if (strEQ(d,"shmget")) + FUN3(O_SHMGET); + if (strEQ(d,"shmread")) + FUN4(O_SHMREAD); + if (strEQ(d,"shmwrite")) + FUN4(O_SHMWRITE); if (strEQ(d,"shutdown")) FOP2(O_SHUTDOWN); break; @@ -1107,7 +1212,7 @@ yylex() break; case 'u': if (strEQ(d,"substr")) - FUN3(O_SUBSTR); + FUN2x(O_SUBSTR); if (strEQ(d,"sub")) { subline = curcmd->c_line; d = bufend; @@ -1144,6 +1249,10 @@ yylex() FUN2(O_SYMLINK); if (strEQ(d,"syscall")) LOP(O_SYSCALL); + if (strEQ(d,"sysread")) + FOP3(O_SYSREAD); + if (strEQ(d,"syswrite")) + FOP3(O_SYSWRITE); break; case 'z': break; @@ -1215,6 +1324,8 @@ yylex() LOP(O_WARN); if (strEQ(d,"wait")) FUN0(O_WAIT); + if (strEQ(d,"waitpid")) + FUN2(O_WAITPID); if (strEQ(d,"wantarray")) { yylval.arg = op_new(1); yylval.arg->arg_type = O_ITEM; @@ -1428,6 +1539,7 @@ register char *s; register char *e; int len; SPAT savespat; + STR *str = Str_new(93,0); Newz(801,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ @@ -1445,8 +1557,9 @@ register char *s; default: fatal("panic: scanpat"); } - s = cpytill(tokenbuf,s,bufend,s[-1],&len); + s = str_append_till(str,s,bufend,s[-1],patleave); if (s >= bufend) { + str_free(str); yyerror("Search pattern not terminated"); yylval.arg = Nullarg; return s; @@ -1463,8 +1576,9 @@ register char *s; spat->spat_flags |= SPAT_KEEP; } } - e = tokenbuf + len; - for (d=tokenbuf; d < e; d++) { + len = str->str_cur; + e = str->str_ptr + len; + for (d = str->str_ptr; d < e; d++) { if (*d == '\\') d++; else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') || @@ -1474,8 +1588,7 @@ register char *s; spat->spat_runtime = arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_DOUBLE; - arg[1].arg_ptr.arg_str = str_make(tokenbuf,len); - arg[1].arg_ptr.arg_str->str_u.str_hash = curstash; + arg[1].arg_ptr.arg_str = str_smake(str); d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); /* make sure it's created */ for (; d < e; d++) { @@ -1501,8 +1614,8 @@ register char *s; #else (void)bcopy((char *)spat, (char *)&savespat, sizeof(SPAT)); #endif - if (*tokenbuf == '^') { - spat->spat_short = scanconst(tokenbuf+1,len-1); + if (*str->str_ptr == '^') { + spat->spat_short = scanconst(str->str_ptr+1,len-1); if (spat->spat_short) { spat->spat_slen = spat->spat_short->str_cur; if (spat->spat_slen == len - 1) @@ -1511,7 +1624,7 @@ register char *s; } else { spat->spat_flags |= SPAT_SCANFIRST; - spat->spat_short = scanconst(tokenbuf,len); + spat->spat_short = scanconst(str->str_ptr,len); if (spat->spat_short) { spat->spat_slen = spat->spat_short->str_cur; if (spat->spat_slen == len) @@ -1520,7 +1633,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_regexp = regcomp(str->str_ptr,str->str_ptr+len, 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. @@ -1535,11 +1648,12 @@ register char *s; #endif if (spat->spat_short) fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); - spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len, + spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len, spat->spat_flags & SPAT_FOLD,1); hoistmust(spat); } got_pat: + str_free(str); yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); return s; } @@ -1552,28 +1666,32 @@ register char *s; register char *d; register char *e; int len; + STR *str = Str_new(93,0); Newz(802,spat,1,SPAT); spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ curstash->tbl_spatroot = spat; - s = cpytill(tokenbuf,s+1,bufend,*s,&len); + s = str_append_till(str,s+1,bufend,*s,patleave); if (s >= bufend) { + str_free(str); yyerror("Substitution pattern not terminated"); yylval.arg = Nullarg; return s; } - e = tokenbuf + len; - for (d=tokenbuf; d < e; d++) { - if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') || - (*d == '@' && d[-1] != '\\')) { + len = str->str_cur; + e = str->str_ptr + len; + for (d = str->str_ptr; d < e; d++) { + if (*d == '\\') + d++; + else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') || + *d == '@' ) { register ARG *arg; spat->spat_runtime = arg = op_new(1); arg->arg_type = O_ITEM; arg[1].arg_type = A_DOUBLE; - arg[1].arg_ptr.arg_str = str_make(tokenbuf,len); - arg[1].arg_ptr.arg_str->str_u.str_hash = curstash; + arg[1].arg_ptr.arg_str = str_smake(str); d = scanreg(d,bufend,buf); (void)stabent(buf,TRUE); /* make sure it's created */ for (; *d; d++) { @@ -1591,21 +1709,21 @@ register char *s; goto get_repl; /* skip compiling for now */ } } - if (*tokenbuf == '^') { - spat->spat_short = scanconst(tokenbuf+1,len-1); + if (*str->str_ptr == '^') { + spat->spat_short = scanconst(str->str_ptr+1,len-1); if (spat->spat_short) spat->spat_slen = spat->spat_short->str_cur; } else { spat->spat_flags |= SPAT_SCANFIRST; - spat->spat_short = scanconst(tokenbuf,len); + spat->spat_short = scanconst(str->str_ptr,len); if (spat->spat_short) spat->spat_slen = spat->spat_short->str_cur; } - d = nsavestr(tokenbuf,len); get_repl: s = scanstr(s); if (s >= bufend) { + str_free(str); yyerror("Substitution replacement not terminated"); yylval.arg = Nullarg; return s; @@ -1632,10 +1750,10 @@ get_repl: s++; if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) spat->spat_repl[1].arg_type = A_SINGLE; - spat->spat_repl = fixeval(make_op(O_EVAL,2, + spat->spat_repl = make_op(O_EVAL,2, spat->spat_repl, Nullarg, - Nullarg)); + Nullarg); spat->spat_flags &= ~SPAT_CONST; } if (*s == 'g') { @@ -1660,11 +1778,12 @@ get_repl: if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST)) fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); if (!spat->spat_runtime) { - spat->spat_regexp = regcomp(d,d+len,spat->spat_flags & SPAT_FOLD,1); + spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len, + spat->spat_flags & SPAT_FOLD,1); hoistmust(spat); - Safefree(d); } yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat); + str_free(str); return s; } @@ -1729,14 +1848,17 @@ register char *s; l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg)); register char *t; register char *r; - register char *tbl; + register short *tbl; register int i; register int j; int tlen, rlen; + int squash; + int delete; + int complement; - Newz(803,tbl,256,char); + New(803,tbl,256,short); arg[2].arg_type = A_NULL; - arg[2].arg_ptr.arg_cval = tbl; + arg[2].arg_ptr.arg_cval = (char*) tbl; s = scanstr(s); if (s >= bufend) { yyerror("Translation pattern not terminated"); @@ -1752,18 +1874,57 @@ register char *s; yylval.arg = Nullarg; return s; } + complement = delete = squash = 0; + while (*s == 'c' || *s == 'd' || *s == 's') { + if (*s == 'c') + complement = 1; + else if (*s == 'd') + delete = 2; + else + squash = 1; + s++; + } r = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr, yylval.arg[1].arg_ptr.arg_str->str_cur,&rlen); free_arg(yylval.arg); + arg[2].arg_len = delete|squash; yylval.arg = arg; - if (!*r) { + if (!rlen && !delete) { Safefree(r); r = t; rlen = tlen; } - for (i = 0, j = 0; i < tlen; i++,j++) { - if (j >= rlen) - --j; - tbl[t[i] & 0377] = r[j]; + if (complement) { + Zero(tbl, 256, short); + for (i = 0; i < tlen; i++) + tbl[t[i] & 0377] = -1; + for (i = 0, j = 0; i < 256; i++,j++) { + if (!tbl[i]) { + if (j >= rlen) { + if (delete) { + tbl[i] = -2; + continue; + } + --j; + } + tbl[i] = r[j]; + } + } + } + else { + for (i = 0; i < 256; i++) + tbl[i] = -1; + for (i = 0, j = 0; i < tlen; i++,j++) { + if (j >= rlen) { + if (delete) { + if (tbl[t[i] & 0377] == -1) + tbl[t[i] & 0377] = -2; + continue; + } + --j; + } + if (tbl[t[i] & 0377] == -1) + tbl[t[i] & 0377] = r[j]; + } } if (r != t) Safefree(r); @@ -1802,7 +1963,7 @@ register char *s; goto snarf_it; case '0': { - long i; + unsigned long i; int shift; arg[1].arg_type = A_SINGLE; @@ -1936,7 +2097,6 @@ register char *s; arg[1].arg_ptr.arg_stab = stab = genstab(); stab_io(stab) = stio_new(); stab_val(stab) = str_make(d,len); - stab_val(stab)->str_u.str_hash = curstash; Safefree(d); set_csh(); } @@ -1950,10 +2110,6 @@ 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(); @@ -2003,7 +2159,7 @@ register char *s; multi_open = multi_close = '<'; else { multi_open = term; - if (tmps = index("([{< )]}> )]}>",term)) + if (term && (tmps = index("([{< )]}> )]}>",term))) term = tmps[5]; multi_close = term; } @@ -2045,7 +2201,8 @@ register char *s; STR *str = Str_new(88,0); str_sset(str,linestr); - astore(lineary,(int)curcmd->c_line,str); + astore(stab_xarray(curcmd->c_filestab), + (int)curcmd->c_line,str); } bufend = linestr->str_ptr + linestr->str_cur; if (hereis) { @@ -2151,8 +2308,6 @@ register char *s; if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle) arg[1].arg_type = A_SINGLE; /* now we can optimize on it */ - tmpstr->str_u.str_hash = curstash; /* so interp knows package */ - tmpstr->str_cur = d - tmpstr->str_ptr; arg[1].arg_ptr.arg_str = tmpstr; s = tmps; @@ -2182,12 +2337,6 @@ load_format() s = bufptr; while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) { curcmd->c_line++; - if (perldb) { - STR *tmpstr = Str_new(89,0); - - str_sset(tmpstr,linestr); - astore(lineary,(int)curcmd->c_line,tmpstr); - } if (in_eval && !rsfp) { eol = index(s,'\n'); if (!eol++) @@ -2195,6 +2344,12 @@ load_format() } else eol = bufend = linestr->str_ptr + linestr->str_cur; + if (perldb) { + STR *tmpstr = Str_new(89,0); + + str_nset(tmpstr, s, eol-s); + astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr); + } if (strnEQ(s,".\n",2)) { bufptr = s; return froot.f_next; @@ -2254,7 +2409,35 @@ load_format() while (*s == '|') s++; break; + case '#': + case '.': + /* Catch the special case @... and handle it as a string + field. */ + if (*s == '.' && s[1] == '.') { + goto default_format; + } + fcmd->f_type = F_DECIMAL; + { + char *p; + + /* Read a format in the form @####.####, where either group + of ### may be empty, or the final .### may be missing. */ + while (*s == '#') + s++; + if (*s == '.') { + s++; + p = s; + while (*s == '#') + s++; + fcmd->f_decimals = s-p; + fcmd->f_flags |= FC_DP; + } else { + fcmd->f_decimals = 0; + } + } + break; default: + default_format: fcmd->f_type = F_LEFT; break; } @@ -2270,12 +2453,6 @@ load_format() if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; curcmd->c_line++; - if (perldb) { - STR *tmpstr = Str_new(90,0); - - str_sset(tmpstr,linestr); - astore(lineary,(int)curcmd->c_line,tmpstr); - } if (in_eval && !rsfp) { eol = index(s,'\n'); if (!eol++) @@ -2283,6 +2460,13 @@ load_format() } else eol = bufend = linestr->str_ptr + linestr->str_cur; + if (perldb) { + STR *tmpstr = Str_new(90,0); + + str_nset(tmpstr, s, eol-s); + astore(stab_xarray(curcmd->c_filestab), + (int)curcmd->c_line,tmpstr); + } if (strnEQ(s,".\n",2)) { bufptr = s; yyerror("Missing values line");