static char ident_too_long[] = "Identifier too long";
+static void restore_rsfp(pTHXo_ void *f);
+static void restore_expect(pTHXo_ void *e);
+static void restore_lex_expect(pTHXo_ void *e);
+
#define UTF (PL_hints & HINT_UTF8)
/*
* Note: we try to be careful never to call the isXXX_utf8() functions
char *oldbp = PL_bufptr;
bool is_first = (PL_oldbufptr == PL_linestart);
+ assert(s >= oldbp);
PL_bufptr = s;
yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
if (is_first)
if (t < PL_bufptr && isSPACE(*t))
Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
t - PL_oldoldbufptr, PL_oldoldbufptr);
-
}
- else if (s <= oldbp)
- Perl_warn(aTHX_ "\t(Missing operator before end of line?)\n");
else
Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
PL_bufptr = oldbp;
SAVESPTR(PL_linestr);
SAVEPPTR(PL_lex_brackstack);
SAVEPPTR(PL_lex_casestack);
- SAVEDESTRUCTOR(S_restore_rsfp, PL_rsfp);
+ SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
SAVESPTR(PL_lex_stuff);
SAVEI32(PL_lex_defer);
SAVESPTR(PL_lex_repl);
- SAVEDESTRUCTOR(S_restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
- SAVEDESTRUCTOR(S_restore_lex_expect, PL_tokenbuf + PL_expect);
+ SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
+ SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
PL_lex_state = LEX_NORMAL;
PL_lex_defer = 0;
}
STATIC void
-S_restore_rsfp(pTHX_ void *f)
-{
- PerlIO *fp = (PerlIO*)f;
-
- if (PL_rsfp == PerlIO_stdin())
- PerlIO_clearerr(PL_rsfp);
- else if (PL_rsfp && (PL_rsfp != fp))
- PerlIO_close(PL_rsfp);
- PL_rsfp = fp;
-}
-
-STATIC void
-S_restore_expect(pTHX_ void *e)
-{
- /* a safe way to store a small integer in a pointer */
- PL_expect = (expectation)((char *)e - PL_tokenbuf);
-}
-
-STATIC void
-S_restore_lex_expect(pTHX_ void *e)
-{
- /* a safe way to store a small integer in a pointer */
- PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
-}
-
-STATIC void
S_incline(pTHX_ char *s)
{
dTHR;
S_check_uni(pTHX)
{
char *s;
- char ch;
char *t;
+ dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
if ((t = strchr(s, '(')) && t < PL_bufptr)
return;
- ch = *s;
- *s = '\0';
- Perl_warn(aTHX_ "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
- *s = ch;
+ if (ckWARN_d(WARN_AMBIGUOUS)){
+ char ch = *s;
+ *s = '\0';
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Warning: Use of \"%s\" without parens is ambiguous",
+ PL_last_uni);
+ *s = ch;
+ }
}
#ifdef CRIPPLED_CC
case 't':
*d++ = '\t';
break;
+#ifdef EBCDIC
+ case 'e':
+ *d++ = '\047'; /* CP 1047 */
+ break;
+ case 'a':
+ *d++ = '\057'; /* CP 1047 */
+ break;
+#else
case 'e':
*d++ = '\033';
break;
case 'a':
*d++ = '\007';
break;
+#endif
} /* end switch */
s++;
if (!SvUPGRADE(datasv, SVt_PVIO))
Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
+#ifdef DEBUGGING
if (PL_filter_debug) {
STRLEN n_a;
Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
}
+#endif /* DEBUGGING */
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
void
Perl_filter_del(pTHX_ filter_t funcp)
{
+#ifdef DEBUGGING
if (PL_filter_debug)
Perl_warn(aTHX_ "filter_del func %p", funcp);
+#endif /* DEBUGGING */
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
+#ifdef DEBUGGING
if (PL_filter_debug)
Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
+#endif /* DEBUGGING */
if (maxlen) {
/* Want a block */
int len ;
}
/* Skip this filter slot if filter has been deleted */
if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
+#ifdef DEBUGGING
if (PL_filter_debug)
Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
+#endif /* DEBUGGING */
return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = (filter_t)IoDIRP(datasv);
+#ifdef DEBUGGING
if (PL_filter_debug) {
STRLEN n_a;
Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
idx, funcp, SvPV(datasv,n_a));
}
+#endif /* DEBUGGING */
/* 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)(aTHX_ idx, buf_sv, maxlen);
+ return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
}
STATIC char *
|| (*t == '=' && t[1] == '>')))
OPERATOR(HASHBRACK);
if (PL_expect == XREF)
- PL_expect = XSTATE; /* was XTERM, trying XSTATE */
+ PL_expect = XTERM;
else {
PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
PL_expect = XSTATE;
}
if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
- if (PL_expect == XOPERATOR)
- no_op("Array length", PL_bufptr);
PL_tokenbuf[0] = '@';
- s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
- FALSE);
+ s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR)
+ no_op("Array length", s);
if (!PL_tokenbuf[1])
PREREF(DOLSHARP);
PL_expect = XOPERATOR;
TOKEN(DOLSHARP);
}
- if (PL_expect == XOPERATOR)
- no_op("Scalar", PL_bufptr);
PL_tokenbuf[0] = '$';
- s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
+ sizeof PL_tokenbuf - 1, FALSE);
+ if (PL_expect == XOPERATOR)
+ no_op("Scalar", s);
if (!PL_tokenbuf[1]) {
if (s == PL_bufend)
yyerror("Final $ should be \\$ or $name");
if (gv && GvCVu(gv)) {
CV* cv;
- if (lastchar == '-')
- Perl_warn(aTHX_ "Ambiguous use of -%s resolved as -&%s()",
+ if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
cv = GvCV(gv);
}
safe_bareword:
- if (lastchar && strchr("*%&", lastchar)) {
- Perl_warn(aTHX_ "Operator or semicolon missing before %c%s",
+ if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Operator or semicolon missing before %c%s",
lastchar, PL_tokenbuf);
- Perl_warn(aTHX_ "Ambiguous use of %c resolved as operator %c",
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Ambiguous use of %c resolved as operator %c",
lastchar, lastchar);
}
TOKEN(WORD);
TERM(sublex_start());
case KEY_map:
- LOP(OP_MAPSTART, XREF);
-
+ LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
+
case KEY_mkdir:
LOP(OP_MKDIR,XTERM);
char *t;
for (d = s; isALNUM_lazy(d); d++) ;
t = skipspace(d);
- if (strchr("|&*+-=!?:.", *t))
- Perl_warn(aTHX_ "Precedence problem: open %.*s should be open(%.*s)",
- d-s,s, d-s,s);
+ if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
+ Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ "Precedence problem: open %.*s should be open(%.*s)",
+ d-s,s, d-s,s);
}
LOP(OP_OPEN,XTERM);
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 */
+ NV 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 */
we in octal/hex/binary?" indicator to disallow hex characters
when in octal mode.
*/
+ dTHR;
UV u;
I32 shift;
bool overflowed = FALSE;
digit:
n = u << shift; /* make room for the digit */
if (!overflowed && (n >> shift) != u
- && !(PL_hints & HINT_NEW_BINARY)) {
- Perl_warn(aTHX_ "Integer overflow in %s number",
- (shift == 4) ? "hex"
- : ((shift == 3) ? "octal" : "binary"));
+ && !(PL_hints & HINT_NEW_BINARY))
+ {
+ if (ckWARN_d(WARN_UNSAFE))
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "Integer overflow in %s number",
+ (shift == 4) ? "hex"
+ : ((shift == 3) ? "octal" : "binary"));
overflowed = TRUE;
}
u = n | b; /* add the digit to the end */
conversion at all.
*/
tryiv = I_V(value);
- if (!floatit && (double)tryiv == value)
+ if (!floatit && (NV)tryiv == value)
sv_setiv(sv, tryiv);
else
sv_setnv(sv, value);
}
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#include "XSUB.h"
+#endif
+
+static void
+restore_rsfp(pTHXo_ void *f)
+{
+ PerlIO *fp = (PerlIO*)f;
+
+ if (PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else if (PL_rsfp && (PL_rsfp != fp))
+ PerlIO_close(PL_rsfp);
+ PL_rsfp = fp;
+}
+
+static void
+restore_expect(pTHXo_ void *e)
+{
+ /* a safe way to store a small integer in a pointer */
+ PL_expect = (expectation)((char *)e - PL_tokenbuf);
+}
+
+static void
+restore_lex_expect(pTHXo_ void *e)
+{
+ /* a safe way to store a small integer in a pointer */
+ PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
+}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff