return off;
}
+/*
+=for apidoc alloccopstash
+
+Available only under threaded builds, this function allocates an entry in
+C<PL_stashpad> for the stash passed to it.
+
+=cut
+*/
+
+#ifdef USE_ITHREADS
+PADOFFSET
+Perl_alloccopstash(pTHX_ HV *hv)
+{
+ PADOFFSET off = 0, o = 1;
+ bool found_slot = FALSE;
+
+ PERL_ARGS_ASSERT_ALLOCCOPSTASH;
+
+ if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
+
+ for (; o < PL_stashpadmax; ++o) {
+ if (PL_stashpad[o] == hv) return PL_stashpadix = o;
+ if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
+ found_slot = TRUE, off = o;
+ }
+ if (!found_slot) {
+ Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
+ Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
+ off = PL_stashpadmax;
+ PL_stashpadmax += 10;
+ }
+
+ PL_stashpad[PL_stashpadix = off] = hv;
+ return off;
+}
+#endif
+
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
PERL_ARGS_ASSERT_COP_FREE;
CopFILE_free(cop);
- CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
switch (o->op_type) {
case OP_UNDEF:
- localize = 0;
PL_modcount++;
return o;
case OP_STUB:
if (type != OP_LEAVESUBLV)
goto nomod;
break; /* op_lvalue()ing was handled by ck_return() */
+
+ case OP_COREARGS:
+ return o;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
switch (type) {
case OP_POS:
case OP_SASSIGN:
- assert(o);
- if (o->op_type == OP_RV2GV)
+ if (o && o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
case OP_PREINC:
if (IN_LOCALE_COMPILETIME)
goto nope;
break;
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST) goto nope;
}
if (PL_parser && PL_parser->error_count)
}
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) );
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((const SV *)gv)
- && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
- {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
- }
cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
}
if (ps) {
if (stash) {
SAVEGENERICSV(PL_curstash);
- SAVECOPSTASH(PL_curcop);
PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
- CopSTASH_set(PL_curcop,stash);
}
/* file becomes the CvFILE. For an XS, it's usually static storage,
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
-#ifdef USE_ITHREADS
- if (stash)
- CopSTASH_free(PL_curcop);
-#endif
LEAVE;
return cv;
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
scalar(kid);
break;
case OA_SCALARREF:
+ if ((type == OP_UNDEF || type == OP_POS)
+ && 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);
+ GV * const * const gvp =
+ (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
+ gv = gvp ? *gvp : NULL;
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
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;
}
#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;
}
data. */
firstcop->cop_line = secondcop->cop_line;
#ifdef USE_ITHREADS
- firstcop->cop_stashpv = secondcop->cop_stashpv;
- firstcop->cop_stashlen = secondcop->cop_stashlen;
+ firstcop->cop_stashoff = secondcop->cop_stashoff;
firstcop->cop_file = secondcop->cop_file;
#else
firstcop->cop_stash = secondcop->cop_stash;
firstcop->cop_hints_hash = secondcop->cop_hints_hash;
#ifdef USE_ITHREADS
- secondcop->cop_stashpv = NULL;
+ secondcop->cop_stashoff = 0;
secondcop->cop_file = NULL;
#else
secondcop->cop_stash = NULL;
case OP_RUNCV:
if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
SV *sv;
- if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
+ if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
sv = newRV((SV *)PL_compcv);
sv_rvweaken(sv);
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++] = ']';
}
onearg:
if (is_handle_constructor(o, 1))
argop->op_private |= OPpCOREARGS_DEREF1;
+ if (scalar_mod_type(NULL, opnum))
+ argop->op_private |= OPpCOREARGS_SCALARMOD;
}
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))
- argop->op_private |= OPpCOREARGS_SCALARMOD;
if (opnum == OP_SUBSTR) {
o->op_private |= OPpMAYBE_LVSUB;
return o;
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff