#include "EXTERN.h"
#include "perl.h"
+#ifndef PERL_OBJECT
static void check_uni _((void));
static void force_next _((I32 type));
static char *force_version _((char *start));
static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
-static SV *q _((SV *sv));
+static SV *tokeq _((SV *sv));
static char *scan_const _((char *start));
static char *scan_formline _((char *s));
static char *scan_heredoc _((char *s));
static void restore_rsfp _((void *f));
static void restore_expect _((void *e));
static void restore_lex_expect _((void *e));
+#endif /* PERL_OBJECT */
static char ident_too_long[] = "Identifier too long";
-static char *linestart; /* beg. of most recently read line */
-
-static char pending_ident; /* pending identifier lookup */
-
-static struct {
- I32 super_state; /* lexer state to save */
- I32 sub_inwhat; /* "lex_inwhat" to use */
- OP *sub_op; /* "lex_op" to use */
-} sublex_info;
-
/* The following are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
*/
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
-static int
+STATIC int
ao(int toketype)
{
if (*bufptr == '=') {
return toketype;
}
-static void
+STATIC void
no_op(char *what, char *s)
{
char *oldbp = bufptr;
bufptr = oldbp;
}
-static void
+STATIC void
missingterm(char *s)
{
char tmpbuf[3];
char q;
if (s) {
char *nl = strrchr(s,'\n');
- if (nl)
+ if (nl)
*nl = '\0';
}
else if (multi_close < 32 || multi_close == 127) {
warn("Use of %s is deprecated", s);
}
-static void
+STATIC void
depcom(void)
{
deprecate("comma-less variable list");
#ifdef WIN32
-static I32
+STATIC I32
win32_textfilter(int idx, SV *sv, int maxlen)
{
I32 count = FILTER_READ(idx+1, sv, maxlen);
doextract = FALSE;
}
-static void
+STATIC void
restore_rsfp(void *f)
{
PerlIO *fp = (PerlIO*)f;
rsfp = fp;
}
-static void
-restore_expect(e)
-void *e;
+STATIC void
+restore_expect(void *e)
{
/* a safe way to store a small integer in a pointer */
expect = (expectation)((char *)e - tokenbuf);
}
-static void
-restore_lex_expect(e)
-void *e;
+STATIC void
+restore_lex_expect(void *e)
{
/* a safe way to store a small integer in a pointer */
lex_expect = (expectation)((char *)e - tokenbuf);
}
-static void
+STATIC void
incline(char *s)
{
dTHR;
curcop->cop_line = atoi(n)-1;
}
-static char *
+STATIC char *
skipspace(register char *s)
{
dTHR;
PerlIO_clearerr(rsfp);
else
(void)PerlIO_close(rsfp);
- if (e_fp == rsfp)
- e_fp = Nullfp;
rsfp = Nullfp;
return s;
}
}
}
-static void
+STATIC void
check_uni(void) {
char *s;
char ch;
#undef UNI
#define UNI(f) return uni(f,s)
-static int
+STATIC int
uni(I32 f, char *s)
{
yylval.ival = f;
#define LOP(f,x) return lop(f,x,s)
-static I32
+STATIC I32
lop(I32 f, expectation x, char *s)
{
dTHR;
return LSTOP;
}
-static void
+STATIC void
force_next(I32 type)
{
nexttype[nexttoke] = type;
}
}
-static char *
+STATIC char *
force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
register char *s;
return s;
}
-static void
+STATIC void
force_ident(register char *s, int kind)
{
if (s && *s) {
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
- gv_fetchpv(s, in_eval ? GV_ADDMULTI : TRUE,
+ gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
}
}
-static char *
+STATIC char *
force_version(char *s)
{
OP *version = Nullop;
return (s);
}
-static SV *
-q(SV *sv)
+STATIC SV *
+tokeq(SV *sv)
{
register char *s;
register char *send;
return sv;
}
-static I32
+STATIC I32
sublex_start(void)
{
register I32 op_type = yylval.ival;
return THING;
}
if (op_type == OP_CONST || op_type == OP_READLINE) {
- SV *sv = q(lex_stuff);
+ SV *sv = tokeq(lex_stuff);
STRLEN len;
char *p = SvPV(sv, len);
yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
return FUNC;
}
-static I32
+STATIC I32
sublex_push(void)
{
dTHR;
return '(';
}
-static I32
+STATIC I32
sublex_done(void)
{
if (!lex_starts++) {
processing a pattern (lex_inpat is true), a transliteration
(lex_inwhat & OP_TRANS is true), or a double-quoted string.
+ Returns a pointer to the character scanned up to. Iff this is
+ advanced from the start pointer supplied (ie if anything was
+ successfully parsed), will leave an OP for the substring scanned
+ in yylval. Caller must intuit reason for not parsing further
+ by looking at the next characters herself.
+
In patterns:
backslashes:
double-quoted style: \r and \n
*/
-static char *
+STATIC char *
scan_const(char *start)
{
register char *send = bufend; /* end of the constant */
bool dorange = FALSE; /* are we in a translit range? */
I32 len; /* ? */
- /*
- leave is the set of acceptably-backslashed characters.
-
- I do *not* understand why there's the double hook here.
- */
+ /* leaveit is the set of acceptably-backslashed characters */
char *leaveit =
lex_inpat
? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
- : (lex_inwhat & OP_TRANS)
- ? ""
- : "";
+ : "";
while (s < send || dorange) {
/* get transliterations out of the way (they're most literal) */
Renew(SvPVX(sv), SvLEN(sv), char);
}
- /* ??? */
+ /* return the substring (via yylval) only if we parsed anything */
if (s > bufptr)
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
else
}
/* This is the one truly awful dwimmer necessary to conflate C and sed. */
-static int
+STATIC int
intuit_more(register char *s)
{
if (lex_brackets)
else {
int weight = 2; /* let's weigh the evidence */
char seen[256];
- unsigned char un_char = 0, last_un_char;
+ unsigned char un_char = 255, last_un_char;
char *send = strchr(s,']');
char tmpbuf[sizeof tokenbuf * 4];
weight += 30;
if (strchr("zZ79~",s[1]))
weight += 30;
+ if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
+ weight -= 5; /* cope with negative subscript */
break;
default:
if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
return TRUE;
}
-static int
+STATIC int
intuit_method(char *start, GV *gv)
{
char *s = start + (*start == '$');
return *s == '(' ? FUNCMETH : METHOD;
}
if (!keyword(tmpbuf, len)) {
- indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV);
+ if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
+ len -= 2;
+ tmpbuf[len] = '\0';
+ goto bare_package;
+ }
+ indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
s = skipspace(s);
if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bearword */
- nextval[nexttoke].opval =
- (OP*)newSVOP(OP_CONST, 0,
- newSVpv(tmpbuf,0));
- nextval[nexttoke].opval->op_private =
- OPpCONST_BARE;
+ bare_package:
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpv(tmpbuf,0));
+ nextval[nexttoke].opval->op_private = OPpCONST_BARE;
expect = XTERM;
force_next(WORD);
bufptr = s;
return 0;
}
-static char*
+STATIC char*
incl_perldb(void)
{
if (perldb) {
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
- return (*funcp)(idx, buf_sv, maxlen);
+ return (*funcp)(THIS_ idx, buf_sv, maxlen);
}
-static char *
+STATIC char *
filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
{
#ifdef WIN32FILTER
/* build ops for a bareword */
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE,
+ gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
((tokenbuf[0] == '$') ? SVt_PV
: (tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
if (SvIVX(linestr) == '\'') {
SV *sv = newSVsv(linestr);
if (!lex_inpat)
- sv = q(sv);
+ sv = tokeq(sv);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = bufend;
}
PerlIO_clearerr(rsfp);
else
(void)PerlIO_close(rsfp);
- if (e_fp == rsfp)
- e_fp = Nullfp;
rsfp = Nullfp;
}
if (!in_eval && (minus_n || minus_p)) {
s++;
if (strnEQ(s,"=>",2)) {
- if (dowarn)
- warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
- (int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
}
d++;
if (*d == '}') {
char minus = (tokenbuf[0] == '-');
- if (dowarn &&
- (keyword(tokenbuf + 1, len) ||
- (minus && len == 1 && isALPHA(tokenbuf[1])) ||
- perl_get_cv(tokenbuf + 1, FALSE) ))
- warn("Ambiguous use of {%s} resolved to {\"%s\"}",
- tokenbuf + !minus, tokenbuf + !minus);
s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
if (minus)
force_next('-');
else
lex_brackstack[lex_brackets++] = XOPERATOR;
s = skipspace(s);
- if (*s == '}') {
- if (expect == XSTATE) {
- lex_brackstack[lex_brackets-1] = XSTATE;
- break;
- }
+ if (*s == '}')
OPERATOR(HASHBRACK);
- }
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
/* Is this a word before a => operator? */
if (strnEQ(d,"=>",2)) {
CLINE;
- if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE)))
- warn("Ambiguous use of %s => resolved to \"%s\" =>",
- tokenbuf, tokenbuf);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
TERM(WORD);
/* Get the rest if it looks like a package qualifier */
if (*s == '\'' || *s == ':' && s[1] == ':') {
+ STRLEN morelen;
s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
- TRUE, &len);
- if (!len)
- croak("Bad name after %s::", tokenbuf);
+ TRUE, &morelen);
+ if (!morelen)
+ croak("Bad name after %s%s", tokenbuf,
+ *s == '\'' ? "'" : "::");
+ len += morelen;
}
if (expect == XOPERATOR) {
no_op("Bareword",s);
}
- /* Look for a subroutine with this name in current package. */
+ /* Look for a subroutine with this name in current package,
+ unless name is "Foo::", in which case Foo is a bearword
+ (and a package name). */
+
+ if (len > 2 &&
+ tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
+ {
+ if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
+ warn("Bareword \"%s\" refers to nonexistent package",
+ tokenbuf);
+ len -= 2;
+ tokenbuf[len] = '\0';
+ gv = Nullgv;
+ gvp = 0;
+ }
+ else {
+ len = 0;
+ if (!gv)
+ gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV);
+ }
+
+ /* if we saw a global override before, get the right name */
if (gvp) {
sv = newSVpv("CORE::GLOBAL::",14);
}
else
sv = newSVpv(tokenbuf,0);
- if (!gv)
- gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV);
/* Presume this is going to be a bareword of some sort. */
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
yylval.opval->op_private = OPpCONST_BARE;
+ /* And if "Foo::", then that's what it certainly is. */
+
+ if (len)
+ goto safe_bareword;
+
/* See if it's the indirect object for a list operator. */
if (oldoldbufptr &&
warn(warn_reserved, tokenbuf);
}
}
+
+ safe_bareword:
if (lastchar && strchr("*%&", lastchar)) {
warn("Operator or semicolon missing before %c%s",
lastchar, tokenbuf);
}
}
force_next(')');
- nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
+ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(lex_stuff));
lex_stuff = Nullsv;
force_next(THING);
force_next(',');
return 0;
}
-static void
+STATIC void
checkcomma(register char *s, char *name, char *what)
{
char *w;
}
}
-static char *
+STATIC char *
scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
register char *d = dest;
*d++ = ':';
s++;
}
- else if (*s == ':' && s[1] == ':' && allow_package && isIDFIRST(s[2])) {
+ else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
*d++ = *s++;
*d++ = *s++;
}
}
}
-static char *
+STATIC char *
scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
{
register char *d;
*pmfl |= PMf_MULTILINE;
else if (ch == 's')
*pmfl |= PMf_SINGLELINE;
+ else if (ch == 't')
+ *pmfl |= PMf_TAINTMEM;
else if (ch == 'x')
*pmfl |= PMf_EXTENDED;
}
-static char *
+STATIC char *
scan_pat(char *start)
{
PMOP *pm;
pm = (PMOP*)newPMOP(OP_MATCH, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- while (*s && strchr("iogcmsx", *s))
+ while (*s && strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
pm->op_pmpermflags = pm->op_pmflags;
return s;
}
-static char *
+STATIC char *
scan_subst(char *start)
{
register char *s;
multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
- while (*s && strchr("iogcmsex", *s)) {
+ while (*s) {
if (*s == 'e') {
s++;
es++;
}
- else
+ else if (strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
}
if (es) {
return s;
}
-static char *
+STATIC char *
scan_trans(char *start)
{
register char* s;
if (lex_stuff)
SvREFCNT_dec(lex_stuff);
lex_stuff = Nullsv;
- croak("Translation pattern not terminated");
+ croak("Transliteration pattern not terminated");
}
if (s[-1] == multi_open)
s--;
if (lex_repl)
SvREFCNT_dec(lex_repl);
lex_repl = Nullsv;
- croak("Translation replacement not terminated");
+ croak("Transliteration replacement not terminated");
}
New(803,tbl,256,short);
return s;
}
-static char *
+STATIC char *
scan_heredoc(register char *s)
{
dTHR;
}
sv_setpvn(tmpstr,d+1,s-d);
s += len - 1;
- curcop->cop_line++; /* the preceding stmt passes a newline */
+ curcop->cop_line++; /* the preceding stmt passes a newline */
sv_catpvn(herewas,s,bufend-s);
sv_setsv(linestr,herewas);
*/
-static char *
+STATIC char *
scan_inputsymbol(char *start)
{
register char *s = start; /* current position in buffer */
*/
-static char *
+STATIC char *
scan_str(char *start)
{
dTHR;
return s;
}
-static char *
+STATIC char *
scan_formline(register char *s)
{
dTHR;
return s;
}
-static void
+STATIC void
set_csh(void)
{
#ifdef CSH
projects / p5sagit/p5-mst-13.2.git / blobdiff