-/* $Header: toke.c,v 3.0.1.7 90/03/27 16:32:37 lwall Locked $
+/* $Header: toke.c,v 3.0.1.8 90/08/09 05:39:58 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: toke.c,v $
+ * Revision 3.0.1.8 90/08/09 05:39:58 lwall
+ * patch19: added require operator
+ * patch19: added -x switch to extract script from input trash
+ * patch19: bare @name didn't add array to symbol table
+ * patch19: Added __LINE__ and __FILE__ tokens
+ * patch19: Added __END__ token
+ * patch19: Numeric literals are now stored only in floating point
+ * patch19: some support for FPS compiler misfunction
+ * patch19: "\\$foo" not handled right
+ * patch19: program and data can now both come from STDIN
+ * patch19: "here" strings caused warnings about uninitialized variables
+ *
* Revision 3.0.1.7 90/03/27 16:32:37 lwall
* patch16: MSDOS support
* patch16: formats didn't work inside eval
#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)
else
fprintf(stderr,"Tokener at %s\n",s);
#endif
+#ifdef BADSWITCH
+ if (*s & 128) {
+ if ((*s & 127) == '(')
+ *s++ = '(';
+ else
+ warn("Unrecognized character \\%03o ignored", *s++);
+ goto retry;
+ }
+#endif
switch (*s) {
default:
if ((*s & 127) == '(')
else
warn("Unrecognized character \\%03o ignored", *s++);
goto retry;
+ case 4:
+ case 26:
+ goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
if (!rsfp)
RETURN(0);
if (minus_n || minus_p || perldb) {
str_set(linestr,"");
if (perldb)
- str_cat(linestr,
-"do 'perldb.pl' || die \"Can't find perldb.pl in @INC\"; print $@;");
+ str_cat(linestr, "require 'perldb.pl';");
if (minus_n || minus_p) {
str_cat(linestr,"line: while (<>) {");
if (minus_a)
in_format = FALSE;
oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
bufend = linestr->str_ptr + linestr->str_cur;
- TERM(FORMLIST);
- }
- line++;
- if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
- if (preprocess)
- (void)mypclose(rsfp);
- else if (rsfp != stdin)
- (void)fclose(rsfp);
- rsfp = Nullfp;
- if (minus_n || minus_p) {
- str_set(linestr,minus_p ? ";}continue{print" : "");
- str_cat(linestr,";}");
+ OPERATOR(FORMLIST);
+ }
+ curcmd->c_line++;
+#ifdef CRYPTSCRIPT
+ cryptswitch();
+#endif /* CRYPTSCRIPT */
+ do {
+ if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (preprocess)
+ (void)mypclose(rsfp);
+ else if (rsfp == stdin)
+ clearerr(stdin);
+ else
+ (void)fclose(rsfp);
+ rsfp = Nullfp;
+ if (minus_n || minus_p) {
+ str_set(linestr,minus_p ? ";}continue{print" : "");
+ str_cat(linestr,";}");
+ oldoldbufptr = oldbufptr = s = str_get(linestr);
+ bufend = linestr->str_ptr + linestr->str_cur;
+ minus_n = minus_p = 0;
+ goto retry;
+ }
oldoldbufptr = oldbufptr = s = str_get(linestr);
- bufend = linestr->str_ptr + linestr->str_cur;
- minus_n = minus_p = 0;
- goto retry;
+ str_set(linestr,"");
+ RETURN(';'); /* not infinite loop because rsfp is NULL now */
}
- oldoldbufptr = oldbufptr = s = str_get(linestr);
- str_set(linestr,"");
- RETURN(';'); /* not infinite loop because rsfp is NULL now */
- }
+ if (doextract && *linestr->str_ptr == '#')
+ doextract = FALSE;
+ } while (doextract);
oldoldbufptr = oldbufptr = bufptr = s;
if (perldb) {
STR *str = Str_new(85,0);
str_sset(str,linestr);
- astore(lineary,(int)line,str);
+ astore(lineary,(int)curcmd->c_line,str);
}
#ifdef DEBUG
if (firstline) {
}
#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;
case ' ': case '\t': case '\f':
s++;
goto retry;
- case '\n':
case '#':
if (preprocess && s == str_get(linestr) &&
s[1] == ' ' && isdigit(s[2])) {
- line = atoi(s+2)-1;
+ curcmd->c_line = atoi(s+2)-1;
for (s += 2; isdigit(*s); s++) ;
d = bufend;
while (s < d && isspace(*s)) s++;
- if (filename)
- Safefree(filename);
s[strlen(s)-1] = '\0'; /* wipe out newline */
if (*s == '"') {
s++;
if (*s)
filename = savestr(s);
else
- filename = savestr(origfilename);
+ filename = origfilename;
oldoldbufptr = oldbufptr = s = str_get(linestr);
}
+ /* FALL THROUGH */
+ case '\n':
if (in_eval && !rsfp) {
d = bufend;
while (s < d && *s != '\n')
oldoldbufptr = oldbufptr = s = bufptr + 1;
TERM(FORMLIST);
}
- line++;
+ curcmd->c_line++;
}
else {
*s = '\0';
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 ')':
s = scanreg(s,bufend,tokenbuf);
if (reparse)
goto do_reparse;
- yylval.stabval = stabent(tokenbuf,TRUE);
+ yylval.stabval = aadd(stabent(tokenbuf,TRUE));
TERM(ARY);
case '/': /* may either be division or pattern */
/* FALL THROUGH */
case '_':
SNARFWORD;
+ if (d[1] == '_') {
+ if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) {
+ ARG *arg = op_new(1);
+
+ yylval.arg = arg;
+ arg->arg_type = O_ITEM;
+ if (d[2] == 'L')
+ (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line);
+ else
+ strcpy(tokenbuf, filename);
+ arg[1].arg_type = A_SINGLE;
+ arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf));
+ TERM(RSTRING);
+ }
+ else if (strEQ(d,"__END__"))
+ goto fake_eof;
+ }
break;
case 'a': case 'A':
SNARFWORD;
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"))
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"))
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"))
break;
case 'e':
if (strEQ(d,"select"))
- OPERATOR(SELECT);
+ OPERATOR(SSELECT);
if (strEQ(d,"seek"))
FOP3(O_SEEK);
if (strEQ(d,"send"))
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;
if (strEQ(d,"substr"))
FUN3(O_SUBSTR);
if (strEQ(d,"sub")) {
- subline = line;
+ subline = curcmd->c_line;
d = bufend;
while (s < d && isspace(*s))
s++;
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"))
register char *s;
char *what;
{
+ char *word;
+
if (*s == '(')
s++;
while (s < bufend && isascii(*s) && isspace(*s))
s++;
if (isascii(*s) && (isalpha(*s) || *s == '_')) {
- s++;
+ word = s++;
while (isalpha(*s) || isdigit(*s) || *s == '_')
s++;
while (s < bufend && isspace(*s))
s++;
- if (*s == ',')
+ if (*s == ',') {
+ *s = '\0';
+ word = instr(
+ "tell eof times getlogin wait length shift umask getppid \
+ cos exp int log rand sin sqrt ord wantarray",
+ word);
+ *s = ',';
+ if (word)
+ return;
fatal("No comma allowed after %s", what);
+ }
}
}
}
e = tokenbuf + len;
for (d=tokenbuf; d < e; d++) {
- if ((*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') ||
- (*d == '@' && d[-1] != '\\')) {
+ if (*d == '\\')
+ d++;
+ else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') ||
+ (*d == '@')) {
register ARG *arg;
spat->spat_runtime = arg = op_new(1);
d = scanreg(d,bufend,buf);
(void)stabent(buf,TRUE); /* make sure it's created */
for (; d < e; d++) {
- if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') {
+ if (*d == '\\')
+ d++;
+ else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') {
d = scanreg(d,bufend,buf);
(void)stabent(buf,TRUE);
}
- else if (*d == '@' && d[-1] != '\\') {
+ else if (*d == '@') {
d = scanreg(d,bufend,buf);
if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") ||
strEQ(buf,"SIG") || strEQ(buf,"INC"))
if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) {
fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD);
spat->spat_regexp = regcomp(tokenbuf,tokenbuf+len,
- spat->spat_flags & SPAT_FOLD,1);
+ spat->spat_flags & SPAT_FOLD);
/* Note that this regexp can still be used if someone says
* something like /a/ && s//b/; so we can't delete it.
*/
int len;
int *retlen;
{
- char t[512];
+ char t[520];
register char *d = t;
register int i;
register char *send = s + len;
- while (s < send) {
+ while (s < send && d - t <= 256) {
if (s[1] == '-' && s+2 < send) {
for (i = s[0]; i <= s[2]; i++)
*d++ = i;
bool alwaysdollar = FALSE;
bool hereis = FALSE;
STR *herewas;
+ STR *str;
char *leave = "\\$@nrtfb0123456789[{]}"; /* which backslash sequences to keep */
int len;
}
}
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 == '<') {
}
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();
STR *tmpstr;
char *tmps;
- multi_start = line;
+ multi_start = curcmd->c_line;
if (hereis)
multi_open = multi_close = '<';
else {
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(lineary,(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] != '|'))) {
Zero(&froot, 1, FCMD);
s = bufptr;
while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) {
- line++;
+ curcmd->c_line++;
if (perldb) {
STR *tmpstr = Str_new(89,0);
str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ astore(lineary,(int)curcmd->c_line,tmpstr);
}
if (in_eval && !rsfp) {
eol = index(s,'\n');
again:
if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch)
goto badform;
- line++;
+ curcmd->c_line++;
if (perldb) {
STR *tmpstr = Str_new(90,0);
str_sset(tmpstr,linestr);
- astore(lineary,(int)line,tmpstr);
+ astore(lineary,(int)curcmd->c_line,tmpstr);
}
if (in_eval && !rsfp) {
eol = index(s,'\n');
str = flinebeg->f_unparsed = Str_new(91,eol - s);
str->str_u.str_hash = curstash;
str_nset(str,"(",1);
- flinebeg->f_line = line;
+ flinebeg->f_line = curcmd->c_line;
eol[-1] = '\0';
if (!flinebeg->f_next->f_type || index(s, ',')) {
eol[-1] = '\n';
projects / p5sagit/p5-mst-13.2.git / blobdiff