/* toke.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define yylval PL_yylval
static char ident_too_long[] = "Identifier too long";
+static char c_without_g[] = "Use of /c modifier is meaningless without /g";
+static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
-static void restore_rsfp(pTHXo_ void *f);
+static void restore_rsfp(pTHX_ void *f);
#ifndef PERL_NO_UTF16_FILTER
-static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
-static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
+static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
+static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
#endif
#define XFAKEBRACK 128
#define XENUMMASK 127
-#ifdef EBCDIC
-/* For now 'use utf8' does not affect tokenizer on EBCDIC */
-#define UTF (PL_linestr && DO_UTF8(PL_linestr))
+#ifdef USE_UTF8_SCRIPTS
+# define UTF (!IN_BYTES)
#else
-#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+# ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
+# define UTF (PL_linestr && DO_UTF8(PL_linestr))
+# else
+# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
+# endif
#endif
/* In variables named $^X, these are the legal values for X.
Perl_deprecate(pTHX_ char *s)
{
if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
+}
+
+void
+Perl_deprecate_old(pTHX_ char *s)
+{
+ /* This function should NOT be called for any new deprecated warnings */
+ /* Use Perl_deprecate instead */
+ /* */
+ /* It is here to maintain backward compatibility with the pre-5.8 */
+ /* warnings category hierarchy. The "deprecated" category used to */
+ /* live under the "syntax" category. It is now a top-level category */
+ /* in its own right. */
+
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ "Use of %s is deprecated", s);
}
/*
STATIC void
S_depcom(pTHX)
{
- deprecate("comma-less variable list");
+ deprecate_old("comma-less variable list");
}
/*
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
PL_bufend = PL_bufptr + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = Nullch;
- SvREFCNT_dec(PL_rs);
- PL_rs = newSVpvn("\n", 1);
PL_rsfp = 0;
}
ch = *t;
*t = '\0';
if (t - s > 0) {
-#ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-#else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+ CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, s);
}
*t = ch;
sv_upgrade(sv, SVt_PVMG);
sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = 0;
av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
}
if (ckWARN_d(WARN_AMBIGUOUS)){
char ch = *s;
*s = '\0';
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Warning: Use of \"%s\" without parens is ambiguous",
PL_last_uni);
*s = ch;
}
}
-/* workaround to replace the UNI() macro with a function. Only the
- * hints/uts.sh file mentions this. Other comments elsewhere in the
- * source indicate Microport Unix might need it too.
- */
-
-#ifdef CRIPPLED_CC
-
-#undef UNI
-#define UNI(f) return uni(f,s)
-
-STATIC int
-S_uni(pTHX_ I32 f, char *s)
-{
- yylval.ival = f;
- PL_expect = XTERM;
- PL_bufptr = s;
- PL_last_uni = PL_oldbufptr;
- PL_last_lop_op = f;
- if (*s == '(')
- return FUNC1;
- s = skipspace(s);
- if (*s == '(')
- return FUNC1;
- else
- return UNIOP;
-}
-
-#endif /* CRIPPLED_CC */
-
/*
* LOP : macro to build a list operator. Its behaviour has been replaced
* with a subroutine, S_lop() for which LOP is just another name.
/*
* S_force_version
* Forces the next token to be a version number.
+ * If the next token appears to be an invalid version number, (e.g. "v2b"),
+ * and if "guessing" is TRUE, then no new token is created (and the caller
+ * must use an alternative parsing method).
*/
STATIC char *
-S_force_version(pTHX_ char *s)
+S_force_version(pTHX_ char *s, int guessing)
{
OP *version = Nullop;
char *d;
if (*d == 'v')
d++;
if (isDIGIT(*d)) {
- for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
+ while (isDIGIT(*d) || *d == '_' || *d == '.')
+ d++;
if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
SV *ver;
s = scan_num(s, &yylval);
SvNOK_on(ver); /* hint that it is a version */
}
}
+ else if (guessing)
+ return s;
}
/* NOTE: The parser sees the package name and the VERSION swapped */
PL_nextval[PL_nexttoke].opval = version;
force_next(WORD);
- return (s);
+ return s;
}
/*
char *e = d++;
while (e-- > c)
*(e + 1) = *e;
- *c = UTF_TO_NATIVE(0xff);
+ *c = (char)UTF_TO_NATIVE(0xff);
/* mark the range as done, and continue */
dorange = FALSE;
didrange = TRUE;
Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
}
if (has_utf8) {
- *d++ = UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
+ *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
s++;
continue;
}
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
}
/* FALL THROUGH */
default:
{
- if (ckWARN(WARN_MISC) && isALNUM(*s))
- Perl_warner(aTHX_ WARN_MISC,
+ if (ckWARN(WARN_MISC) &&
+ isALNUM(*s) &&
+ *s != '_')
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Unrecognized escape \\%c passed through",
*s);
/* default action is to copy the quoted character */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
{
- STRLEN len = 0; /* disallow underscores */
- uv = (UV)scan_oct(s, 3, &len);
+ I32 flags = 0;
+ STRLEN len = 3;
+ uv = grok_oct(s, &len, &flags, NULL);
s += len;
}
goto NUM_ESCAPE_INSERT;
++s;
if (*s == '{') {
char* e = strchr(s, '}');
- STRLEN len = 1; /* allow underscores */
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
+ PERL_SCAN_DISALLOW_PREFIX;
+ STRLEN len;
+ ++s;
if (!e) {
yyerror("Missing right brace on \\x{}");
- ++s;
continue;
}
- uv = (UV)scan_hex(s + 1, e - s - 1, &len);
+ len = e - s;
+ uv = grok_hex(s, &len, &flags, NULL);
s = e + 1;
}
else {
{
- STRLEN len = 0; /* disallow underscores */
- uv = (UV)scan_hex(s, 2, &len);
+ STRLEN len = 2;
+ I32 flags = PERL_SCAN_DISALLOW_PREFIX;
+ uv = grok_hex(s, &len, &flags, NULL);
s += len;
}
}
}
continue;
- /* \N{latin small letter a} is a named character */
+ /* \N{LATIN SMALL LETTER A} is a named character */
case 'N':
++s;
if (*s == '{') {
if (has_utf8)
sv_utf8_upgrade(res);
str = SvPV(res,len);
+#ifdef EBCDIC_NEVER_MIND
+ /* charnames uses pack U and that has been
+ * recently changed to do the below uni->native
+ * mapping, so this would be redundant (and wrong,
+ * the code point would be doubly converted).
+ * But leave this in just in case the pack U change
+ * gets revoked, but the semantics is still
+ * desireable for charnames. --jhi */
+ {
+ UV uv = utf8_to_uvchr((U8*)str, 0);
+
+ if (uv < 0x100) {
+ U8 tmpbuf[UTF8_MAXLEN+1], *d;
+
+ d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
+ sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
+ str = SvPV(res, len);
+ }
+ }
+#endif
if (!has_utf8 && SvUTF8(res)) {
char *ostart = SvPVX(sv);
SvCUR_set(sv, d - ostart);
d = SvPVX(sv) + SvCUR(sv);
has_utf8 = TRUE;
}
- if (len > e - s + 4) {
+ if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
char *odest = SvPVX(sv);
SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
Perl_croak(aTHX_ "panic: constant overflowed allocated space");
SvPOK_on(sv);
+ if (PL_encoding && !has_utf8) {
+ sv_recode_to_utf8(sv, PL_encoding);
+ has_utf8 = TRUE;
+ }
if (has_utf8) {
SvUTF8_on(sv);
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
IoFLAGS(datasv) |= IOf_FAKE_DIRP;
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
- funcp, SvPV_nolen(datasv)));
+ (void*)funcp, SvPV_nolen(datasv)));
av_unshift(PL_rsfp_filters, 1);
av_store(PL_rsfp_filters, 0, datasv) ;
return(datasv);
Perl_filter_del(pTHX_ filter_t funcp)
{
SV *datasv;
- DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
+ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
funcp = (filter_t)IoANY(datasv);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
- idx, funcp, SvPV_nolen(datasv)));
+ idx, (void*)funcp, SvPV_nolen(datasv)));
/* 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)(aTHXo_ idx, buf_sv, maxlen);
+ return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}
STATIC char *
bool bof = FALSE;
/* check if there's an identifier for us to look at */
- if (PL_pending_ident) {
- /* pit holds the identifier we read and pending_ident is reset */
- 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.
-
- if it's a legal name, the OP is a PADANY.
- */
- if (PL_in_my) {
- if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
- if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ "No package name allowed for "
- "variable %s in \"our\"",
- PL_tokenbuf));
- tmp = pad_allocmy(PL_tokenbuf);
- }
- else {
- if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
-
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
- return PRIVATEREF;
- }
- }
-
- /*
- 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(PL_tokenbuf,':')) {
-#ifdef USE_THREADS
- /* Check for single character per-thread SVs */
- if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
- && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
- && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
- {
- yylval.opval = newOP(OP_THREADSV, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
- }
-#endif /* USE_THREADS */
- if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
- SV *namesv = AvARRAY(PL_comppad_name)[tmp];
- /* might be an "our" variable" */
- if (SvFLAGS(namesv) & SVpad_OUR) {
- /* build ops for a bareword */
- SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
- sv_catpvn(sym, "::", 2);
- sv_catpv(sym, PL_tokenbuf+1);
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(SvPVX(sym),
- (PL_in_eval
- ? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE
- ),
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
- return WORD;
- }
-
- /* if it's a sort block and they're naming $a or $b */
- if (PL_last_lop_op == OP_SORT &&
- PL_tokenbuf[0] == '$' &&
- (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
- && !PL_tokenbuf[2])
- {
- for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
- d < PL_bufend && *d != '\n';
- d++)
- {
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
- PL_tokenbuf);
- }
- }
- }
-
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
- }
- }
-
- /*
- 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 == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
- if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
- && ckWARN(WARN_AMBIGUOUS))
- {
- /* Downgraded from fatal to warning 20000522 mjd */
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
- "Possible unintended interpolation of %s in string",
- PL_tokenbuf);
- }
- }
-
- /* build ops for a bareword */
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
- ((PL_tokenbuf[0] == '$') ? SVt_PV
- : (PL_tokenbuf[0] == '@') ? SVt_PVAV
- : SVt_PVHV));
- return WORD;
- }
+ if (PL_pending_ident)
+ return S_pending_ident(aTHX);
/* no identifier pending identification */
if (PL_lex_dojoin) {
PL_nextval[PL_nexttoke].ival = 0;
force_next(',');
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
force_next(PRIVATEREF);
#else
force_ident("\"", '$');
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
PL_nextval[PL_nexttoke].ival = 0;
force_next('$');
PL_nextval[PL_nexttoke].ival = 0;
if (PL_minus_l)
sv_catpv(PL_linestr,"chomp;");
if (PL_minus_a) {
- GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
- if (gv)
- GvIMPORTED_AV_on(gv);
if (PL_minus_F) {
if (strchr("/'\"", *PL_splitstr)
&& strchr(PL_splitstr + 1, *PL_splitstr))
- Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
+ Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
else {
char delim;
s = "'~#\200\1'"; /* surely one char is unused...*/
while (s[1] && strchr(PL_splitstr, *s)) s++;
delim = *s;
- Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
+ Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
"q" + (delim == '\''), delim);
for (s = PL_splitstr; *s; s++) {
if (*s == '\\')
}
}
else
- sv_catpv(PL_linestr,"@F=split(' ');");
+ sv_catpv(PL_linestr,"our @F=split(' ');");
}
}
sv_catpv(PL_linestr, "\n");
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = 0;
av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
goto retry;
}
}
if (PL_doextract) {
- if (*s == '#' && s[1] == '!' && instr(s,"perl"))
- PL_doextract = FALSE;
-
/* Incest with pod. */
if (*s == '=' && strnEQ(s, "=cut", 4)) {
sv_setpv(PL_linestr, "");
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = 0;
av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
}
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
* at least, set argv[0] to the basename of the Perl
* interpreter. So, having found "#!", we'll set it right.
*/
- SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
+ SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
assert(SvPOK(x) || SvGMAGICAL(x));
if (sv_eq(x, CopFILESV(PL_curcop))) {
sv_setpvn(x, ipath, ipathend - ipath);
while (SPACE_OR_TAB(*d)) d++;
if (*d++ == '-') {
+ bool switches_done = PL_doswitches;
do {
if (*d == 'M' || *d == 'm') {
char *m = d;
(void)gv_fetchfile(PL_origfilename);
goto retry;
}
+ if (PL_doswitches && !switches_done) {
+ int argc = PL_origargc;
+ char **argv = PL_origargv;
+ do {
+ argc--,argv++;
+ } while (argc && argv[0][0] == '-' && argv[0][1]);
+ init_argv_symbols(argc,argv);
+ }
}
}
}
PL_lex_stuff = Nullsv;
}
else {
+ /* NOTE: any CV attrs applied here need to be part of
+ the CVf_BUILTIN_ATTRS define in cv.h! */
if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
CvLVALUE_on(PL_compcv);
else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
CvMETHOD_on(PL_compcv);
#ifdef USE_ITHREADS
- else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "shared", len))
- GvSHARED_on(cGVOPx_gv(yylval.opval));
+ else if (PL_in_my == KEY_our && len == 6 &&
+ strnEQ(s, "unique", len))
+ GvUNIQUE_on(cGVOPx_gv(yylval.opval));
#endif
/* After we've set the flags, it could be argued that
we don't need to do the attributes.pm-based setting
process, and shouldn't bother appending recognized
- flags. To experiment with that, uncomment the
- following "else": */
+ flags. To experiment with that, uncomment the
+ following "else". (Note that's already been
+ uncommented. That keeps the above-applied built-in
+ attributes from being intercepted (and possibly
+ rejected) by a package's attribute routines, but is
+ justified by the performance win for the common case
+ of applying only built-in attributes.) */
else
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
&& isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
{
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
BAop(OP_BIT_AND);
if (tmp == '~')
PMop(OP_MATCH);
if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
s--;
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
PL_bufptr = skipspace(PL_bufptr);
while (t < PL_bufend && *t != ']')
t++;
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Multidimensional syntax %.*s not supported",
(t - PL_bufptr) + 1, PL_bufptr);
}
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
for (; isSPACE(*t); t++) ;
if (*t == ';' && get_cv(tmpbuf, FALSE))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"You need to quote \"%s\"", tmpbuf);
}
}
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = skipspace(PL_bufptr);
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value %.*s better written as $%.*s",
t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
}
case '\\':
s++;
if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
- Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
*s, *s);
if (PL_expect == XOPERATOR)
no_op("Backslash",s);
}
else { /* no override */
tmp = -tmp;
+ if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "dump() better written as CORE::dump()");
+ }
gv = Nullgv;
gvp = 0;
if (ckWARN(WARN_AMBIGUOUS) && hgv
&& tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous call resolved as CORE::%s(), %s",
GvENAME(hgv), "qualify as such or use &");
}
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart) {
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
else
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
- Perl_warner(aTHX_ WARN_BAREWORD,
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
"Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
len -= 2;
if (gv && GvCVu(gv)) {
CV* cv;
if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of -%s resolved as -&%s()",
PL_tokenbuf, PL_tokenbuf);
/* Check for a constant sub */
if (strEQ(proto, "$"))
OPERATOR(UNIOPSUB);
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname,"__ANON__");
+ sv_setpv(PL_subname, PL_curstash ?
+ "__ANON__" : "__ANON__::__ANON__");
PREBLOCK(LSTOPSUB);
}
}
if (ckWARN(WARN_RESERVED)) {
if (lastchar != '-') {
for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
- if (!*d)
- Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
+ if (!*d && strNE(PL_tokenbuf,"main"))
+ Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
}
}
safe_bareword:
if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Operator or semicolon missing before %c%s",
lastchar, PL_tokenbuf);
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c resolved as operator %c",
lastchar, lastchar);
}
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
- if (ckWARN(WARN_CHMOD)) {
- for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
- if (*d != '0' && isDIGIT(*d))
- Perl_warner(aTHX_ WARN_CHMOD,
- "chmod() mode argument is missing initial 0");
- }
LOP(OP_CHMOD,XTERM);
case KEY_chown:
if (*s == '{')
PRETERMBLOCK(DO);
if (*s != '\'')
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_word(s,WORD,TRUE,TRUE,FALSE);
OPERATOR(DO);
case KEY_die:
if (PL_expect != XSTATE)
yyerror("\"no\" not allowed in expression");
s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s);
+ s = force_version(s, FALSE);
yylval.ival = 0;
OPERATOR(USE);
for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
t = skipspace(d);
if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
- Perl_warner(aTHX_ WARN_PRECEDENCE,
+ Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
"Precedence problem: open %.*s should be open(%.*s)",
d-s,s, d-s,s);
}
if (!warned && ckWARN(WARN_QW)) {
for (; !isSPACE(*d) && len; --len, ++d) {
if (*d == ',') {
- Perl_warner(aTHX_ WARN_QW,
+ Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to separate words with commas");
++warned;
}
else if (*d == '#') {
- Perl_warner(aTHX_ WARN_QW,
+ Perl_warner(aTHX_ packWARN(WARN_QW),
"Possible attempt to put comments in qw() list");
++warned;
}
case KEY_require:
s = skipspace(s);
- if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
- s = force_version(s);
+ if (isDIGIT(*s)) {
+ s = force_version(s, FALSE);
}
- else {
+ else if (*s != 'v' || !isDIGIT(s[1])
+ || (s = force_version(s, TRUE), *s == 'v'))
+ {
*PL_tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
char tmpbuf[sizeof PL_tokenbuf];
SSize_t tboffset = 0;
expectation attrful;
- bool have_name, have_proto;
+ bool have_name, have_proto, bad_proto;
int key = tmp;
s = skipspace(s);
s = scan_str(s,FALSE,FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
- /* strip spaces */
+ /* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
+ bad_proto = FALSE;
for (p = d; *p; ++p) {
- if (!isSPACE(*p))
+ if (!isSPACE(*p)) {
d[tmp++] = *p;
+ if (!strchr("$@%*;[]&\\", *p))
+ bad_proto = TRUE;
+ }
}
d[tmp] = '\0';
+ if (bad_proto && ckWARN(WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Illegal character in prototype for %s : %s",
+ SvPVX(PL_subname), d);
SvCUR(PL_lex_stuff) = tmp;
have_proto = TRUE;
force_next(THING);
}
if (!have_name) {
- sv_setpv(PL_subname,"__ANON__");
+ sv_setpv(PL_subname,
+ PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
TOKEN(ANONSUB);
}
(void) force_word(PL_oldbufptr + tboffset, WORD,
LOP(OP_UTIME,XTERM);
case KEY_umask:
- if (ckWARN(WARN_UMASK)) {
- for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
- if (*d != '0' && isDIGIT(*d))
- Perl_warner(aTHX_ WARN_UMASK,
- "umask: argument is missing initial 0");
- }
UNI(OP_UMASK);
case KEY_unshift:
yyerror("\"use\" not allowed in expression");
s = skipspace(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
- s = force_version(s);
+ s = force_version(s, TRUE);
if (*s == ';' || (s = skipspace(s), *s == ';')) {
PL_nextval[PL_nexttoke].opval = Nullop;
force_next(WORD);
}
+ else if (*s == 'v') {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s, FALSE);
+ }
}
else {
s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s);
+ s = force_version(s, FALSE);
}
yylval.ival = 1;
OPERATOR(USE);
case KEY_write:
#ifdef EBCDIC
{
- static char ctl_l[2];
-
- if (ctl_l[0] == '\0')
- ctl_l[0] = toCTRL('L');
+ char ctl_l[2];
+ ctl_l[0] = toCTRL('L');
+ ctl_l[1] = '\0';
gv_fetchpv(ctl_l,TRUE, SVt_PV);
}
#else
#pragma segment Main
#endif
+static int
+S_pending_ident(pTHX)
+{
+ register char *d;
+ register I32 tmp;
+ /* pit holds the identifier we read and pending_ident is reset */
+ 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.
+
+ if it's a legal name, the OP is a PADANY.
+ */
+ if (PL_in_my) {
+ if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
+ if (strchr(PL_tokenbuf,':'))
+ yyerror(Perl_form(aTHX_ "No package name allowed for "
+ "variable %s in \"our\"",
+ PL_tokenbuf));
+ tmp = pad_allocmy(PL_tokenbuf);
+ }
+ else {
+ if (strchr(PL_tokenbuf,':'))
+ yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
+ return PRIVATEREF;
+ }
+ }
+
+ /*
+ 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(PL_tokenbuf,':')) {
+#ifdef USE_5005THREADS
+ /* Check for single character per-thread SVs */
+ if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
+ && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
+ && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
+ {
+ yylval.opval = newOP(OP_THREADSV, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+#endif /* USE_5005THREADS */
+ if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
+ SV *namesv = AvARRAY(PL_comppad_name)[tmp];
+ /* might be an "our" variable" */
+ if (SvFLAGS(namesv) & SVpad_OUR) {
+ /* build ops for a bareword */
+ SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
+ sv_catpvn(sym, "::", 2);
+ sv_catpv(sym, PL_tokenbuf+1);
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(SvPVX(sym),
+ (PL_in_eval
+ ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADDMULTI
+ ),
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+ }
+
+ /* if it's a sort block and they're naming $a or $b */
+ if (PL_last_lop_op == OP_SORT &&
+ PL_tokenbuf[0] == '$' &&
+ (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
+ && !PL_tokenbuf[2])
+ {
+ for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
+ d < PL_bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
+ PL_tokenbuf);
+ }
+ }
+ }
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+ }
+
+ /*
+ 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 == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
+ GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
+ if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ && ckWARN(WARN_AMBIGUOUS))
+ {
+ /* Downgraded from fatal to warning 20000522 mjd */
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Possible unintended interpolation of %s in string",
+ PL_tokenbuf);
+ }
+ }
+
+ /* build ops for a bareword */
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+}
+
I32
Perl_keyword(pTHX_ register char *d, I32 len)
{
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"%s (...) interpreted as function",name);
}
}
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
const char *brack = *s == '[' ? "[...]" : "{...}";
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest) || get_cv(dest, FALSE)))
{
- Perl_warner(aTHX_ WARN_AMBIGUOUS,
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
while (*s && strchr("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
}
+ /* issue a warning if /c is specified,but /g is not */
+ if (ckWARN(WARN_REGEXP) &&
+ (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
+ }
+
pm->op_pmpermflags = pm->op_pmflags;
PL_lex_op = (OP*)pm;
break;
}
+ /* /c is not meaningful with s/// */
+ if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
+ }
+
if (es) {
SV *repl;
PL_sublex_info.super_bufptr = s;
else
term = '"';
if (!isALNUM_lazy_if(s,UTF))
- deprecate("bare << to mean <<\"\"");
+ deprecate_old("bare << to mean <<\"\"");
for (; isALNUM_lazy_if(s,UTF); s++) {
if (d < e)
*d++ = *s;
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = 0;
av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
}
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
return s;
}
else {
+ bool readline_overriden = FALSE;
+ GV *gv_readline = Nullgv;
+ GV **gvp;
/* we're in a filehandle read situation */
d = PL_tokenbuf;
if (!len)
(void)strcpy(d,"ARGV");
+ /* Check whether readline() is overriden */
+ if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
+ ||
+ ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
+ && (gv_readline = *gvp) != (GV*)&PL_sv_undef
+ && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
+ readline_overriden = TRUE;
+
/* if <$fh>, create the ops to turn the variable into a
filehandle
*/
add symbol table ops
*/
if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
- OP *o = newOP(OP_PADSV, 0);
- o->op_targ = tmp;
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
+ SV *namesv = AvARRAY(PL_comppad_name)[tmp];
+ if (SvFLAGS(namesv) & SVpad_OUR) {
+ SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
+ sv_catpvn(sym, "::", 2);
+ sv_catpv(sym, d+1);
+ d = SvPVX(sym);
+ goto intro_sym;
+ }
+ else {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = tmp;
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, o,
+ newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0, o);
+ }
}
else {
- GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
- newUNOP(OP_RV2SV, 0,
- newGVOP(OP_GV, 0, gv)));
- }
- PL_lex_op->op_flags |= OPf_SPECIAL;
+ GV *gv;
+ ++d;
+intro_sym:
+ gv = gv_fetchpv(d,
+ (PL_in_eval
+ ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADDMULTI),
+ SVt_PV);
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0,
+ newUNOP(OP_RV2SV, 0,
+ newGVOP(OP_GV, 0, gv)));
+ }
+ if (!readline_overriden)
+ PL_lex_op->op_flags |= OPf_SPECIAL;
/* we created the ops in PL_lex_op, so make yylval.ival a null op */
yylval.ival = OP_NULL;
}
(<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
- PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
+ PL_lex_op = readline_overriden
+ ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newGVOP(OP_GV, 0, gv),
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
+ : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
yylval.ival = OP_NULL;
}
}
sv_upgrade(sv, SVt_PVMG);
sv_setsv(sv,PL_linestr);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = 0;
av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
}
if (*s == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
}
/* _ are ignored -- but warned about if consecutive */
case '_':
if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
break;
overflowed = TRUE;
n = (NV) u;
if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
+ Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in %s number",
base);
} else
/* final misplaced underbar check */
if (s[-1] == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
sv = NEWSV(92,0);
if (overflowed) {
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
- Perl_warner(aTHX_ WARN_PORTABLE,
+ Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
sv_setnv(sv, n);
else {
#if UVSIZE > 4
if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
- Perl_warner(aTHX_ WARN_PORTABLE,
+ Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"%s number > %s non-portable",
Base, max);
#endif
*/
if (*s == '_') {
if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
}
/* final misplaced underbar check */
if (lastub && s == lastub + 1) {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
}
/* read a decimal portion if there is one. avoid
if (*s == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s;
}
Perl_croak(aTHX_ number_too_long);
if (*s == '_') {
if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s;
}
/* fractional part ending in underbar? */
if (s[-1] == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
}
if (*s == '.' && isDIGIT(s[1])) {
/* oops, it's really a v-string, but without the "v" */
- s = start - 1;
+ s = start;
goto vstring;
}
}
/* stray preinitial _ */
if (*s == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
}
/* stray initial _ */
if (*s == '_') {
if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
}
if (ckWARN(WARN_SYNTAX) &&
((lastub && s == lastub + 1) ||
(!isDIGIT(s[1]) && s[1] != '_')))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Misplaced _ in number");
lastub = s++;
}
}
}
- /* terminate the string */
- *d = '\0';
/* make an sv from the string */
sv = NEWSV(92,0);
-#if defined(Strtol) && defined(Strtoul)
-
/*
- strtol/strtoll sets errno to ERANGE if the number is too big
- for an integer. We try to do an integer conversion first
- if no characters indicating "float" have been found.
+ We try to do an integer conversion first if no characters
+ indicating "float" have been found.
*/
if (!floatit) {
- IV iv = 0;
- UV uv = 0;
- errno = 0;
- if (*PL_tokenbuf == '-')
- iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
- else
- uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
- if (errno)
- floatit = TRUE; /* Probably just too large. */
- else if (*PL_tokenbuf == '-')
- sv_setiv(sv, iv);
- else if (uv <= IV_MAX)
+ UV uv;
+ int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
+
+ if (flags == IS_NUMBER_IN_UV) {
+ if (uv <= IV_MAX)
sv_setiv(sv, uv); /* Prefer IVs over UVs. */
- else
+ else
sv_setuv(sv, uv);
- }
+ } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
+ if (uv <= (UV) IV_MIN)
+ sv_setiv(sv, -(IV)uv);
+ else
+ floatit = TRUE;
+ } else
+ floatit = TRUE;
+ }
if (floatit) {
+ /* terminate the string */
+ *d = '\0';
nv = Atof(PL_tokenbuf);
sv_setnv(sv, nv);
}
-#else
- /*
- No working strtou?ll?.
- Unfortunately atol() doesn't do range checks (returning
- LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
- everywhere [1], so we cannot use use atol() (or atoll()).
- If we could, they would be used, as Atol(), very much like
- Strtol() and Strtoul() are used above.
-
- [1] XXX Configure test needed to check for atol()
- (and atoll()) overflow behaviour XXX
-
- --jhi
-
- We need to do this the hard way. */
-
- nv = Atof(PL_tokenbuf);
-
- /* See if we can make do with an integer value without loss of
- precision. We use U_V to cast to a UV, because some
- compilers have issues. Then we try casting it back and see
- if it was the same [1]. We only do this if we know we
- specifically read an integer. If floatit is true, then we
- don't need to do the conversion at all.
-
- [1] Note that this is lossy if our NVs cannot preserve our
- UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean)
- and NV_PRESERVES_UV_BITS (a number), but in general we really
- do hope all such potentially lossy platforms have strtou?ll?
- to do a lossless IV/UV conversion.
-
- Maybe could do some tricks with DBL_DIG, LDBL_DIG and
- DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
- as NV_DIG and NV_MANT_DIG)?
-
- --jhi
- */
- {
- UV uv = U_V(nv);
- if (!floatit && (NV)uv == nv) {
- if (uv <= IV_MAX)
- sv_setiv(sv, uv); /* Prefer IVs over UVs. */
- else
- sv_setuv(sv, uv);
- }
- else
- sv_setnv(sv, nv);
- }
-#endif
if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
(PL_hints & HINT_NEW_INTEGER) )
sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
/* if it starts with a v, it could be a v-string */
case 'v':
vstring:
- {
- char *pos = s;
- pos++;
- while (isDIGIT(*pos) || *pos == '_')
- pos++;
- if (!isALPHA(*pos)) {
- UV rev;
- U8 tmpbuf[UTF8_MAXLEN+1];
- U8 *tmpend;
- s++; /* get past 'v' */
-
- sv = NEWSV(92,5);
- sv_setpvn(sv, "", 0);
-
- for (;;) {
- if (*s == '0' && isDIGIT(s[1]))
- yyerror("Octal number in vector unsupported");
- rev = 0;
- {
- /* this is atoi() that tolerates underscores */
- char *end = pos;
- UV mult = 1;
- while (--end >= s) {
- UV orev;
- if (*end == '_')
- continue;
- orev = rev;
- rev += (*end - '0') * mult;
- mult *= 10;
- if (orev > rev && ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in decimal number");
- }
- }
- /* Append native character for the rev point */
- tmpend = uvchr_to_utf8(tmpbuf, rev);
- sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
- if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
- SvUTF8_on(sv);
- if (*pos == '.' && isDIGIT(pos[1]))
- s = ++pos;
- else {
- s = pos;
- break;
- }
- while (isDIGIT(*pos) || *pos == '_')
- pos++;
- }
- SvPOK_on(sv);
- SvREADONLY_on(sv);
- }
- }
+ sv = NEWSV(92,5); /* preallocate storage space */
+ s = new_vstring(s,sv);
break;
}
if (*t == '@' || *t == '^')
needargs = TRUE;
}
- sv_catpvn(stuff, s, eol-s);
+ if (eol > s) {
+ sv_catpvn(stuff, s, eol-s);
#ifndef PERL_STRICT_CR
- if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
- char *end = SvPVX(stuff) + SvCUR(stuff);
- end[-2] = '\n';
- end[-1] = '\0';
- SvCUR(stuff)--;
- }
+ if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
+ char *end = SvPVX(stuff) + SvCUR(stuff);
+ end[-2] = '\n';
+ end[-1] = '\0';
+ SvCUR(stuff)--;
+ }
#endif
+ }
+ else
+ break;
}
s = eol;
if (PL_rsfp) {
PL_min_intro_pending = 0;
PL_padix = 0;
PL_subline = CopLINE(PL_curcop);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
PL_curpad[0] = (SV*)newAV();
SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
CvPADLIST(PL_compcv) = comppadlist;
CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
return oldsavestack_ix;
}
}
msg = sv_2mortal(newSVpv(s, 0));
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+ OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (context)
Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
else
if (PL_error_count >= 10) {
if (PL_in_eval && SvCUR(ERRSV))
Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
- ERRSV, CopFILE(PL_curcop));
+ ERRSV, OutCopFILE(PL_curcop));
else
Perl_croak(aTHX_ "%s has too many errors.\n",
- CopFILE(PL_curcop));
+ OutCopFILE(PL_curcop));
}
PL_in_my = 0;
PL_in_my_stash = Nullhv;
return (char*)s;
}
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
/*
* restore_rsfp
* Restore a source filter.
*/
static void
-restore_rsfp(pTHXo_ void *f)
+restore_rsfp(pTHX_ void *f)
{
PerlIO *fp = (PerlIO*)f;
#ifndef PERL_NO_UTF16_FILTER
static I32
-utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
I32 count = FILTER_READ(idx+1, sv, maxlen);
if (count) {
}
static I32
-utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
{
I32 count = FILTER_READ(idx+1, sv, maxlen);
if (count) {
return count;
}
#endif
+