toke.c

早期freebsd实现

/* $RCSfile: toke.c,v $$Revision: 4.0.1.9 $$Date: 1993/02/05 19:48:43 $
 *
 *    Copyright (c) 1991, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 * $Log: toke.c,v $
 * Revision 4.0.1.9  1993/02/05  19:48:43  lwall
 * patch36: now detects ambiguous use of filetest operators as well as unary
 * patch36: fixed ambiguity on - within tr///
 *
 * Revision 4.0.1.8  92/06/23  12:33:45  lwall
 * patch35: bad interaction between backslash and hyphen in tr///
 * 
 * Revision 4.0.1.7  92/06/11  21:16:30  lwall
 * patch34: expectterm incorrectly set to indicate start of program or block
 * 
 * Revision 4.0.1.6  92/06/08  16:03:49  lwall
 * patch20: an EXPR may now start with a bareword
 * patch20: print $fh EXPR can now expect term rather than operator in EXPR
 * patch20: added ... as variant on ..
 * patch20: new warning on spurious backslash
 * patch20: new warning on missing $ for foreach variable
 * patch20: "foo"x1024 now legal without space after x
 * patch20: new warning on print accidentally used as function
 * patch20: tr/stuff// wasn't working right
 * patch20: 2. now eats the dot
 * patch20: <@ARGV> now notices @ARGV
 * patch20: tr/// now lets you say \-
 * 
 * Revision 4.0.1.5  91/11/11  16:45:51  lwall
 * patch19: default arg for shift was wrong after first subroutine definition
 * 
 * Revision 4.0.1.4  91/11/05  19:02:48  lwall
 * patch11: \x and \c were subject to double interpretation in regexps
 * patch11: prepared for ctype implementations that don't define isascii()
 * patch11: nested list operators could miscount parens
 * patch11: once-thru blocks didn't display right in the debugger
 * patch11: sort eval "whatever" didn't work
 * patch11: underscore is now allowed within literal octal and hex numbers
 * 
 * Revision 4.0.1.3  91/06/10  01:32:26  lwall
 * patch10: m'$foo' now treats string as single quoted
 * patch10: certain pattern optimizations were botched
 * 
 * Revision 4.0.1.2  91/06/07  12:05:56  lwall
 * patch4: new copyright notice
 * patch4: debugger lost track of lines in eval
 * patch4: //o and s///o now optimize themselves fully at runtime
 * patch4: added global modifier for pattern matches
 * 
 * Revision 4.0.1.1  91/04/12  09:18:18  lwall
 * patch1: perl -de "print" wouldn't stop at the first statement
 * 
 * Revision 4.0  91/03/20  01:42:14  lwall
 * 4.0 baseline.
 * 
 */

#include "EXTERN.h"
#include "perl.h"
#include "perly.h"

static void set_csh();

#ifdef I_FCNTL
#include <fcntl.h>
#endif
#ifdef I_SYS_FILE
#include <sys/file.h>
#endif

#ifdef f_next
#undef f_next
#endif

/* which backslash sequences to keep in m// or s// */

static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}";

char *reparse;		/* if non-null, scanident found ${foo[$bar]} */

void checkcomma();

#ifdef CLINE
#undef CLINE
#endif
#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline))

#ifdef atarist
#define PERL_META(c) ((c) | 128)
#else
#define META(c) ((c) | 128)
#endif

#define RETURN(retval) return (bufptr = s,(int)retval)
#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval)
#define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval)
#define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX)
#define FTST(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)FILETEST)
#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 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)
#define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP)
#define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP)
#define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2)
#define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3)
#define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4)
#define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22)
#define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25)

static char *last_uni;

/* This bit of chicanery makes a unary function followed by
 * a parenthesis into a function with one argument, highest precedence.
 */
#define UNI(f) return(yylval.ival = f, \
	expectterm = TRUE, \
	bufptr = s, \
	last_uni = oldbufptr, \
	(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )

/* This does similarly for list operators, merely by pretending that the
 * paren came before the listop rather than after.
 */
#ifdef atarist
#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
	(*s = (char) PERL_META('('), bufptr = oldbufptr, '(') : \
	(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
#else
#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \
	(*s = (char) META('('), bufptr = oldbufptr, '(') : \
	(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
#endif
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)

char *
skipspace(s)
register char *s;
{
    while (s < bufend && isSPACE(*s))
	s++;
    return s;
}

void
check_uni() {
    char *s;
    char ch;

    if (oldoldbufptr != last_uni)
	return;
    while (isSPACE(*last_uni))
	last_uni++;
    for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ;
    ch = *s;
    *s = '\0';
    warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni);
    *s = ch;
}

#ifdef CRIPPLED_CC

#undef UNI
#undef LOP
#define UNI(f) return uni(f,s)
#define LOP(f) return lop(f,s)

int
uni(f,s)
int f;
char *s;
{
    yylval.ival = f;
    expectterm = TRUE;
    bufptr = s;
    last_uni = oldbufptr;
    if (*s == '(')
	return FUNC1;
    s = skipspace(s);
    if (*s == '(')
	return FUNC1;
    else
	return UNIOP;
}

int
lop(f,s)
int f;
char *s;
{
    CLINE;
    if (*s != '(')
	s = skipspace(s);
    if (*s == '(') {
#ifdef atarist
	*s = PERL_META('(');
#else
	*s = META('(');
#endif
	bufptr = oldbufptr;
	return '(';
    }
    else {
	yylval.ival=f;
	expectterm = TRUE;
	bufptr = s;
	return LISTOP;
    }
}

#endif /* CRIPPLED_CC */

int
yylex()
{
    register char *s = bufptr;
    register char *d;
    register int tmp;
    static bool in_format = FALSE;
    static bool firstline = TRUE;
    extern int yychar;		/* last token */

    oldoldbufptr = oldbufptr;
    oldbufptr = s;

  retry:
#ifdef YYDEBUG
    if (debug & 1)
	if (index(s,'\n'))
	    fprintf(stderr,"Tokener at %s",s);
	else
	    fprintf(stderr,"Tokener at %s\n",s);
#endif
#ifdef BADSWITCH
    if (*s & 128) {
	if ((*s & 127) == '(') {
	    *s++ = '(';
	    oldbufptr = s;
	}
	else if ((*s & 127) == '}') {
	    *s++ = '}';
	    RETURN('}');
	}
	else
	    warn("Unrecognized character \\%03o ignored", *s++ & 255);
	goto retry;
    }
#endif
    switch (*s) {
    default:
	if ((*s & 127) == '(') {
	    *s++ = '(';
	    oldbufptr = s;
	}
	else if ((*s & 127) == '}') {
	    *s++ = '}';
	    RETURN('}');
	}
	else
	    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);
	if (s++ < bufend)
	    goto retry;			/* ignore stray nulls */
	last_uni = 0;
	if (firstline) {
	    firstline = FALSE;
	    if (minus_n || minus_p || perldb) {
		str_set(linestr,"");
		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(' ');");
		}
		oldoldbufptr = oldbufptr = s = str_get(linestr);
		bufend = linestr->str_ptr + linestr->str_cur;
		goto retry;
	    }
	}
	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;
	    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 ((FILE*)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);
		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(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str);
	}
#ifdef DEBUG
	if (firstline) {
	    char *showinput();
	    s = showinput();
	}
