-/* $Header: toke.c,v 3.0.1.5 90/02/28 18:47:06 lwall Locked $
+/* $RCSfile: toke.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:18:18 $
*
* 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.5 90/02/28 18:47:06 lwall
- * patch9: return grandfathered to never be function call
- * patch9: non-existent perldb.pl now gives reasonable error message
- * patch9: perl can now start up other interpreters scripts
- * patch9: line numbers were bogus during certain portions of foreach evaluation
- * patch9: null hereis core dumped
+ * Revision 4.0.1.1 91/04/12 09:18:18 lwall
+ * patch1: perl -de "print" wouldn't stop at the first statement
*
- * Revision 3.0.1.4 89/12/21 20:26:56 lwall
- * patch7: -d switch incompatible with -p or -n
- * patch7: " ''$foo'' " didn't parse right
- * patch7: grandfathered m'pat' and s'pat'repl' to not be package qualifiers
- *
- * Revision 3.0.1.3 89/11/17 15:43:15 lwall
- * patch5: IBM PC/RT compiler can't deal with UNI() and LOP() macros
- * patch5: } misadjusted expection of subsequent term or operator
- * patch5: y/abcde// didn't work
- *
- * Revision 3.0.1.2 89/11/11 05:04:42 lwall
- * patch2: fixed a CLINE macro conflict
- *
- * Revision 3.0.1.1 89/10/26 23:26:21 lwall
- * patch1: disambiguated word after "sort" better
- *
- * Revision 3.0 89/10/18 15:32:33 lwall
- * 3.0 baseline
+ * Revision 4.0 91/03/20 01:42:14 lwall
+ * 4.0 baseline.
*
*/
#include "perl.h"
#include "perly.h"
-char *reparse; /* if non-null, scanreg found ${foo[$bar]} */
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+/* which backslash sequences to keep in m// or s// */
+
+static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}";
+
+char *reparse; /* if non-null, scanident found ${foo[$bar]} */
+
+void checkcomma();
#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)
#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)
/* This does similarly for list operators, merely by pretending that the
* paren came before the listop rather than after.
*/
-#define LOP(f) return(*s == '(' || (s = skipspace(s), *s == '(') ? \
+#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
(*s = META('('), bufptr = oldbufptr, '(') : \
(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
/* grandfather return to old style */
int f;
char *s;
{
+ CLINE;
if (*s != '(')
s = skipspace(s);
if (*s == '(') {
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++ & 255);
+ goto retry;
+ }
+#endif
switch (*s) {
default:
if ((*s & 127) == '(')
*s++ = '(';
else
- warn("Unrecognized character \\%03o ignored", *s++);
+ warn("Unrecognized character \\%03o ignored", *s++ & 255);
goto retry;
+ case 4:
+ case 26:
+ goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
if (!rsfp)
RETURN(0);
firstline = FALSE;
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 $@;");
+ 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_l)
+ str_cat(linestr,"chop;");
if (minus_a)
str_cat(linestr,"@F=split(' ');");
}
}
}
if (in_format) {
+ bufptr = bufend;
yylval.formval = load_format();
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 (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,";}");
+ 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(0);
- }
+ 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(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
}
#ifdef DEBUG
if (firstline) {
}
#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;
}
}
goto retry;
- case ' ': case '\t': case '\f':
+ case ' ': case '\t': case '\f': case '\r': case 013:
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++;
s[strlen(s)-1] = '\0'; /* wipe out trailing quote */
}
if (*s)
- filename = savestr(s);
+ curcmd->c_filestab = fstab(s);
else
- filename = savestr(origfilename);
+ curcmd->c_filestab = fstab(origfilename);
oldoldbufptr = oldbufptr = s = str_get(linestr);
}
+ /* FALL THROUGH */
+ case '\n':
if (in_eval && !rsfp) {
d = bufend;
while (s < d && *s != '\n')
s++;
- if (s < d) {
+ if (s < d)
s++;
- line++;
+ 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();
+ in_format = FALSE;
+ oldoldbufptr = oldbufptr = s = bufptr + 1;
+ TERM(FORMLIST);
}
+ curcmd->c_line++;
}
else {
*s = '\0';
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;
case '*':
if (expectterm) {
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
yylval.stabval = stabent(tokenbuf,TRUE);
TERM(STAR);
}
MOP(O_MULTIPLY);
case '%':
if (expectterm) {
- s = scanreg(s,bufend,tokenbuf);
- yylval.stabval = stabent(tokenbuf,TRUE);
+ s = scanident(s,bufend,tokenbuf);
+ yylval.stabval = hadd(stabent(tokenbuf,TRUE));
TERM(HSH);
}
s++;
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 ')':
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 '>':
case '$':
if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) {
s++;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
yylval.stabval = aadd(stabent(tokenbuf,TRUE));
TERM(ARYLEN);
}
d = s;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,bufend,tokenbuf);
if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */
do_reparse:
s[-1] = ')';
case '@':
d = s;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(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 */
/* 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, 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__")) {
+#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(HAS_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':
SNARFWORD;
+ if (strEQ(d,"alarm"))
+ UNI(O_ALARM);
if (strEQ(d,"accept"))
FOP22(O_ACCEPT);
if (strEQ(d,"atan2"))
SNARFWORD;
if (strEQ(d,"bind"))
FOP2(O_BIND);
+ if (strEQ(d,"binmode"))
+ FOP(O_BINMODE);
break;
case 'c': case 'C':
SNARFWORD;
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();
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"))
HFUN(O_EACH);
if (strEQ(d,"exec")) {
set_csh();
- LOP(O_EXEC);
+ LOP(O_EXEC_OP);
}
if (strEQ(d,"endhostent"))
FUN0(O_EHOSTENT);
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")) {
case 'i': case 'I':
SNARFWORD;
if (strEQ(d,"if")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
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;
s = scanstr(s-2);
TERM(RSTRING);
}
+ if (strEQ(d,"qx")) {
+ s = scanstr(s-2);
+ TERM(RSTRING);
+ }
break;
case 'r': case 'R':
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"))
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':
if (strEQ(d,"select"))
- OPERATOR(SELECT);
+ 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;
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;
TERM(SPLIT);
if (strEQ(d,"sprintf"))
FL(O_SPRINTF);
+ if (strEQ(d,"splice")) {
+ yylval.ival = O_SPLICE;
+ OPERATOR(PUSH);
+ }
break;
case 'q':
if (strEQ(d,"sqrt"))
break;
case 'u':
if (strEQ(d,"substr"))
- FUN3(O_SUBSTR);
+ FUN2x(O_SUBSTR);
if (strEQ(d,"sub")) {
- subline = line;
+ subline = curcmd->c_line;
d = bufend;
while (s < d && isspace(*s))
s++;
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;
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"))
case 'w': case 'W':
SNARFWORD;
if (strEQ(d,"while")) {
- yylval.ival = line;
+ yylval.ival = curcmd->c_line;
OPERATOR(WHILE);
}
if (strEQ(d,"warn"))
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;
return (CLINE, bufptr = s, (int)WORD);
}
-int
+void
checkcomma(s,what)
register char *s;
char *what;
{
+ char *someword;
+
if (*s == '(')
s++;
while (s < bufend && isascii(*s) && isspace(*s))
s++;
if (isascii(*s) && (isalpha(*s) || *s == '_')) {
- s++;
+ someword = s++;
while (isalpha(*s) || isdigit(*s) || *s == '_')
s++;
while (s < bufend && isspace(*s))
s++;
- if (*s == ',')
+ if (*s == ',') {
+ *s = '\0';
+ someword = instr(
+ "tell eof times getlogin wait length shift umask getppid \
+ cos exp int log rand sin sqrt ord wantarray",
+ someword);
+ *s = ',';
+ if (someword)
+ return;
fatal("No comma allowed after %s", what);
+ }
}
}
char *
-scanreg(s,send,dest)
+scanident(s,send,dest)
register char *s;
register char *send;
char *dest;
else
d[1] = '\0';
}
- if (*d == '^' && !isspace(*s))
- *d = *s++ & 31;
+ if (*d == '^' && (isupper(*s) || index("[\\]^_?",*s)))
+ *d = *s++ ^ 64;
return s;
}
e = d;
break;
case '\\':
- if (d[1] && index("wWbB0123456789sSdD",d[1])) {
+ if (d[1] && index("wWbB0123456789sSdDlLuUE",d[1])) {
e = d;
break;
}
case 'r':
*d = '\r';
break;
+ case 'e':
+ *d = '\033';
+ break;
+ case 'a':
+ *d = '\007';
+ break;
}
/* FALL THROUGH */
default:
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++) {
- 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;
- d = scanreg(d,bufend,buf);
+ arg[1].arg_ptr.arg_str = str_smake(str);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE); /* make sure it's created */
for (; d < e; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- d = scanreg(d,bufend,buf);
+ if (*d == '\\')
+ d++;
+ else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE);
}
- else if (*d == '@' && d[-1] != '\\') {
- d = scanreg(d,bufend,buf);
+ else if (*d == '@') {
+ d = scanident(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
(void)stabent(buf,TRUE);
#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_flags & SPAT_FOLD,1);
+ 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_flags & SPAT_FOLD,1);
+ spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len,
+ spat->spat_flags & SPAT_FOLD);
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;
- d = scanreg(d,bufend,buf);
+ arg[1].arg_ptr.arg_str = str_smake(str);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE); /* make sure it's created */
for (; *d; d++) {
if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
(void)stabent(buf,TRUE);
}
else if (*d == '@' && d[-1] != '\\') {
- d = scanreg(d,bufend,buf);
+ d = scanident(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
(void)stabent(buf,TRUE);
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);
hoistmust(spat);
- Safefree(d);
}
yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat);
+ str_free(str);
return 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++)
+ for (i = (s[0] & 0377); i <= (s[2] & 0377); i++)
*d++ = i;
s += 3;
}
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");
}
t = expand_charset(yylval.arg[1].arg_ptr.arg_str->str_ptr,
yylval.arg[1].arg_ptr.arg_str->str_cur,&tlen);
- free_arg(yylval.arg);
+ arg_free(yylval.arg);
s = scanstr(s-1);
if (s >= bufend) {
yyerror("Translation replacement 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_free(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++) {
+ if (!tbl[i]) {
+ if (j >= rlen) {
+ if (delete)
+ tbl[i] = -2;
+ else
+ tbl[i] = r[j-1];
+ }
+ else
+ 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] & 0377;
+ }
}
if (r != t)
Safefree(r);
bool alwaysdollar = FALSE;
bool hereis = FALSE;
STR *herewas;
- char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
+ STR *str;
+ char *leave = "\\$@nrtfbeacx0123456789[{]}lLuUE"; /* which backslash sequences to keep */
int len;
arg = op_new(1);
goto snarf_it;
case '0':
{
- long i;
+ unsigned long i;
int shift;
arg[1].arg_type = A_SINGLE;
}
}
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':
*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 == '<') {
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;
- if (rsfp == stdin && (strEQ(d,"stdin") || strEQ(d,"STDIN")))
- yyerror("Can't get both program and data from <STDIN>");
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();
s++;
goto do_double;
}
+ if (*s == 'x') {
+ s++;
+ goto do_back;
+ }
/* FALL THROUGH */
case '\'':
do_single:
STR *tmpstr;
char *tmps;
- multi_start = line;
+ multi_start = curcmd->c_line;
if (hereis)
multi_open = multi_close = '<';
else {
multi_open = term;
- if (tmps = index("([{< )]}> )]}>",term))
+ if (term && (tmps = index("([{< )]}> )]}>",term)))
term = tmps[5];
multi_close = term;
}
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);
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(stab_xarray(curcmd->c_filestab),
+ (int)curcmd->c_line,str);
}
bufend = linestr->str_ptr + linestr->str_cur;
if (hereis) {
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;
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] != '|'))) {
makesingle = FALSE; /* force interpretation */
}
else if (*s == '\\' && s+1 < send) {
+ if (index("lLuUE",s[1]))
+ makesingle = FALSE;
s++;
}
s++;
if ((*s == '$' && s+1 < send &&
(alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
(*s == '@' && s+1 < send) ) {
- len = scanreg(s,send,tokenbuf) - s;
+ len = scanident(s,send,tokenbuf) - s;
if (*s == '$' || strEQ(tokenbuf,"ARGV")
|| strEQ(tokenbuf,"ENV")
|| strEQ(tokenbuf,"SIG")
continue;
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
- *d = *s++ - '0';
- if (s < send && *s && index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- if (s < send && *s && index("01234567",*s)) {
- *d <<= 3;
- *d += *s++ - '0';
- }
- d++;
+ *d++ = scanoct(s, 3, &len);
+ s += len;
+ continue;
+ case 'x':
+ *d++ = scanhex(++s, 2, &len);
+ s += len;
+ continue;
+ case 'c':
+ s++;
+ *d = *s++;
+ if (islower(*d))
+ *d = toupper(*d);
+ *d++ ^= 64;
continue;
case 'b':
*d++ = '\b';
case 't':
*d++ = '\t';
break;
+ case 'e':
+ *d++ = '\033';
+ break;
+ case 'a':
+ *d++ = '\007';
+ break;
}
s++;
continue;
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;
{
FCMD froot;
FCMD *flinebeg;
+ char *eol;
register FCMD *fprev = &froot;
register FCMD *fcmd;
register char *s;
bool repeater;
Zero(&froot, 1, FCMD);
- while ((s = str_gets(linestr,rsfp, 0)) != Nullch) {
- line++;
+ s = bufptr;
+ while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
+ curcmd->c_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->str_ptr + linestr->str_cur;
if (perldb) {
STR *tmpstr = Str_new(89,0);
- str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ str_nset(tmpstr, s, eol-s);
+ astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
}
- bufend = linestr->str_ptr + linestr->str_cur;
- if (strEQ(s,".\n")) {
- bufptr = s;
- return froot.f_next;
+ if (*s == '.') {
+ for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n') {
+ bufptr = s;
+ return froot.f_next;
+ }
}
- if (*s == '#')
+ if (*s == '#') {
+ s = eol;
continue;
+ }
flinebeg = Nullfcmd;
noblank = FALSE;
repeater = FALSE;
- while (s < bufend) {
+ while (s < eol) {
Newz(804,fcmd,1,FCMD);
fprev->f_next = fcmd;
fprev = fcmd;
- for (t=s; t < bufend && *t != '@' && *t != '^'; t++) {
+ for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
if (*t == '~') {
noblank = TRUE;
*t = ' ';
fcmd->f_pre = nsavestr(s, t-s);
fcmd->f_presize = t-s;
s = t;
- if (s >= bufend) {
+ if (s >= eol) {
if (noblank)
fcmd->f_flags |= FC_NOBLANK;
if (repeater)
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 (flinebeg) {
again:
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
+ if (s >= bufend &&
+ (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
goto badform;
- line++;
+ curcmd->c_line++;
+ if (in_eval && !rsfp) {
+ eol = index(s,'\n');
+ if (!eol++)
+ eol = bufend;
+ }
+ else
+ eol = bufend = linestr->str_ptr + linestr->str_cur;
if (perldb) {
STR *tmpstr = Str_new(90,0);
- str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ str_nset(tmpstr, s, eol-s);
+ astore(stab_xarray(curcmd->c_filestab),
+ (int)curcmd->c_line,tmpstr);
}
- if (strEQ(s,".\n")) {
+ if (strnEQ(s,".\n",2)) {
bufptr = s;
yyerror("Missing values line");
return froot.f_next;
}
- if (*s == '#')
+ if (*s == '#') {
+ s = eol;
goto again;
- bufend = linestr->str_ptr + linestr->str_cur;
- str = flinebeg->f_unparsed = Str_new(91,bufend - bufptr);
+ }
+ str = flinebeg->f_unparsed = Str_new(91,eol - s);
str->str_u.str_hash = curstash;
str_nset(str,"(",1);
- flinebeg->f_line = line;
- if (!flinebeg->f_next->f_type || index(linestr->str_ptr, ',')) {
- str_scat(str,linestr);
+ flinebeg->f_line = curcmd->c_line;
+ eol[-1] = '\0';
+ if (!flinebeg->f_next->f_type || index(s, ',')) {
+ eol[-1] = '\n';
+ str_ncat(str, s, eol - s - 1);
str_ncat(str,",$$);",5);
+ s = eol;
}
else {
- while (s < bufend && isspace(*s))
+ eol[-1] = '\n';
+ while (s < eol && isspace(*s))
s++;
t = s;
- while (s < bufend) {
+ while (s < eol) {
switch (*s) {
case ' ': case '\t': case '\n': case ';':
str_ncat(str, t, s - t);
str_ncat(str, "," ,1);
- while (s < bufend && (isspace(*s) || *s == ';'))
+ while (s < eol && (isspace(*s) || *s == ';'))
s++;
t = s;
break;
case '$':
str_ncat(str, t, s - t);
t = s;
- s = scanreg(s,bufend,tokenbuf);
+ s = scanident(s,eol,tokenbuf);
str_ncat(str, t, s - t);
t = s;
- if (s < bufend && *s && index("$'\"",*s))
+ if (s < eol && *s && index("$'\"",*s))
str_ncat(str, ",", 1);
break;
case '"': case '\'':
str_ncat(str, t, s - t);
t = s;
s++;
- while (s < bufend && (*s != *t || s[-1] == '\\'))
+ while (s < eol && (*s != *t || s[-1] == '\\'))
s++;
- if (s < bufend)
+ if (s < eol)
s++;
str_ncat(str, t, s - t);
t = s;
- if (s < bufend && *s && index("$'\"",*s))
+ if (s < eol && *s && index("$'\"",*s))
str_ncat(str, ",", 1);
break;
default:
https://perl5.git.perl.org / perl5.git / blobdiff