if (len &&
!(is_our ||
isALPHA(name[1]) ||
- ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
- if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
+ if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
switch (o->op_type) {
case OP_UNDEF:
- localize = 0;
PL_modcount++;
return o;
case OP_STUB:
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
- assert(o || type != OP_SASSIGN);
-
switch (type) {
+ case OP_POS:
case OP_SASSIGN:
+ assert(o);
if (o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
newSTATEOP(0, NULL, imop) ));
if (use_version) {
- HV * const hinthv = GvHV(PL_hintgv);
- const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
-
/* Enable the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
/* If a version >= 5.11.0 is requested, strictures are on by default! */
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
PL_hints |= HINT_STRICT_REFS;
- if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
PL_hints |= HINT_STRICT_SUBS;
- if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
PL_hints |= HINT_STRICT_VARS;
}
/* otherwise they are off */
else {
- if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
PL_hints &= ~HINT_STRICT_REFS;
- if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
PL_hints &= ~HINT_STRICT_SUBS;
- if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
PL_hints &= ~HINT_STRICT_VARS;
}
}
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv))))));
+ newGVOP(OP_GV, 0, gv)))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
- if (type != OP_GOTO || label->op_type == OP_CONST) {
+ if (type != OP_GOTO) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
+ const_label:
o = newPVOP(type,
label->op_type == OP_CONST
? SvUTF8(((SVOP*)label)->op_sv)
if (label->op_type == OP_ENTERSUB
&& !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
+ else if (label->op_type == OP_CONST) {
+ SV * const sv = ((SVOP *)label)->op_sv;
+ STRLEN l;
+ const char *s = SvPV_const(sv,l);
+ if (l == strlen(s)) goto const_label;
+ }
o = newUNOP(type, OPf_STACKED, label);
}
PL_hints |= HINT_BLOCK_SCOPE;
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
PERL_ARGS_ASSERT_NEWXS;
- return newXS_flags(name, subaddr, filename, NULL, 0);
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
}
#ifdef PERL_MAD
MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
-
- if (!(o->op_private & OPpEVAL_BYTES)
+ }
+ if (!(o->op_private & OPpEVAL_BYTES)
&& FEATURE_UNIEVAL_IS_ENABLED)
o->op_private |= OPpEVAL_UNICODE;
- }
return o;
}
scalar(kid);
break;
case OA_SCALARREF:
+ if (type == OP_UNDEF && numargs == 1 && !(oa >> 4)
+ && kid->op_type == OP_LIST)
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
op_lvalue(scalar(kid), type);
break;
}
else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- }
-
-#if !defined(PERL_EXTERNAL_GLOB)
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs("File::Glob"), NULL, NULL, NULL);
- LEAVE;
+ GV * const * const gvp =
+ (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
+ gv = gvp ? *gvp : NULL;
}
-#endif /* !PERL_EXTERNAL_GLOB */
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
op_append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
- o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
else o->op_flags &= ~OPf_SPECIAL;
+#if !defined(PERL_EXTERNAL_GLOB)
+ if (!PL_globhook) {
+ ENTER;
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs("File::Glob"), NULL, NULL, NULL);
+ LEAVE;
+ }
+#endif /* !PERL_EXTERNAL_GLOB */
gv = newGVgen("main");
gv_IOadd(gv);
#ifndef PERL_EXTERNAL_GLOB
#ifndef PERL_MAD
op_free(o);
#endif
- newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, kid,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0,
- gv))))));
+ gv)))));
op_getmad(o,newop,'O');
return newop;
}
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
+ callmg->mg_flags |= MGf_COPY;
}
}
firstcop->cop_line = secondcop->cop_line;
#ifdef USE_ITHREADS
firstcop->cop_stashpv = secondcop->cop_stashpv;
+ firstcop->cop_stashlen = secondcop->cop_stashlen;
firstcop->cop_file = secondcop->cop_file;
#else
firstcop->cop_stash = secondcop->cop_stash;
This function assigns the prototype of the named core function to C<sv>, or
to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
NULL if the core function has no prototype. C<code> is a code as returned
-by C<keyword()>. It must be negative and unequal to -KEY_CORE.
+by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
=cut
*/
PERL_ARGS_ASSERT_CORE_PROTOTYPE;
- assert (code < 0 && code != -KEY_CORE);
+ assert (code && code != -KEY_CORE);
if (!sv) sv = sv_newmortal();
#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
- switch (-code) {
+ switch (code < 0 ? -code : code) {
case KEY_and : case KEY_chop: case KEY_chomp:
- case KEY_cmp : case KEY_exec: case KEY_eq :
- case KEY_ge : case KEY_gt : case KEY_le :
- case KEY_lt : case KEY_ne : case KEY_or :
- case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
+ case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
+ case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
+ case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
+ case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
+ case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
+ case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
+ case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
+ case KEY_x : case KEY_xor :
if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+ case KEY_glob: retsetpvs("_;", OP_GLOB);
case KEY_keys: retsetpvs("+", OP_KEYS);
case KEY_values: retsetpvs("+", OP_VALUES);
case KEY_each: retsetpvs("+", OP_EACH);
case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
case KEY_pop: retsetpvs(";+", OP_POP);
case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
case KEY_splice:
retsetpvs("+;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
}
i++;
}
- assert(0); return NULL; /* Should not happen... */
+ return NULL;
found:
defgv = PL_opargs[i] & OA_DEFGV;
oa = PL_opargs[i] >> OASHIFT;
str[n++] = '$';
str[n++] = '@';
str[n++] = '%';
- if (i == OP_LOCK) str[n++] = '&';
+ if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
str[n++] = '*';
str[n++] = ']';
}
}
return o;
default:
- o = convert(opnum,0,argop);
+ o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
if (is_handle_constructor(o, 2))
argop->op_private |= OPpCOREARGS_DEREF2;
if (scalar_mod_type(NULL, opnum))
https://perl5.git.perl.org / perl5.git / blobdiff