static char ident_too_long[] = "Identifier too long";
-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.
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;
}
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);
}
}
/*
* 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;
}
/*
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 == '{') {
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) {
+ Perl_sv_recode_to_utf8(aTHX_ 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 *
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_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...*/
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;
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);
+ }
}
}
}
}
else { /* no override */
tmp = -tmp;
+ if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ WARN_MISC,
+ "dump() better written as CORE::dump()");
+ }
gv = Nullgv;
gvp = 0;
if (ckWARN(WARN_AMBIGUOUS) && hgv
if (ckWARN(WARN_RESERVED)) {
if (lastchar != '-') {
for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
- if (!*d)
+ if (!*d && strNE(PL_tokenbuf,"main"))
Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
PL_tokenbuf);
}
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);
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_ WARN_SYNTAX,
+ "Illegal character in prototype for %s : %s",
+ SvPVX(PL_subname), d);
SvCUR(PL_lex_stuff) = tmp;
have_proto = TRUE;
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
*/
if (!strchr(PL_tokenbuf,':')) {
-#ifdef USE_THREADS
+#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 */
yylval.opval->op_targ = tmp;
return PRIVATEREF;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
SV *namesv = AvARRAY(PL_comppad_name)[tmp];
/* might be an "our" variable" */
gv_fetchpv(SvPVX(sym),
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
- : TRUE
+ : GV_ADDMULTI
),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
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)) {
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 = (OP*)newUNOP(OP_READLINE, 0, o);
+ }
}
else {
- GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
+ GV *gv;
+ ++d;
+intro_sym:
+ gv = gv_fetchpv(d,
+ (PL_in_eval
+ ? (GV_ADDMULTI | GV_ADDINEVAL)
+ : GV_ADDMULTI),
+ SVt_PV);
PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv)));
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);
}
register char *e; /* end of temp buffer */
NV nv; /* number read, as a double */
SV *sv = Nullsv; /* place to put the converted number */
- bool floatit, /* boolean: int or float? */
- octal = 0; /* Is this an octal number? */
+ bool floatit; /* boolean: int or float? */
char *lastub = 0; /* position of last underbar */
static char number_too_long[] = "Number too long";
/* so it must be octal */
else {
shift = 3;
- octal = 1;
s++;
}
}
if (*s == '.' && isDIGIT(s[1])) {
/* oops, it's really a v-string, but without the "v" */
- s = start - 1;
+ s = start;
goto vstring;
}
}
/* 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;
}
/* make the op for the constant and return */
- if (sv) {
+ if (sv)
lvalp->opval = newSVOP(OP_CONST, 0, sv);
- if (octal)
- ((SVOP *)lvalp->opval)->op_private |= OPpCONST_OCTAL;
- }
else
lvalp->opval = Nullop;
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;
}
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
+