#endif
	bufend = linestr->str_ptr + linestr->str_cur;
	if (curcmd->c_line == 1) {
	    if (*s == '#' && s[1] == '!') {
		if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
		    char **newargv;
		    char *cmd;

		    s += 2;
		    if (*s == ' ')
			s++;
		    cmd = s;
		    while (s < bufend && !isSPACE(*s))
			s++;
		    *s++ = '\0';
		    while (s < bufend && isSPACE(*s))
			s++;
		    if (s < bufend) {
			Newz(899,newargv,origargc+3,char*);
			newargv[1] = s;
			while (s < bufend && !isSPACE(*s))
			    s++;
			*s = '\0';
			Copy(origargv+1, newargv+2, origargc+1, char*);
		    }
		    else
			newargv = origargv;
		    newargv[0] = cmd;
		    execv(cmd,newargv);
		    fatal("Can't exec %s", cmd);
		}
	    }
	    else {
		while (s < bufend && isSPACE(*s))
		    s++;
		if (*s == ':')	/* for csh's that have to exec sh scripts */
		    s++;
	    }
	}
	goto retry;
    case ' ': case '\t': case '\f': case '\r': case 013:
	s++;
	goto retry;
    case '#':
	if (preprocess && s == str_get(linestr) &&
	       s[1] == ' ' && (isDIGIT(s[2]) || strnEQ(s+2,"line ",5)) ) {
	    while (*s && !isDIGIT(*s))
		s++;
	    curcmd->c_line = atoi(s)-1;
	    while (isDIGIT(*s))
		s++;
	    d = bufend;
	    while (s < d && isSPACE(*s)) s++;
	    s[strlen(s)-1] = '\0';	/* wipe out newline */
	    if (*s == '"') {
		s++;
		s[strlen(s)-1] = '\0';	/* wipe out trailing quote */
	    }
	    if (*s)
		curcmd->c_filestab = fstab(s);
	    else
		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)
		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';
	    bufend = s;
	}
	goto retry;
    case '-':
	if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) {
	    s++;
	    last_uni = oldbufptr;
	    switch (*s++) {
	    case 'r': FTST(O_FTEREAD);
	    case 'w': FTST(O_FTEWRITE);
	    case 'x': FTST(O_FTEEXEC);
	    case 'o': FTST(O_FTEOWNED);
	    case 'R': FTST(O_FTRREAD);
	    case 'W': FTST(O_FTRWRITE);
	    case 'X': FTST(O_FTREXEC);
	    case 'O': FTST(O_FTROWNED);
	    case 'e': FTST(O_FTIS);
	    case 'z': FTST(O_FTZERO);
	    case 's': FTST(O_FTSIZE);
	    case 'f': FTST(O_FTFILE);
	    case 'd': FTST(O_FTDIR);
	    case 'l': FTST(O_FTLINK);
	    case 'p': FTST(O_FTPIPE);
	    case 'S': FTST(O_FTSOCK);
	    case 'u': FTST(O_FTSUID);
	    case 'g': FTST(O_FTSGID);
	    case 'k': FTST(O_FTSVTX);
	    case 'b': FTST(O_FTBLK);
	    case 'c': FTST(O_FTCHR);
	    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 (*s == tmp) {
	    s++;
	    RETURN(DEC);
	}
	if (expectterm) {
	    if (isSPACE(*s) || !isSPACE(*bufptr))
		check_uni();
	    OPERATOR('-');
	}
	else
	    AOP(O_SUBTRACT);
    case '+':
	tmp = *s++;
	if (*s == tmp) {
	    s++;
	    RETURN(INC);
	}
	if (expectterm) {
	    if (isSPACE(*s) || !isSPACE(*bufptr))
		check_uni();
	    OPERATOR('+');
	}
	else
	    AOP(O_ADD);

    case '*':
	if (expectterm) {
	    check_uni();
	    s = scanident(s,bufend,tokenbuf);
	    yylval.stabval = stabent(tokenbuf,TRUE);
	    TERM(STAR);
	}
	tmp = *s++;
	if (*s == tmp) {
	    s++;
	    OPERATOR(POW);
	}
	MOP(O_MULTIPLY);
    case '%':
	if (expectterm) {
	    if (!isALPHA(s[1]))
		check_uni();
	    s = scanident(s,bufend,tokenbuf);
	    yylval.stabval = hadd(stabent(tokenbuf,TRUE));
	    TERM(HSH);
	}
	s++;
	MOP(O_MODULO);

    case '^':
    case '~':
    case '(':
    case ',':
    case ':':
    case '[':
	tmp = *s++;
	OPERATOR(tmp);
    case '{':
	tmp = *s++;
	yylval.ival = curcmd->c_line;
	if (isSPACE(*s) || *s == '#')
	    cmdline = NOLINE;   /* invalidate current command line number */
	expectterm = 2;
	RETURN(tmp);
    case ';':
	if (curcmd->c_line < cmdline)
	    cmdline = curcmd->c_line;
	tmp = *s++;
	OPERATOR(tmp);
    case ')':