* Aop : addition-level operator
* Mop : multiplication-level operator
* Eop : equality-testing operator
- * Rop : relational operator <= != gt
+ * Rop : relational operator <= != gt
*
* Also see LOP and lop() below.
*/
void
Perl_deprecate(pTHX_ char *s)
{
- dTHR;
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
}
void
Perl_lex_start(pTHX_ SV *line)
{
- dTHR;
char *s;
STRLEN len;
STATIC void
S_incline(pTHX_ char *s)
{
- dTHR;
char *t;
char *n;
char *e;
STATIC char *
S_skipspace(pTHX_ register char *s)
{
- dTHR;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
{
char *s;
char *t;
- dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dTHR;
yylval.ival = f;
CLINE;
PL_expect = x;
PL_nextval[PL_nexttoke].opval = o;
force_next(WORD);
if (kind) {
- 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.
STATIC I32
S_sublex_push(pTHX)
{
- dTHR;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
/* FALL THROUGH */
default:
{
- dTHR;
if (ckWARN(WARN_MISC) && isALNUM(*s))
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
int
Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
{
- dTHR;
int r;
yylval_pointer[yyactlevel] = lvalp;
Perl_yylex(pTHX)
#endif
{
- dTHR;
register char *s;
register char *d;
register I32 tmp;
char pit = PL_pending_ident;
PL_pending_ident = 0;
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Tokener saw identifier '%s'\n", PL_tokenbuf); })
+
/* 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.
PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
+ (IV)PL_nexttype[PL_nexttoke]); })
+
return(PL_nexttype[PL_nexttoke]);
/* interpolated case modifiers like \L \U, including \Q and \E.
return yylex();
}
else {
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Saw case modifier at '%s'\n", PL_bufptr); })
s = PL_bufptr + 1;
if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
case LEX_INTERPSTART:
if (PL_bufptr == PL_bufend)
return sublex_done();
+ DEBUG_T({ PerlIO_printf(Perl_debug_log,
+ "### Interpolated variable at '%s'\n", PL_bufptr); })
PL_expect = XTERM;
PL_lex_dojoin = (*PL_bufptr == '@');
PL_lex_state = LEX_INTERPNORMAL;
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
- DEBUG_p( {
+ DEBUG_T( {
PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
exp_name[PL_expect], s);
} )
PL_last_lop = 0;
if (PL_lex_brackets)
yyerror("Missing right curly or square bracket");
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Tokener got EOF\n");
+ } )
TOKEN(0);
}
if (s++ < PL_bufend)
else
newargv = PL_origargv;
newargv[0] = ipath;
- PerlProc_execv(ipath, newargv);
+ PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
Perl_croak(aTHX_ "Can't exec %s", ipath);
}
#endif
goto retry;
case '-':
if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+ I32 ftst = 0;
+
s++;
PL_bufptr = s;
tmp = *s++;
if (strnEQ(s,"=>",2)) {
s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw unary minus before =>, forcing word '%s'\n", s);
+ } )
OPERATOR('-'); /* unary minus */
}
PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = OP_FTEREAD; /* good enough */
switch (tmp) {
- case 'r': FTST(OP_FTEREAD);
- case 'w': FTST(OP_FTEWRITE);
- case 'x': FTST(OP_FTEEXEC);
- case 'o': FTST(OP_FTEOWNED);
- case 'R': FTST(OP_FTRREAD);
- case 'W': FTST(OP_FTRWRITE);
- case 'X': FTST(OP_FTREXEC);
- case 'O': FTST(OP_FTROWNED);
- case 'e': FTST(OP_FTIS);
- case 'z': FTST(OP_FTZERO);
- case 's': FTST(OP_FTSIZE);
- case 'f': FTST(OP_FTFILE);
- case 'd': FTST(OP_FTDIR);
- case 'l': FTST(OP_FTLINK);
- case 'p': FTST(OP_FTPIPE);
- case 'S': FTST(OP_FTSOCK);
- case 'u': FTST(OP_FTSUID);
- case 'g': FTST(OP_FTSGID);
- case 'k': FTST(OP_FTSVTX);
- case 'b': FTST(OP_FTBLK);
- case 'c': FTST(OP_FTCHR);
- case 't': FTST(OP_FTTTY);
- case 'T': FTST(OP_FTTEXT);
- case 'B': FTST(OP_FTBINARY);
- case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
- case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
- case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+ case 'r': ftst = OP_FTEREAD; break;
+ case 'w': ftst = OP_FTEWRITE; break;
+ case 'x': ftst = OP_FTEEXEC; break;
+ case 'o': ftst = OP_FTEOWNED; break;
+ case 'R': ftst = OP_FTRREAD; break;
+ case 'W': ftst = OP_FTRWRITE; break;
+ case 'X': ftst = OP_FTREXEC; break;
+ case 'O': ftst = OP_FTROWNED; break;
+ case 'e': ftst = OP_FTIS; break;
+ case 'z': ftst = OP_FTZERO; break;
+ case 's': ftst = OP_FTSIZE; break;
+ case 'f': ftst = OP_FTFILE; break;
+ case 'd': ftst = OP_FTDIR; break;
+ case 'l': ftst = OP_FTLINK; break;
+ case 'p': ftst = OP_FTPIPE; break;
+ case 'S': ftst = OP_FTSOCK; break;
+ case 'u': ftst = OP_FTSUID; break;
+ case 'g': ftst = OP_FTSGID; break;
+ case 'k': ftst = OP_FTSVTX; break;
+ case 'b': ftst = OP_FTBLK; break;
+ case 'c': ftst = OP_FTCHR; break;
+ case 't': ftst = OP_FTTTY; break;
+ case 'T': ftst = OP_FTTEXT; break;
+ case 'B': ftst = OP_FTBINARY; break;
+ case 'M': case 'A': case 'C':
+ gv_fetchpv("\024",TRUE, SVt_PV);
+ switch (tmp) {
+ case 'M': ftst = OP_FTMTIME; break;
+ case 'A': ftst = OP_FTATIME; break;
+ case 'C': ftst = OP_FTCTIME; break;
+ default: break;
+ }
+ break;
default:
- Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
break;
}
+ if (ftst) {
+ PL_last_lop_op = ftst;
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw file test %c\n", ftst);
+ } )
+ if (*s == '(' && ckWARN(WARN_AMBIGUOUS))
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Ambiguous -%c() resolved as a file test",
+ tmp);
+ FTST(ftst);
+ }
+ else {
+ /* Assume it was a minus followed by a one-letter named
+ * subroutine call (or a -bareword), then. */
+ s -= 2;
+ }
}
tmp = *s++;
if (*s == tmp) {
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &yylval);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw number in '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR)
no_op("Number",s);
TERM(THING);
case '\'':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw string in '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '"':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw string in '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR) {
if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
PL_expect = XTERM;
case '`':
s = scan_str(s,FALSE,FALSE);
+ DEBUG_T( { PerlIO_printf(Perl_debug_log,
+ "### Saw backtick string in '%s'\n", s);
+ } )
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (!s)
char *w;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
for (w = s+2; *w && level; w++) {
*d = '\0';
while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
const char *brack = *s == '[' ? "[...]" : "{...}";
Perl_warner(aTHX_ WARN_AMBIGUOUS,
if (funny == '#')
funny = '@';
if (PL_lex_state == LEX_NORMAL) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest) || get_cv(dest, FALSE)))
{
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
- dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
STATIC char *
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
{
- dTHR;
SV *sv; /* scalar value: string */
char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
we in octal/hex/binary?" indicator to disallow hex characters
when in octal mode.
*/
- dTHR;
NV n = 0.0;
UV u = 0;
I32 shift;
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
- dTHR;
overflowed = TRUE;
n = (NV) u;
if (ckWARN_d(WARN_OVERFLOW))
out:
sv = NEWSV(92,0);
if (overflowed) {
- dTHR;
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
}
else {
#if UVSIZE > 4
- dTHR;
if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
if -w is on
*/
if (*s == '_') {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
/* final misplaced underbar check */
if (lastub && s - lastub != 3) {
- dTHR;
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
pos++;
if (!isALPHA(*pos)) {
UV rev;
- U8 tmpbuf[UTF8_MAXLEN];
+ U8 tmpbuf[UTF8_MAXLEN+1];
U8 *tmpend;
bool utf8 = FALSE;
s++; /* get past 'v' */
STATIC char *
S_scan_formline(pTHX_ register char *s)
{
- dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpvn("",0);
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dTHR;
I32 oldsavestack_ix = PL_savestack_ix;
CV* outsidecv = PL_compcv;
AV* comppadlist;
int
Perl_yywarn(pTHX_ char *s)
{
- dTHR;
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
int
Perl_yyerror(pTHX_ char *s)
{
- dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
projects / p5sagit/p5-mst-13.2.git / blobdiff