* "It all comes from here, the stench and the peril." --Frodo
*/
+#define TMP_CRLF_PATCH
+
#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 char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
I32 ck_uni));
static char *scan_inputsymbol _((char *start));
-static char *scan_pat _((char *start));
+static char *scan_pat _((char *start, I32 type));
static char *scan_str _((char *start));
static char *scan_subst _((char *start));
static char *scan_trans _((char *start));
#endif
static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
static void restore_rsfp _((void *f));
+static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
+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).
*/
+/* #define LEX_NOTPARSING 11 is done in perl.h. */
+
#define LEX_NORMAL 10
#define LEX_INTERPNORMAL 9
#define LEX_INTERPCASEMOD 8
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
-static int
-ao(toketype)
-int toketype;
+STATIC int
+ao(int toketype)
{
if (*bufptr == '=') {
bufptr++;
return toketype;
}
-static void
-no_op(what, s)
-char *what;
-char *s;
+STATIC void
+no_op(char *what, char *s)
{
char *oldbp = bufptr;
bool is_first = (oldbufptr == linestart);
bufptr = oldbp;
}
-static void
-missingterm(s)
-char *s;
+STATIC void
+missingterm(char *s)
{
char tmpbuf[3];
char q;
}
void
-deprecate(s)
-char *s;
+deprecate(char *s)
{
if (dowarn)
warn("Use of %s is deprecated", s);
}
-static void
-depcom()
+STATIC void
+depcom(void)
{
deprecate("comma-less variable list");
}
+#ifdef WIN32
+
+STATIC I32
+win32_textfilter(int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count > 0 && !maxlen)
+ win32_strip_return(sv);
+ return count;
+}
+#endif
+
+
void
-lex_start(line)
-SV *line;
+lex_start(SV *line)
{
+ dTHR;
char *s;
STRLEN len;
SAVEPPTR(lex_brackstack);
SAVEPPTR(lex_casestack);
SAVEDESTRUCTOR(restore_rsfp, rsfp);
+ SAVESPTR(lex_stuff);
+ SAVEI32(lex_defer);
+ SAVESPTR(lex_repl);
+ SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */
+ SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect);
lex_state = LEX_NORMAL;
lex_defer = 0;
*lex_casestack = '\0';
lex_dojoin = 0;
lex_starts = 0;
- if (lex_stuff)
- SvREFCNT_dec(lex_stuff);
lex_stuff = Nullsv;
- if (lex_repl)
- SvREFCNT_dec(lex_repl);
lex_repl = Nullsv;
lex_inpat = 0;
lex_inwhat = 0;
}
void
-lex_end()
+lex_end(void)
{
doextract = FALSE;
}
-static void
-restore_rsfp(f)
-void *f;
+STATIC void
+restore_rsfp(void *f)
{
PerlIO *fp = (PerlIO*)f;
rsfp = fp;
}
-static void
-incline(s)
-char *s;
+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(void *e)
{
+ /* a safe way to store a small integer in a pointer */
+ lex_expect = (expectation)((char *)e - tokenbuf);
+}
+
+STATIC void
+incline(char *s)
+{
+ dTHR;
char *t;
char *n;
char ch;
curcop->cop_line = atoi(n)-1;
}
-static char *
-skipspace(s)
-register char *s;
+STATIC char *
+skipspace(register char *s)
{
+ dTHR;
if (lex_formbrack && lex_brackets <= lex_formbrack) {
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
return s;
if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
if (minus_n || minus_p) {
- sv_setpv(linestr,minus_p ? ";}continue{print" : "");
+ sv_setpv(linestr,minus_p ?
+ ";}continue{print or die qq(-p destination: $!\\n)" :
+ "");
sv_catpv(linestr,";}");
minus_n = minus_p = 0;
}
oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
if (preprocess && !in_eval)
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
else if ((PerlIO*)rsfp == PerlIO_stdin())
PerlIO_clearerr(rsfp);
else
bufend = s + SvCUR(linestr);
s = bufptr;
incline(s);
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
}
}
-static void
-check_uni() {
+STATIC void
+check_uni(void) {
char *s;
char ch;
char *t;
#undef UNI
#define UNI(f) return uni(f,s)
-static int
-uni(f,s)
-I32 f;
-char *s;
+STATIC int
+uni(I32 f, char *s)
{
yylval.ival = f;
expect = XTERM;
#define LOP(f,x) return lop(f,x,s)
-static I32
-lop
-#ifdef CAN_PROTOTYPE
- (I32 f, expectation x, char *s)
-#else
- (f,x,s)
-I32 f;
-expectation x;
-char *s;
-#endif /* CAN_PROTOTYPE */
+STATIC I32
+lop(I32 f, expectation x, char *s)
{
+ dTHR;
yylval.ival = f;
CLINE;
expect = x;
return LSTOP;
}
-static void
-force_next(type)
-I32 type;
+STATIC void
+force_next(I32 type)
{
nexttype[nexttoke] = type;
nexttoke++;
}
}
-static char *
-force_word(start,token,check_keyword,allow_pack,allow_tick)
-register char *start;
-int token;
-int check_keyword;
-int allow_pack;
-int allow_tick;
+STATIC char *
+force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
{
register char *s;
STRLEN len;
s = start;
if (isIDFIRST(*s) ||
(allow_pack && *s == ':') ||
- (allow_tick && *s == '\'') )
+ (allow_initial_tick && *s == '\'') )
{
s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
if (check_keyword && keyword(tokenbuf, len))
return s;
}
-static void
-force_ident(s, kind)
-register char *s;
-int kind;
+STATIC void
+force_ident(register char *s, int kind)
{
if (s && *s) {
- OP* op = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
- nextval[nexttoke].opval = op;
+ OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ nextval[nexttoke].opval = o;
force_next(WORD);
if (kind) {
- op->op_private = OPpCONST_ENTERED;
+ dTHR; /* just for in_eval */
+ o->op_private = OPpCONST_ENTERED;
/* 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 | GV_ADDINEVAL) : TRUE,
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
}
}
-static char *
-force_version(s)
-char *s;
+STATIC char *
+force_version(char *s)
{
OP *version = Nullop;
return (s);
}
-static SV *
-q(sv)
-SV *sv;
+STATIC SV *
+tokeq(SV *sv)
{
register char *s;
register char *send;
register char *d;
- STRLEN len;
+ STRLEN len = 0;
+ SV *pv = sv;
if (!SvLEN(sv))
- return sv;
+ goto finish;
s = SvPV_force(sv, len);
if (SvIVX(sv) == -1)
- return sv;
+ goto finish;
send = s + len;
while (s < send && *s != '\\')
s++;
if (s == send)
- return sv;
+ goto finish;
d = s;
+ if ( hints & HINT_NEW_STRING )
+ pv = sv_2mortal(newSVpv(SvPVX(pv), len));
while (s < send) {
if (*s == '\\') {
if (s + 1 < send && (s[1] == '\\'))
}
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
-
+ finish:
+ if ( hints & HINT_NEW_STRING )
+ return new_constant(NULL, 0, "q", sv, pv, "q");
return sv;
}
-static I32
-sublex_start()
+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);
- STRLEN len;
- char *p = SvPV(sv, len);
- yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
- SvREFCNT_dec(sv);
+ SV *sv = tokeq(lex_stuff);
+
+ if (SvTYPE(sv) == SVt_PVIV) {
+ /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
+ STRLEN len;
+ char *p;
+ SV *nsv;
+
+ p = SvPV(sv, len);
+ nsv = newSVpv(p, len);
+ SvREFCNT_dec(sv);
+ sv = nsv;
+ }
+ yylval.opval = (OP*)newSVOP(op_type, 0, sv);
lex_stuff = Nullsv;
return THING;
}
return FUNC;
}
-static I32
-sublex_push()
+STATIC I32
+sublex_push(void)
{
- push_scope();
+ dTHR;
+ ENTER;
lex_state = sublex_info.super_state;
SAVEI32(lex_dojoin);
curcop->cop_line = multi_start;
lex_inwhat = sublex_info.sub_inwhat;
- if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
+ if (lex_inwhat == OP_MATCH || lex_inwhat == OP_QR || lex_inwhat == OP_SUBST)
lex_inpat = sublex_info.sub_op;
else
lex_inpat = Nullop;
return '(';
}
-static I32
-sublex_done()
+STATIC I32
+sublex_done(void)
{
if (!lex_starts++) {
expect = XOPERATOR;
return ',';
}
else {
- pop_scope();
+ LEAVE;
bufend = SvPVX(linestr);
bufend += SvCUR(linestr);
expect = XOPERATOR;
}
}
-static char *
-scan_const(start)
-char *start;
+/*
+ scan_const
+
+ Extracts a pattern, double-quoted string, or transliteration. This
+ is terrifying code.
+
+ It looks at lex_inwhat and lex_inpat to find out whether it's
+ 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
+ regexp special ones: \D \s
+ constants: \x3
+ backrefs: \1 (deprecated in substitution replacements)
+ case and quoting: \U \Q \E
+ stops on @ and $, but not for $ as tail anchor
+
+ In transliterations:
+ characters are VERY literal, except for - not at the start or end
+ of the string, which indicates a range. scan_const expands the
+ range to the full set of intermediate characters.
+
+ In double-quoted strings:
+ backslashes:
+ double-quoted style: \r and \n
+ constants: \x3
+ backrefs: \1 (deprecated)
+ case and quoting: \U \Q \E
+ stops on @ and $
+
+ scan_const does *not* construct ops to handle interpolated strings.
+ It stops processing as soon as it finds an embedded $ or @ variable
+ and leaves it to the caller to work out what's going on.
+
+ @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
+
+ $ in pattern could be $foo or could be tail anchor. Assumption:
+ it's a tail anchor if $ is the last thing in the string, or if it's
+ followed by one of ")| \n\t"
+
+ \1 (backreferences) are turned into $1
+
+ The structure of the code is
+ while (there's a character to process) {
+ handle transliteration ranges
+ skip regexp comments
+ skip # initiated comments in //x patterns
+ check for embedded @foo
+ check for embedded scalars
+ if (backslash) {
+ leave intact backslashes from leave (below)
+ deprecate \1 in strings and sub replacements
+ handle string-changing backslashes \l \U \Q \E, etc.
+ switch (what was escaped) {
+ handle - in a transliteration (becomes a literal -)
+ handle \132 octal characters
+ handle 0x15 hex characters
+ handle \cV (control V)
+ handle printf backslashes (\f, \r, \n, etc)
+ } (end switch)
+ } (end if backslash)
+ } (end while character to read)
+
+*/
+
+STATIC char *
+scan_const(char *start)
{
- register char *send = bufend;
- SV *sv = NEWSV(93, send - start);
- register char *s = start;
- register char *d = SvPVX(sv);
- bool dorange = FALSE;
- I32 len;
- char *leave =
+ register char *send = bufend; /* end of the constant */
+ SV *sv = NEWSV(93, send - start); /* sv for the constant */
+ register char *s = start; /* start of the constant */
+ register char *d = SvPVX(sv); /* destination for copies */
+ bool dorange = FALSE; /* are we in a translit range? */
+ I32 len; /* ? */
+
+ /* leaveit is the set of acceptably-backslashed characters */
+ char *leaveit =
lex_inpat
- ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
- : (lex_inwhat & OP_TRANS)
- ? ""
- : "";
+ ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ : "";
while (s < send || dorange) {
+ /* get transliterations out of the way (they're most literal) */
if (lex_inwhat == OP_TRANS) {
+ /* expand a range A-Z to the full set of characters. AIE! */
if (dorange) {
- I32 i;
- I32 max;
- i = d - SvPVX(sv);
- SvGROW(sv, SvLEN(sv) + 256);
- d = SvPVX(sv) + i;
- d -= 2;
- max = (U8)d[1];
+ I32 i; /* current expanded character */
+ I32 max; /* last character in range */
+
+ i = d - SvPVX(sv); /* remember current offset */
+ SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
+ d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
+ d -= 2; /* eat the first char and the - */
+
+ max = (U8)d[1]; /* last char in range */
+
for (i = (U8)*d; i <= max; i++)
*d++ = i;
+
+ /* mark the range as done, and continue */
dorange = FALSE;
continue;
}
+
+ /* range begins (ignore - as first or last char) */
else if (*s == '-' && s+1 < send && s != start) {
dorange = TRUE;
s++;
}
}
- else if (*s == '(' && lex_inpat && s[1] == '?' && s[2] == '#') {
- while (s < send && *s != ')')
- *d++ = *s++;
+
+ /* if we get here, we're not doing a transliteration */
+
+ /* skip for regexp comments /(?#comment)/ */
+ else if (*s == '(' && lex_inpat && s[1] == '?') {
+ if (s[2] == '#') {
+ while (s < send && *s != ')')
+ *d++ = *s++;
+ } else if (s[2] == '{') { /* This should march regcomp.c */
+ I32 count = 1;
+ char *regparse = s + 3;
+ char c;
+
+ while (count && (c = *regparse)) {
+ if (c == '\\' && regparse[1])
+ regparse++;
+ else if (c == '{')
+ count++;
+ else if (c == '}')
+ count--;
+ regparse++;
+ }
+ if (*regparse == ')')
+ regparse++;
+ else
+ yyerror("Sequence (?{...}) not terminated or not {}-balanced");
+ while (s < regparse && *s != ')')
+ *d++ = *s++;
+ }
}
+
+ /* likewise skip #-initiated comments in //x patterns */
else if (*s == '#' && lex_inpat &&
((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
*d++ = *s++;
}
+
+ /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
break;
+
+ /* check for embedded scalars. only stop if we're sure it's a
+ variable.
+ */
else if (*s == '$') {
if (!lex_inpat) /* not a regexp, so $ must be var */
break;
- if (s + 1 < send && !strchr(")| \n\t", s[1]))
+ if (s + 1 < send && !strchr("()| \n\t", s[1]))
break; /* in regexp, $ might be tail anchor */
}
+
+ /* backslashes */
if (*s == '\\' && s+1 < send) {
s++;
- if (*s && strchr(leave, *s)) {
+
+ /* some backslashes we leave behind */
+ if (*s && strchr(leaveit, *s)) {
*d++ = '\\';
*d++ = *s++;
continue;
}
+
+ /* deprecate \1 in strings and substitution replacements */
if (lex_inwhat == OP_SUBST && !lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
*--s = '$';
break;
}
+
+ /* string-change backslash escapes */
if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
--s;
break;
}
+
+ /* if we get here, it's either a quoted -, or a digit */
switch (*s) {
+
+ /* quoted - in transliterations */
case '-':
if (lex_inwhat == OP_TRANS) {
*d++ = *s++;
continue;
}
/* FALL THROUGH */
+ /* default action is to copy the quoted character */
default:
*d++ = *s++;
continue;
+
+ /* \132 indicates an octal constant */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
*d++ = scan_oct(s, 3, &len);
s += len;
continue;
+
+ /* \x24 indicates a hex constant */
case 'x':
*d++ = scan_hex(++s, 2, &len);
s += len;
continue;
+
+ /* \c is a control character */
case 'c':
s++;
len = *s++;
*d++ = toCTRL(len);
continue;
+
+ /* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
*d++ = '\b';
break;
case 'a':
*d++ = '\007';
break;
- }
+ } /* end switch */
+
s++;
continue;
- }
+ } /* end if (backslash) */
+
*d++ = *s++;
- }
+ } /* while loop to process each character */
+
+ /* terminate the string and set up the sv */
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
SvPOK_on(sv);
+ /* shrink the sv if we allocated more than we used */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
- if (s > bufptr)
+
+ /* return the substring (via yylval) only if we parsed anything */
+ if (s > bufptr) {
+ if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
+ sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"),
+ sv, Nullsv,
+ ( lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (lex_inwhat == OP_SUBST && !lex_inpat)
+ ? "s"
+ : "qq")));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
- else
+ } else
SvREFCNT_dec(sv);
return s;
}
/* This is the one truly awful dwimmer necessary to conflate C and sed. */
-static int
-intuit_more(s)
-register char *s;
+STATIC int
+intuit_more(register char *s)
{
if (lex_brackets)
return TRUE;
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
-intuit_method(start,gv)
-char *start;
-GV *gv;
+STATIC int
+intuit_method(char *start, GV *gv)
{
char *s = start + (*start == '$');
char tmpbuf[sizeof tokenbuf];
GV* indirgv;
if (gv) {
+ CV *cv;
if (GvIO(gv))
return 0;
- if (!GvCVu(gv))
+ if ((cv = GvCVu(gv))) {
+ char *proto = SvPVX(cv);
+ if (proto) {
+ if (*proto == ';')
+ proto++;
+ if (*proto == '*')
+ return 0;
+ }
+ } else
gv = 0;
}
s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
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*
-incl_perldb()
+STATIC char*
+incl_perldb(void)
{
if (perldb) {
- char *pdb = getenv("PERL5DB");
+ char *pdb = PerlEnv_getenv("PERL5DB");
if (pdb)
return pdb;
+ SETERRNO(0,SS$_NORMAL);
return "BEGIN { require 'perl5db.pl' }";
}
return "";
static int filter_debug = 0;
SV *
-filter_add(funcp, datasv)
- filter_t funcp;
- SV *datasv;
+filter_add(filter_t funcp, SV *datasv)
{
if (!funcp){ /* temporary handy debugging hack to be deleted */
filter_debug = atoi((char*)datasv);
if (!rsfp_filters)
rsfp_filters = newAV();
if (!datasv)
- datasv = newSV(0);
+ datasv = NEWSV(255,0);
if (!SvUPGRADE(datasv, SVt_PVIO))
die("Can't upgrade filter_add data to SVt_PVIO");
IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
/* Delete most recently added instance of this filter function. */
void
-filter_del(funcp)
- filter_t funcp;
+filter_del(filter_t funcp)
{
if (filter_debug)
warn("filter_del func %p", funcp);
- if (!rsfp_filters || AvFILL(rsfp_filters)<0)
+ if (!rsfp_filters || AvFILLp(rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
- if (IoDIRP(FILTER_DATA(0)) == (void*)funcp){
- /* sv_free(av_pop(rsfp_filters)); */
- sv_free(av_shift(rsfp_filters));
+ if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){
+ sv_free(av_pop(rsfp_filters));
return;
}
/* Invoke the n'th filter function for the current rsfp. */
I32
-filter_read(idx, buf_sv, maxlen)
- int idx;
- SV *buf_sv;
- int maxlen; /* 0 = read one text line */
+filter_read(int idx, SV *buf_sv, int maxlen)
+
+
+ /* 0 = read one text line */
{
filter_t funcp;
SV *datasv = NULL;
if (!rsfp_filters)
return -1;
- if (idx > AvFILL(rsfp_filters)){ /* Any more filters? */
+ if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
if (filter_debug)
/* 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)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
}
-static char *
-filter_gets(sv,fp, append)
-register SV *sv;
-register PerlIO *fp;
-STRLEN append;
+STATIC char *
+filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
{
+#ifdef WIN32FILTER
+ if (!rsfp_filters) {
+ filter_add(win32_textfilter,NULL);
+ }
+#endif
if (rsfp_filters) {
if (!append)
}
else
return (sv_gets(sv, fp, append));
-
}
EXT int yychar; /* last token */
+/*
+ yylex
+
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
+ stitching them into a tree.
+
+ Returns:
+ PRIVATEREF
+
+ Structure:
+ if read an identifier
+ if we're in a my declaration
+ croak if they tried to say my($foo::bar)
+ build the ops for a my() declaration
+ if it's an access to a my() variable
+ are we in a sort block?
+ croak if my($a); $a <=> $b
+ build ops for access to a my() variable
+ if in a dq string, and they've said @foo and we can't find @foo
+ croak
+ build ops for a bareword
+ if we already built the token before, use it.
+*/
+
int
-yylex()
+yylex(void)
{
+ dTHR;
register char *s;
register char *d;
register I32 tmp;
STRLEN len;
+ GV *gv = Nullgv;
+ GV **gvp = 0;
+ /* check if there's an identifier for us to look at */
if (pending_ident) {
+ /* pit holds the identifier we read and pending_ident is reset */
char pit = pending_ident;
pending_ident = 0;
+ /* if we're in a my(), we can't allow dynamics here.
+ $foo'bar has already been turned into $foo::bar, so
+ just check for colons.
+
+ if it's a legal name, the OP is a PADANY.
+ */
if (in_my) {
if (strchr(tokenbuf,':'))
croak(no_myglob,tokenbuf);
+
yylval.opval = newOP(OP_PADANY, 0);
yylval.opval->op_targ = pad_allocmy(tokenbuf);
return PRIVATEREF;
}
- if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) {
- if (last_lop_op == OP_SORT &&
- tokenbuf[0] == '$' &&
- (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
- && !tokenbuf[2])
+ /*
+ build the ops for accesses to a my() variable.
+
+ Deny my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
+ if (!strchr(tokenbuf,':')) {
+#ifdef USE_THREADS
+ /* Check for single character per-thread SVs */
+ if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
+ && !isALPHA(tokenbuf[1]) /* Rule out obvious non-threadsvs */
+ && (tmp = find_threadsv(&tokenbuf[1])) != NOT_IN_PAD)
{
- for (d = in_eval ? oldoldbufptr : linestart;
- d < bufend && *d != '\n';
- d++)
+ yylval.opval = newOP(OP_THREADSV, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+#endif /* USE_THREADS */
+ if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
+ /* if it's a sort block and they're naming $a or $b */
+ if (last_lop_op == OP_SORT &&
+ tokenbuf[0] == '$' &&
+ (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
+ && !tokenbuf[2])
{
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- croak("Can't use \"my %s\" in sort comparison",
- tokenbuf);
+ for (d = in_eval ? oldoldbufptr : linestart;
+ d < bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ croak("Can't use \"my %s\" in sort comparison",
+ tokenbuf);
+ }
}
}
- }
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
}
- /* Force them to make up their mind on "@foo". */
+ /*
+ Whine if they've said @foo in a doublequoted string,
+ and @foo isn't a variable we can find in the symbol
+ table.
+ */
if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
tokenbuf, tokenbuf));
}
+ /* 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 | GV_ADDINEVAL) : TRUE,
((tokenbuf[0] == '$') ? SVt_PV
: (tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
return WORD;
}
+ /* no identifier pending identification */
+
switch (lex_state) {
#ifdef COMMENTARY
case LEX_NORMAL: /* Some compilers will produce faster */
break;
#endif
+ /* when we're already built the next token, just pull it out the queue */
case LEX_KNOWNEXT:
nexttoke--;
yylval = nextval[nexttoke];
}
return(nexttype[nexttoke]);
+ /* interpolated case modifiers like \L \U, including \Q and \E.
+ when we get here, bufptr is at the \
+ */
case LEX_INTERPCASEMOD:
#ifdef DEBUGGING
if (bufptr != bufend && *bufptr != '\\')
croak("panic: INTERPCASEMOD");
#endif
- if (bufptr == bufend || bufptr[1] == 'E') {
+ /* handle \E or end of string */
+ if (bufptr == bufend || bufptr[1] == 'E') {
char oldmod;
+
+ /* if at a \E */
if (lex_casemods) {
oldmod = lex_casestack[--lex_casemods];
lex_casestack[lex_casemods] = '\0';
+
if (bufptr != bufend && strchr("LUQ", oldmod)) {
bufptr += 2;
lex_state = LEX_INTERPCONCAT;
if (lex_dojoin) {
nextval[nexttoke].ival = 0;
force_next(',');
+#ifdef USE_THREADS
+ nextval[nexttoke].opval = newOP(OP_THREADSV, 0);
+ nextval[nexttoke].opval->op_targ = find_threadsv("\"");
+ force_next(PRIVATEREF);
+#else
force_ident("\"", '$');
+#endif /* USE_THREADS */
nextval[nexttoke].ival = 0;
force_next('$');
nextval[nexttoke].ival = 0;
if (SvIVX(linestr) == '\'') {
SV *sv = newSVsv(linestr);
if (!lex_inpat)
- sv = q(sv);
+ sv = tokeq(sv);
+ else if ( hints & HINT_NEW_RE )
+ sv = new_constant(NULL, 0, "qr", sv, sv, "q");
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = bufend;
}
if (SvCUR(linestr))
sv_catpv(linestr,";");
if (preambleav){
- while(AvFILL(preambleav) >= 0) {
+ while(AvFILLp(preambleav) >= 0) {
SV *tmpsv = av_shift(preambleav);
sv_catsv(linestr, tmpsv);
sv_catpv(linestr, ";");
sv_catpv(linestr, "\n");
oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
fake_eof:
if (rsfp) {
if (preprocess && !in_eval)
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
else if ((PerlIO *)rsfp == PerlIO_stdin())
PerlIO_clearerr(rsfp);
else
incline(s);
} while (doextract);
oldoldbufptr = oldbufptr = bufptr = linestart = s;
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
}
d = moreswitches(d);
} while (d);
- if (perldb && !oldpdb ||
+ if (PERLDB_LINE && !oldpdb ||
( minus_n || minus_p ) && !(oldn || oldp) )
/* if we have already added "LINE: while (<>) {",
we must not do it again */
oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
preambled = FALSE;
- if (perldb)
+ if (PERLDB_LINE)
(void)gv_fetchfile(origfilename);
goto retry;
}
}
goto retry;
case '\r':
+#ifndef TMP_CRLF_PATCH
warn("Illegal character \\%03o (carriage return)", '\r');
croak(
"(Maybe you didn't strip carriage returns after a network transfer?)\n");
+#endif
case ' ': case '\t': case '\f': case 013:
s++;
goto retry;
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('-');
close = term;
if (open == close)
for (t++; t < bufend; t++) {
- if (*t == '\\' && t+1 < bufend && term != '\\')
+ if (*t == '\\' && t+1 < bufend && open != '\\')
t++;
- else if (*t == term)
+ else if (*t == open)
break;
}
else
for (t++; t < bufend; t++) {
- if (*t == '\\' && t+1 < bufend && term != '\\')
+ if (*t == '\\' && t+1 < bufend)
t++;
- else if (*t == term && --brackets <= 0)
+ else if (*t == close && --brackets <= 0)
break;
else if (*t == open)
brackets++;
else if (isIDFIRST(*s)) {
char tmpbuf[sizeof tokenbuf];
scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- if (keyword(tmpbuf, len))
- expect = XTERM; /* e.g. print $fh length() */
+ if (tmp = keyword(tmpbuf, len)) {
+ /* binary operators exclude handle interpretations */
+ switch (tmp) {
+ case -KEY_x:
+ case -KEY_eq:
+ case -KEY_ne:
+ case -KEY_gt:
+ case -KEY_lt:
+ case -KEY_ge:
+ case -KEY_le:
+ case -KEY_cmp:
+ break;
+ default:
+ expect = XTERM; /* e.g. print $fh length() */
+ break;
+ }
+ }
else {
GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
if (gv && GvCVu(gv))
case '/': /* may either be division or pattern */
case '?': /* may either be conditional or pattern */
if (expect != XOPERATOR) {
- check_uni();
- s = scan_pat(s);
+ /* Disable warning on "study /blah/" */
+ if (oldoldbufptr == last_uni
+ && (*last_uni != 's' || s - last_uni < 5
+ || memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
}
tmp = *s++;
case 'y': case 'Y':
case 'z': case 'Z':
- keylookup:
+ keylookup: {
+ gv = Nullgv;
+ gvp = 0;
+
bufptr = s;
s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
(tokenbuf[0] == 'q' &&
- strchr("qwx", tokenbuf[1]))));
+ strchr("qwxr", tokenbuf[1]))));
/* x::* is just a word, unless x is "CORE" */
if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
/* 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);
}
if (tmp < 0) { /* second-class keyword? */
- GV* gv;
- if (expect != XOPERATOR &&
- (*s != ':' || s[1] != ':') &&
- (gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
- GvIMPORTED_CV(gv))
+ GV *ogv = Nullgv; /* override (winner) */
+ GV *hgv = Nullgv; /* hidden (loser) */
+ if (expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
+ CV *cv;
+ if ((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
+ (cv = GvCVu(gv)))
+ {
+ if (GvIMPORTED_CV(gv))
+ ogv = gv;
+ else if (! CvMETHOD(cv))
+ hgv = gv;
+ }
+ if (!ogv &&
+ (gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
+ (gv = *gvp) != (GV*)&sv_undef &&
+ GvCVu(gv) && GvIMPORTED_CV(gv))
+ {
+ ogv = gv;
+ }
+ }
+ if (ogv) {
+ tmp = 0; /* overridden by import or by GLOBAL */
+ }
+ else if (gv && !gvp
+ && -tmp==KEY_lock /* XXX generalizable kludge */
+ && !hv_fetch(GvHVn(incgv), "Thread.pm", 9, FALSE))
{
- tmp = 0;
+ tmp = 0; /* any sub overrides "weak" keyword */
}
- else
+ else { /* no override */
tmp = -tmp;
+ gv = Nullgv;
+ gvp = 0;
+ if (dowarn && hgv)
+ warn("Ambiguous call resolved as CORE::%s(), "
+ "qualify as such or use &", GvENAME(hgv));
+ }
}
reserved_word:
default: /* not a keyword */
just_a_word: {
- GV *gv;
SV *sv;
char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
/* 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 */
- gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV);
+ if (gvp) {
+ sv = newSVpv("CORE::GLOBAL::",14);
+ sv_catpv(sv,tokenbuf);
+ }
+ else
+ sv = newSVpv(tokenbuf,0);
/* Presume this is going to be a bareword of some sort. */
CLINE;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ 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 &&
oldoldbufptr < bufptr &&
(oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
/* NO SKIPSPACE BEFORE HERE! */
- (expect == XREF ||
- (opargs[last_lop_op] >> OASHIFT & 7) == OA_FILEREF) )
+ (expect == XREF
+ || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
+ || (last_lop_op == OP_ENTERSUB
+ && last_proto
+ && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
{
bool immediate_paren = *s == '(';
/* Is there a prototype? */
if (SvPOK(cv)) {
STRLEN len;
- char *proto = SvPV((SV*)cv, len);
+ last_proto = SvPV((SV*)cv, len);
if (!len)
TERM(FUNC0SUB);
- if (strEQ(proto, "$"))
+ if (strEQ(last_proto, "$"))
OPERATOR(UNIOPSUB);
- if (*proto == '&' && *s == '{') {
+ if (*last_proto == '&' && *s == '{') {
sv_setpv(subname,"__ANON__");
PREBLOCK(LSTOPSUB);
}
- }
+ } else
+ last_proto = NULL;
nextval[nexttoke].opval = yylval.opval;
expect = XTERM;
force_next(WORD);
warn(warn_reserved, tokenbuf);
}
}
+
+ safe_bareword:
if (lastchar && strchr("*%&", lastchar)) {
warn("Operator or semicolon missing before %c%s",
lastchar, tokenbuf);
case KEY_DESTROY:
case KEY_BEGIN:
case KEY_END:
+ case KEY_INIT:
if (expect == XSTATE) {
s = bufptr;
goto really_sub;
case KEY_foreach:
yylval.ival = curcop->cop_line;
s = skipspace(s);
- if (isIDFIRST(*s)) {
+ if (expect == XSTATE && isIDFIRST(*s)) {
char *p = s;
if ((bufend - p) >= 3 &&
strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
case KEY_listen:
LOP(OP_LISTEN,XTERM);
+ case KEY_lock:
+ UNI(OP_LOCK);
+
case KEY_lstat:
UNI(OP_LSTAT);
case KEY_m:
- s = scan_pat(s);
+ s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
case KEY_map:
case KEY_my:
in_my = TRUE;
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
+ in_my_stash = gv_stashpv(tokenbuf, FALSE);
+ if (!in_my_stash) {
+ char tmpbuf[1024];
+ bufptr = s;
+ sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
+ yyerror(tmpbuf);
+ }
+ }
OPERATOR(MY);
case KEY_next:
}
}
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(',');
SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
TERM(sublex_start());
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
+
case KEY_qx:
s = scan_str(s);
if (!s)
if (*s == ';' || *s == ')') /* probably a close */
croak("sort is now a reserved word");
expect = XTERM;
- s = force_word(s,WORD,TRUE,TRUE,TRUE);
+ s = force_word(s,WORD,TRUE,TRUE,FALSE);
LOP(OP_SORT,XREF);
case KEY_split:
s = scan_trans(s);
TERM(sublex_start());
}
- }
+ }}
}
I32
-keyword(d, len)
-register char *d;
-I32 len;
+keyword(register char *d, I32 len)
{
switch (*d) {
case '_':
case 4:
if (strEQ(d,"grep")) return KEY_grep;
if (strEQ(d,"goto")) return KEY_goto;
- if (strEQ(d,"glob")) return -KEY_glob;
+ if (strEQ(d,"glob")) return KEY_glob;
break;
case 6:
if (strEQ(d,"gmtime")) return -KEY_gmtime;
case 'h':
if (strEQ(d,"hex")) return -KEY_hex;
break;
+ case 'I':
+ if (strEQ(d,"INIT")) return KEY_INIT;
+ break;
case 'i':
switch (len) {
case 2:
case 4:
if (strEQ(d,"last")) return KEY_last;
if (strEQ(d,"link")) return -KEY_link;
+ if (strEQ(d,"lock")) return -KEY_lock;
break;
case 5:
if (strEQ(d,"local")) return KEY_local;
case 3:
if (strEQ(d,"ord")) return -KEY_ord;
if (strEQ(d,"oct")) return -KEY_oct;
+ if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
+ return 0;}
break;
case 4:
if (strEQ(d,"open")) return -KEY_open;
case 'q':
if (len <= 2) {
if (strEQ(d,"q")) return KEY_q;
+ if (strEQ(d,"qr")) return KEY_qr;
if (strEQ(d,"qq")) return KEY_qq;
if (strEQ(d,"qw")) return KEY_qw;
if (strEQ(d,"qx")) return KEY_qx;
return 0;
}
-static void
-checkcomma(s,name,what)
-register char *s;
-char *name;
-char *what;
+STATIC void
+checkcomma(register char *s, char *name, char *what)
{
char *w;
}
if (*w)
for (; *w && isSPACE(*w); w++) ;
- if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */
+ if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
warn("%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
}
}
-static char *
-scan_word(s, dest, destlen, allow_package, slp)
-register char *s;
-char *dest;
-STRLEN destlen;
-int allow_package;
-STRLEN *slp;
+STATIC SV *
+new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
+{
+ dSP;
+ HV *table = GvHV(hintgv); /* ^H */
+ BINOP myop;
+ SV *res;
+ bool oldcatch = CATCH_GET;
+ SV **cvp;
+ SV *cv, *typesv;
+ char buf[128];
+
+ if (!table) {
+ yyerror("%^H is not defined");
+ return sv;
+ }
+ cvp = hv_fetch(table, key, strlen(key), FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ sprintf(buf,"$^H{%s} is not defined", key);
+ yyerror(buf);
+ return sv;
+ }
+ sv_2mortal(sv); /* Parent created it permanently */
+ cv = *cvp;
+ if (!pv)
+ pv = sv_2mortal(newSVpv(s, len));
+ if (type)
+ typesv = sv_2mortal(newSVpv(type, 0));
+ else
+ typesv = &sv_undef;
+ CATCH_SET(TRUE);
+ Zero(&myop, 1, BINOP);
+ myop.op_last = (OP *) &myop;
+ myop.op_next = Nullop;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+
+ PUSHSTACKi(PERLSI_OVERLOAD);
+ ENTER;
+ SAVEOP();
+ op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
+ PUTBACK;
+ pp_pushmark(ARGS);
+
+ EXTEND(sp, 4);
+ PUSHs(pv);
+ PUSHs(sv);
+ PUSHs(typesv);
+ PUSHs(cv);
+ PUTBACK;
+
+ if (op = pp_entersub(ARGS))
+ CALLRUNOPS();
+ LEAVE;
+ SPAGAIN;
+
+ res = POPs;
+ PUTBACK;
+ CATCH_SET(oldcatch);
+ POPSTACK;
+
+ if (!SvOK(res)) {
+ sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
+ yyerror(buf);
+ }
+ return SvREFCNT_inc(res);
+}
+
+STATIC char *
+scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
register char *d = dest;
register char *e = d + destlen - 3; /* two-character token, ending NUL */
*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 *
-scan_ident(s, send, dest, destlen, ck_uni)
-register char *s;
-register char *send;
-char *dest;
-STRLEN destlen;
-I32 ck_uni;
+STATIC char *
+scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
{
register char *d;
register char *e;
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
- if (dowarn &&
+ if (dowarn && lex_state == LEX_NORMAL &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
warn("Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
return s;
}
-void pmflag(pmfl,ch)
-U16* pmfl;
-int ch;
+void pmflag(U16 *pmfl, int ch)
{
if (ch == 'i')
*pmfl |= PMf_FOLD;
*pmfl |= PMf_EXTENDED;
}
-static char *
-scan_pat(start)
-char *start;
+STATIC char *
+scan_pat(char *start, I32 type)
{
PMOP *pm;
char *s;
croak("Search pattern not terminated");
}
- pm = (PMOP*)newPMOP(OP_MATCH, 0);
+ pm = (PMOP*)newPMOP(type, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- while (*s && strchr("iogcmsx", *s))
- pmflag(&pm->op_pmflags,*s++);
+ if(type == OP_QR) {
+ while (*s && strchr("iomsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
+ else {
+ while (*s && strchr("iogcmsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
pm->op_pmpermflags = pm->op_pmflags;
lex_op = (OP*)pm;
return s;
}
-static char *
-scan_subst(start)
-char *start;
+STATIC char *
+scan_subst(char *start)
{
register char *s;
register PMOP *pm;
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("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
}
if (es) {
return s;
}
-void
-hoistmust(pm)
-register PMOP *pm;
-{
- if (!pm->op_pmshort && pm->op_pmregexp->regstart &&
- (!pm->op_pmregexp->regmust || pm->op_pmregexp->reganch & ROPT_ANCH)
- ) {
- if (!(pm->op_pmregexp->reganch & ROPT_ANCH))
- pm->op_pmflags |= PMf_SCANFIRST;
- pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart);
- pm->op_pmslen = SvCUR(pm->op_pmshort);
- }
- else if (pm->op_pmregexp->regmust) {/* is there a better short-circuit? */
- if (pm->op_pmshort &&
- sv_eq(pm->op_pmshort,pm->op_pmregexp->regmust))
- {
- if (pm->op_pmflags & PMf_SCANFIRST) {
- SvREFCNT_dec(pm->op_pmshort);
- pm->op_pmshort = Nullsv;
- }
- else {
- SvREFCNT_dec(pm->op_pmregexp->regmust);
- pm->op_pmregexp->regmust = Nullsv;
- return;
- }
- }
- /* promote the better string */
- if ((!pm->op_pmshort &&
- !(pm->op_pmregexp->reganch & ROPT_ANCH_GPOS)) ||
- ((pm->op_pmflags & PMf_SCANFIRST) &&
- (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)))) {
- SvREFCNT_dec(pm->op_pmshort); /* ok if null */
- pm->op_pmshort = pm->op_pmregexp->regmust;
- pm->op_pmslen = SvCUR(pm->op_pmshort);
- pm->op_pmregexp->regmust = Nullsv;
- pm->op_pmflags |= PMf_SCANFIRST;
- }
- }
-}
-
-static char *
-scan_trans(start)
-char *start;
+STATIC char *
+scan_trans(char *start)
{
register char* s;
- OP *op;
+ OP *o;
short *tbl;
I32 squash;
- I32 delete;
+ I32 Delete;
I32 complement;
yylval.ival = OP_NULL;
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);
- op = newPVOP(OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
- complement = delete = squash = 0;
+ complement = Delete = squash = 0;
while (*s == 'c' || *s == 'd' || *s == 's') {
if (*s == 'c')
complement = OPpTRANS_COMPLEMENT;
else if (*s == 'd')
- delete = OPpTRANS_DELETE;
+ Delete = OPpTRANS_DELETE;
else
squash = OPpTRANS_SQUASH;
s++;
}
- op->op_private = delete|squash|complement;
+ o->op_private = Delete|squash|complement;
- lex_op = op;
+ lex_op = o;
yylval.ival = OP_TRANS;
return s;
}
-static char *
-scan_heredoc(s)
-register char *s;
+STATIC char *
+scan_heredoc(register char *s)
{
+ dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
register char *d;
register char *e;
char *peek;
- int outer = (rsfp && !lex_inwhat);
+ int outer = (rsfp && !(lex_inwhat == OP_SCALAR));
s += 2;
d = tokenbuf;
*d++ = '\n';
*d = '\0';
len = d - tokenbuf;
+#ifdef TMP_CRLF_PATCH
+ d = strchr(s, '\r');
+ if (d) {
+ char *olds = s;
+ s = d;
+ while (s < bufend) {
+ if (*s == '\r') {
+ *d++ = '\n';
+ if (*++s == '\n')
+ s++;
+ }
+ else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
+ *d++ = *s++;
+ s++;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ bufend = d;
+ SvCUR_set(linestr, bufend - SvPVX(linestr));
+ s = olds;
+ }
+#endif
d = "\n";
if (outer || !(d=ninstr(s,bufend,d,d+1)))
herewas = newSVpv(s,bufend-s);
s--, herewas = newSVpv(s,d-s);
s += SvCUR(herewas);
- tmpstr = NEWSV(87,80);
+ tmpstr = NEWSV(87,79);
sv_upgrade(tmpstr, SVt_PVIV);
if (term == '\'') {
op_type = OP_CONST;
}
sv_setpvn(tmpstr,d+1,s-d);
s += len - 1;
+ curcop->cop_line++; /* the preceding stmt passes a newline */
+
sv_catpvn(herewas,s,bufend-s);
sv_setsv(linestr,herewas);
oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
missingterm(tokenbuf);
}
curcop->cop_line++;
- if (perldb && curstash != debstash) {
+ bufend = SvPVX(linestr) + SvCUR(linestr);
+#ifdef TMP_CRLF_PATCH
+ if (bufend - linestart >= 2) {
+ if (bufend[-2] == '\r' || bufend[-2] == '\n') {
+ bufend[-2] = '\n';
+ bufend--;
+ SvCUR_set(linestr, bufend - SvPVX(linestr));
+ }
+ else if (bufend[-1] == '\r')
+ bufend[-1] = '\n';
+ }
+ else if (bufend - linestart == 1 && bufend[-1] == '\r')
+ bufend[-1] = '\n';
+#endif
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
sv_upgrade(sv, SVt_PVMG);
av_store(GvAV(curcop->cop_filegv),
(I32)curcop->cop_line,sv);
}
- bufend = SvPVX(linestr) + SvCUR(linestr);
if (*s == term && memEQ(s,tokenbuf,len)) {
s = bufend - 1;
*s = ' ';
return s;
}
-static char *
-scan_inputsymbol(start)
-char *start;
+/* scan_inputsymbol
+ takes: current position in input buffer
+ returns: new position in input buffer
+ side-effects: yylval and lex_op are set.
+
+ This code handles:
+
+ <> read from ARGV
+ <FH> read from filehandle
+ <pkg::FH> read from package qualified filehandle
+ <pkg'FH> read from package qualified filehandle
+ <$fh> read from filehandle in $fh
+ <*.h> filename glob
+
+*/
+
+STATIC char *
+scan_inputsymbol(char *start)
{
- register char *s = start;
+ register char *s = start; /* current position in buffer */
register char *d;
register char *e;
I32 len;
- d = tokenbuf;
- e = tokenbuf + sizeof tokenbuf;
- s = delimcpy(d, e, s + 1, bufend, '>', &len);
+ d = tokenbuf; /* start of temp holding space */
+ e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
+ s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
+
+ /* die if we didn't have space for the contents of the <>,
+ or if it didn't end
+ */
+
if (len >= sizeof tokenbuf)
croak("Excessively long <> operator");
if (s >= bufend)
croak("Unterminated <> operator");
+
s++;
+
+ /* check for <$fh>
+ Remember, only scalar variables are interpreted as filehandles by
+ this code. Anything more complex (e.g., <$fh{$num}>) will be
+ treated as a glob() call.
+ This code makes use of the fact that except for the $ at the front,
+ a scalar variable and a filehandle look the same.
+ */
if (*d == '$' && d[1]) d++;
+
+ /* allow <Pkg'VALUE> or <Pkg::VALUE> */
while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
d++;
+
+ /* If we've tried to read what we allow filehandles to look like, and
+ there's still text left, then it must be a glob() and not a getline.
+ Use scan_str to pull out the stuff between the <> and treat it
+ as nothing more than a string.
+ */
+
if (d - tokenbuf != len) {
yylval.ival = OP_GLOB;
set_csh();
s = scan_str(start);
if (!s)
- croak("Glob not terminated");
+ croak("Glob not terminated");
return s;
}
else {
+ /* we're in a filehandle read situation */
d = tokenbuf;
+
+ /* turn <> into <ARGV> */
if (!len)
(void)strcpy(d,"ARGV");
+
+ /* if <$fh>, create the ops to turn the variable into a
+ filehandle
+ */
if (*d == '$') {
I32 tmp;
- if (tmp = pad_findmy(d)) {
- OP *op = newOP(OP_PADSV, 0);
- op->op_targ = tmp;
- lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, op));
+
+ /* try to find it in the pad for this block, otherwise find
+ add symbol table ops
+ */
+ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = tmp;
+ lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
}
else {
GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv))));
}
+ /* we created the ops in lex_op, so make yylval.ival a null op */
yylval.ival = OP_NULL;
}
+
+ /* If it's none of the above, it must be a literal filehandle
+ (<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
yylval.ival = OP_NULL;
}
}
+
return s;
}
-static char *
-scan_str(start)
-char *start;
-{
- SV *sv;
- char *tmps;
- register char *s = start;
- register char term;
- register char *to;
- I32 brackets = 1;
+/* scan_str
+ takes: start position in buffer
+ returns: position to continue reading from buffer
+ side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
+ updates the read buffer.
+
+ This subroutine pulls a string out of the input. It is called for:
+ q single quotes q(literal text)
+ ' single quotes 'literal text'
+ qq double quotes qq(interpolate $here please)
+ " double quotes "interpolate $here please"
+ qx backticks qx(/bin/ls -l)
+ ` backticks `/bin/ls -l`
+ qw quote words @EXPORT_OK = qw( func() $spam )
+ m// regexp match m/this/
+ s/// regexp substitute s/this/that/
+ tr/// string transliterate tr/this/that/
+ y/// string transliterate y/this/that/
+ ($*@) sub prototypes sub foo ($)
+ <> readline or globs <FOO>, <>, <$fh>, or <*.c>
+
+ In most of these cases (all but <>, patterns and transliterate)
+ yylex() calls scan_str(). m// makes yylex() call scan_pat() which
+ calls scan_str(). s/// makes yylex() call scan_subst() which calls
+ scan_str(). tr/// and y/// make yylex() call scan_trans() which
+ calls scan_str().
+
+ It skips whitespace before the string starts, and treats the first
+ character as the delimiter. If the delimiter is one of ([{< then
+ the corresponding "close" character )]}> is used as the closing
+ delimiter. It allows quoting of delimiters, and if the string has
+ balanced delimiters ([{<>}]) it allows nesting.
+
+ The lexer always reads these strings into lex_stuff, except in the
+ case of the operators which take *two* arguments (s/// and tr///)
+ when it checks to see if lex_stuff is full (presumably with the 1st
+ arg to s or tr) and if so puts the string into lex_repl.
+
+*/
+
+STATIC char *
+scan_str(char *start)
+{
+ dTHR;
+ SV *sv; /* scalar value: string */
+ char *tmps; /* temp string, used for delimiter matching */
+ register char *s = start; /* current position in the buffer */
+ register char term; /* terminating character */
+ register char *to; /* current position in the sv's data */
+ I32 brackets = 1; /* bracket nesting level */
+
+ /* skip space before the delimiter */
if (isSPACE(*s))
s = skipspace(s);
+
+ /* mark where we are, in case we need to report errors */
CLINE;
+
+ /* after skipping whitespace, the next character is the terminator */
term = *s;
+ /* mark where we are */
multi_start = curcop->cop_line;
multi_open = term;
+
+ /* find corresponding closing delimiter */
if (term && (tmps = strchr("([{< )]}> )]}>",term)))
term = tmps[5];
multi_close = term;
- sv = NEWSV(87,80);
+ /* create a new SV to hold the contents. 87 is leak category, I'm
+ assuming. 79 is the SV's initial length. What a random number. */
+ sv = NEWSV(87,79);
sv_upgrade(sv, SVt_PVIV);
SvIVX(sv) = term;
(void)SvPOK_only(sv); /* validate pointer */
+
+ /* move past delimiter and try to read a complete string */
s++;
for (;;) {
+ /* extend sv if need be */
SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
+ /* set 'to' to the next character in the sv's string */
to = SvPVX(sv)+SvCUR(sv);
+
+ /* if open delimiter is the close delimiter read unbridle */
if (multi_open == multi_close) {
for (; s < bufend; s++,to++) {
+ /* embedded newlines increment the current line number */
if (*s == '\n' && !rsfp)
curcop->cop_line++;
+ /* handle quoted delimiters */
if (*s == '\\' && s+1 < bufend && term != '\\') {
if (s[1] == term)
s++;
+ /* any other quotes are simply copied straight through */
else
*to++ = *s++;
}
+ /* terminate when run out of buffer (the for() condition), or
+ have found the terminator */
else if (*s == term)
break;
*to = *s;
}
}
+
+ /* if the terminator isn't the same as the start character (e.g.,
+ matched brackets), we have to allow more in the quoting, and
+ be prepared for nested brackets.
+ */
else {
+ /* read until we run out of string, or we find the terminator */
for (; s < bufend; s++,to++) {
+ /* embedded newlines increment the line count */
if (*s == '\n' && !rsfp)
curcop->cop_line++;
- if (*s == '\\' && s+1 < bufend && term != '\\') {
- if (s[1] == term)
+ /* backslashes can escape the open or closing characters */
+ if (*s == '\\' && s+1 < bufend) {
+ if ((s[1] == multi_open) || (s[1] == multi_close))
s++;
else
*to++ = *s++;
}
- else if (*s == term && --brackets <= 0)
+ /* allow nested opens and closes */
+ else if (*s == multi_close && --brackets <= 0)
break;
else if (*s == multi_open)
brackets++;
*to = *s;
}
}
+ /* terminate the copied string and update the sv's end-of-string */
*to = '\0';
SvCUR_set(sv, to - SvPVX(sv));
- if (s < bufend) break; /* string ends on this line? */
+ /*
+ * this next chunk reads more into the buffer if we're not done yet
+ */
+
+ if (s < bufend) break; /* handle case where we are done yet :-) */
+#ifdef TMP_CRLF_PATCH
+ if (to - SvPVX(sv) >= 2) {
+ if (to[-2] == '\r' || to[-2] == '\n') {
+ to[-2] = '\n';
+ to--;
+ SvCUR_set(sv, to - SvPVX(sv));
+ }
+ else if (to[-1] == '\r')
+ to[-1] = '\n';
+ }
+ else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
+ to[-1] = '\n';
+#endif
+
+ /* if we're out of file, or a read fails, bail and reset the current
+ line marker so we can report where the unterminated string began
+ */
if (!rsfp ||
!(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
sv_free(sv);
curcop->cop_line = multi_start;
return Nullch;
}
+ /* we read a line, so increment our line counter */
curcop->cop_line++;
- if (perldb && curstash != debstash) {
+
+ /* update debugger info */
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
sv_upgrade(sv, SVt_PVMG);
av_store(GvAV(curcop->cop_filegv),
(I32)curcop->cop_line, sv);
}
+
+ /* having changed the buffer, we must update bufend */
bufend = SvPVX(linestr) + SvCUR(linestr);
}
+
+ /* at this point, we have successfully read the delimited string */
+
multi_end = curcop->cop_line;
s++;
+
+ /* if we allocated too much space, give some back */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
+
+ /* decide whether this is the first or second quoted string we've read
+ for this op
+ */
+
if (lex_stuff)
lex_repl = sv;
else
return s;
}
+/*
+ scan_num
+ takes: pointer to position in buffer
+ returns: pointer to new position in buffer
+ side-effects: builds ops for the constant in yylval.op
+
+ Read a number in any of the formats that Perl accepts:
+
+ 0(x[0-7A-F]+)|([0-7]+)
+ [\d_]+(\.[\d_]*)?[Ee](\d+)
+
+ Underbars (_) are allowed in decimal numbers. If -w is on,
+ underbars before a decimal point must be at three digit intervals.
+
+ Like most scan_ routines, it uses the tokenbuf buffer to hold the
+ thing it reads.
+
+ If it reads a number without a decimal point or an exponent, it will
+ try converting the number to an integer and see if it can do so
+ without loss of precision.
+*/
+
char *
-scan_num(start)
-char *start;
+scan_num(char *start)
{
- register char *s = start;
- register char *d;
- register char *e;
- I32 tryiv;
- double value;
- SV *sv;
- I32 floatit;
- char *lastub = 0;
+ register char *s = start; /* current position in buffer */
+ register char *d; /* destination in temp buffer */
+ register char *e; /* end of temp buffer */
+ I32 tryiv; /* used to see if it can be an int */
+ double value; /* number read, as a double */
+ SV *sv; /* place to put the converted number */
+ I32 floatit; /* boolean: int or float? */
+ char *lastub = 0; /* position of last underbar */
static char number_too_long[] = "Number too long";
+ /* We use the first character to decide what type of number this is */
+
switch (*s) {
default:
- croak("panic: scan_num");
+ croak("panic: scan_num");
+
+ /* if it starts with a 0, it could be an octal number, a decimal in
+ 0.13 disguise, or a hexadecimal number.
+ */
case '0':
{
+ /* variables:
+ u holds the "number so far"
+ shift the power of 2 of the base (hex == 4, octal == 3)
+ overflowed was the number more than we can hold?
+
+ Shift is used when we add a digit. It also serves as an "are
+ we in octal or hex?" indicator to disallow hex characters when
+ in octal mode.
+ */
UV u;
I32 shift;
bool overflowed = FALSE;
+ /* check for hex */
if (s[1] == 'x') {
shift = 4;
s += 2;
}
+ /* check for a decimal in disguise */
else if (s[1] == '.')
goto decimal;
+ /* so it must be octal */
else
shift = 3;
u = 0;
+
+ /* read the rest of the octal number */
for (;;) {
- UV n, b;
+ UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
switch (*s) {
+
+ /* if we don't mention it, we're done */
default:
goto out;
+
+ /* _ are ignored */
case '_':
s++;
break;
+
+ /* 8 and 9 are not octal */
case '8': case '9':
if (shift != 4)
yyerror("Illegal octal digit");
/* FALL THROUGH */
+
+ /* octal digits */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
- b = *s++ & 15;
+ b = *s++ & 15; /* ASCII digit -> value of digit */
goto digit;
+
+ /* hex digits */
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ /* make sure they said 0x */
if (shift != 4)
goto out;
b = (*s++ & 7) + 9;
+
+ /* Prepare to put the digit we have onto the end
+ of the number so far. We check for overflows.
+ */
+
digit:
- n = u << shift;
- if (!overflowed && (n >> shift) != u) {
+ n = u << shift; /* make room for the digit */
+ if (!overflowed && (n >> shift) != u
+ && !(hints & HINT_NEW_BINARY)) {
warn("Integer overflow in %s number",
(shift == 4) ? "hex" : "octal");
overflowed = TRUE;
}
- u = n | b;
+ u = n | b; /* add the digit to the end */
break;
}
}
+
+ /* if we get here, we had success: make a scalar value from
+ the number.
+ */
out:
sv = NEWSV(92,0);
sv_setuv(sv, u);
+ if ( hints & HINT_NEW_BINARY)
+ sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
}
break;
+
+ /*
+ handle decimal numbers.
+ we're also sent here when we read a 0 as the first digit
+ */
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '.':
decimal:
d = tokenbuf;
e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
floatit = FALSE;
+
+ /* read next group of digits and _ and copy into d */
while (isDIGIT(*s) || *s == '_') {
+ /* skip underscores, checking for misplaced ones
+ if -w is on
+ */
if (*s == '_') {
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
lastub = ++s;
}
else {
+ /* check for end of fixed-length buffer */
if (d >= e)
croak(number_too_long);
+ /* if we're ok, copy the character */
*d++ = *s++;
}
}
+
+ /* final misplaced underbar check */
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
+
+ /* read a decimal portion if there is one. avoid
+ 3..5 being interpreted as the number 3. followed
+ by .5
+ */
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
+
+ /* copy, ignoring underbars, until we run out of
+ digits. Note: no misplaced underbar checks!
+ */
for (; isDIGIT(*s) || *s == '_'; s++) {
+ /* fixed length buffer check */
if (d >= e)
croak(number_too_long);
if (*s != '_')
*d++ = *s;
}
}
+
+ /* read exponent part, if present */
if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
floatit = TRUE;
s++;
+
+ /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
+
+ /* allow positive or negative exponent */
if (*s == '+' || *s == '-')
*d++ = *s++;
+
+ /* read digits of exponent (no underbars :-) */
while (isDIGIT(*s)) {
if (d >= e)
croak(number_too_long);
*d++ = *s++;
}
}
+
+ /* terminate the string */
*d = '\0';
+
+ /* make an sv from the string */
sv = NEWSV(92,0);
+ /* reset numeric locale in case we were earlier left in Swaziland */
SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
+
+ /*
+ See if we can make do with an integer value without loss of
+ precision. We use I_V to cast to an int, because some
+ compilers have issues. Then we try casting it back and see
+ if it was the same. We only do this if we know we
+ specifically read an integer.
+
+ Note: if floatit is true, then we don't need to do the
+ conversion at all.
+ */
tryiv = I_V(value);
if (!floatit && (double)tryiv == value)
sv_setiv(sv, tryiv);
else
sv_setnv(sv, value);
+ if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) )
+ sv = new_constant(tokenbuf, d - tokenbuf,
+ (floatit ? "float" : "integer"), sv, Nullsv, NULL);
break;
}
+ /* make the op for the constant and return */
+
yylval.opval = newSVOP(OP_CONST, 0, sv);
return s;
}
-static char *
-scan_formline(s)
-register char *s;
+STATIC char *
+scan_formline(register char *s)
{
+ dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpv("",0);
return s;
}
-static void
-set_csh()
+STATIC void
+set_csh(void)
{
#ifdef CSH
if (!cshlen)
}
I32
-start_subparse(is_format, flags)
-I32 is_format;
-U32 flags;
+start_subparse(I32 is_format, U32 flags)
{
+ dTHR;
I32 oldsavestack_ix = savestack_ix;
CV* outsidecv = compcv;
AV* comppadlist;
CvFLAGS(compcv) |= flags;
comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
padix = 0;
subline = curcop->cop_line;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
- CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
+#ifdef USE_THREADS
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
return oldsavestack_ix;
}
int
-yywarn(s)
-char *s;
+yywarn(char *s)
{
+ dTHR;
--error_count;
in_eval |= 2;
yyerror(s);
}
int
-yyerror(s)
-char *s;
+yyerror(char *s)
{
+ dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
if (in_eval & 2)
warn("%_", msg);
else if (in_eval)
- sv_catsv(GvSV(errgv), msg);
+ sv_catsv(ERRSV, msg);
else
PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
if (++error_count >= 10)
croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
in_my = 0;
+ in_my_stash = Nullhv;
return 0;
}
+
+
https://perl5.git.perl.org / perl5.git / blobdiff