#
# 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 ($<facility should be <$facility).
+# - changed \n to \r in print CONS (\r is useful, $message already has a \n).
+# - Changed &xlate to return -1 for an unknown name, instead of croaking.
+#
+#
# tom christiansen <tchrist@convex.com>
# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
# NOTE: openlog now takes three arguments, just like openlog(3)
#
# 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');
$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;
}
$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) {
}
else {
open(CONS,">/dev/console");
- print CONS "$<facility.$priority>$whoami: $message\n";
+ print CONS "<$facility.$priority>$whoami: $message\r";
exit if defined $pid; # if fork failed, we're parent
close CONS;
}
$name =~ y/a-z/A-Z/;
$name = "LOG_$name" unless $name =~ /^LOG_/;
$name = "syslog'$name";
- &$name;
+ eval &$name || -1;
}
sub connect {
-/* $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
*
* 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
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;
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';
+ }
}
}
}
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);
{
register STRLEN len;
+ if (str == &str_undef)
+ return;
if (!ptr)
ptr = "";
len = strlen(ptr);
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);
{
register STRLEN len;
+ if (str == &str_undef)
+ return;
if (!ptr)
return;
if (!(str->str_pok))
register char *to;
register STRLEN len;
+ if (str == &str_undef)
+ return Nullch;
if (!from)
return Nullch;
len = fromend - from;
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;
register char *bigend;
register int i;
+ if (bigstr == &str_undef)
+ return;
bigstr->str_nok = 0;
bigstr->str_pok = SP_VALID; /* disable possible screamer */
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)
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 */
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);
{
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);
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 */
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);
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
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");
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]))
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);
}
{
register char *d;
- if (!str)
+ if (!str || str == &str_undef)
return;
if (str->str_nok) {
str->str_u.str_nval += 1.0;
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;
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)) {
/* reset variables */
+ if (!stash->tbl_array)
+ return;
while (*s) {
i = *s;
if (s[1] == '-') {
aclear(stab_xarray(stab));
}
if (stab_xhash(stab)) {
- hclear(stab_xhash(stab));
+ hclear(stab_xhash(stab), FALSE);
if (stab == envstab)
environ[0] = Nullch;
}
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");
}
-/* $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
*
* 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
*
#include "perl.h"
#include "perly.h"
+#ifdef I_FCNTL
+#include <fcntl.h>
+#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
#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)
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)
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,";}");
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) {
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 */
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();
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;
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 '>':
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':
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();
HFUN(O_EACH);
if (strEQ(d,"exec")) {
set_csh();
- LOP(O_EXEC);
+ LOP(O_EXEC_OP);
}
if (strEQ(d,"endhostent"))
FUN0(O_EHOSTENT);
OPERATOR(IF);
}
if (strEQ(d,"index"))
- FUN2(O_INDEX);
+ FUN2x(O_INDEX);
if (strEQ(d,"int"))
UNI(O_INT);
if (strEQ(d,"ioctl"))
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;
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"))
switch (d[1]) {
case 'a':
case 'b':
+ break;
case 'c':
+ if (strEQ(d,"scalar"))
+ UNI(O_SCALAR);
+ break;
case 'd':
break;
case 'e':
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"))
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;
break;
case 'u':
if (strEQ(d,"substr"))
- FUN3(O_SUBSTR);
+ FUN2x(O_SUBSTR);
if (strEQ(d,"sub")) {
subline = curcmd->c_line;
d = bufend;
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;
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;
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 */
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;
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] != ')') ||
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++) {
#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)
}
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)
}
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.
#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;
}
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++) {
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;
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') {
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;
}
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");
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);
goto snarf_it;
case '0':
{
- long i;
+ unsigned long i;
int shift;
arg[1].arg_type = A_SINGLE;
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();
}
}
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();
multi_open = multi_close = '<';
else {
multi_open = term;
- if (tmps = index("([{< )]}> )]}>",term))
+ if (term && (tmps = index("([{< )]}> )]}>",term)))
term = tmps[5];
multi_close = term;
}
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) {
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;
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++)
}
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;
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;
}
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++)
}
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");
projects / p5sagit/p5-mst-13.2.git / commitdiff