STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ if (cop->cop_label) {
+#ifdef PERL_TRACK_MEMPOOL
+ Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+ /* Only the thread that allocated us can free us. */
+ if (header->interpreter == aTHX)
+#endif
+ {
+ Safefree(cop->cop_label);
+ cop->cop_label = NULL;
+ }
+ }
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
|| ltype == OP_PADHV) && ckWARN(WARN_MISC))
{
const char * const desc
- = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) ?
- (int)rtype : OP_MATCH];
- const char * const sample =
- (const char *)
- (((ltype == OP_RV2AV || ltype == OP_PADAV)
- ? "@array" : "%hash"));
+ = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+ ? (int)rtype : OP_MATCH];
+ const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ ? "@array" : "%hash");
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
dVAR;
register OP *curop;
OP *newop;
- volatile I32 type = o->op_type;
- volatile SV *sv = NULL;
+ VOL I32 type = o->op_type;
+ SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
OP *old_next;
pp_pushmark();
CALLRUNOPS(aTHX);
PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
pp_anonlist();
PL_tmps_floor = oldtmps_floor;
bits = 8;
Safefree(cPVOPo->op_pv);
+ cPVOPo->op_pv = NULL;
cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
SvREFCNT_dec(listsv);
SvREFCNT_dec(transv);
if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
/* FIXME - can we make this function take const char * args? */
- PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
+ PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
#ifdef PERL_MAD
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
+ || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
- (void)SvIOK_on(*svp);
- SvIV_set(*svp, PTR2IV(cop));
+ AV *av = CopFILEAVx(PL_curcop);
+ if (av) {
+ SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
+ SvIV_set(*svp, PTR2IV(cop));
+ }
}
}
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
- o = newPVOP(type, 0,
- savepv(label->op_type == OP_CONST
- ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
- : (const char *)""));
+ o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
+ ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
+ : ""));
}
#ifdef PERL_MAD
op_getmad(label,o,'L');
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
- CvFILE(cv) = 0;
+ CvFILE(cv) = NULL;
#endif
if (!CvISXSUB(cv) && CvROOT(cv)) {
aname = NULL;
gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
- : gv_fetchpv((const char *)
- (aname ? aname
- : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
+ : gv_fetchpv(aname ? aname
+ : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
gv_fetch_flags, SVt_PVCV);
if (!PL_madskills) {
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- (const char *)
- (CvCONST(cv)
- ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"), name);
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined", name);
CopLINE_set(PL_curcop, oldline);
}
#ifdef PERL_MAD
else
s = tname;
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
+ if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
av_store(PL_endav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
+ else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
+ /* It's never too late to run a unitcheck block */
+ if (!PL_unitcheckav)
+ PL_unitcheckav = newAV();
+ DEBUG_x( dump_sub(gv) );
+ av_unshift(PL_unitcheckav, 1);
+ av_store(PL_unitcheckav, 0, (SV*)cv);
+ GvCV(gv) = 0; /* cv has been hijacked */
+ }
else if (strEQ(s, "CHECK") && !PL_error_count) {
if (!PL_checkav)
PL_checkav = newAV();
cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
+ Safefree(file);
#ifdef USE_ITHREADS
if (stash)
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
dVAR;
- GV * const gv =
- gv_fetchpv((const char *)
- (name ? name :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
- GV_ADDMULTI, SVt_PVCV);
+ GV * const gv = gv_fetchpv(name ? name :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI, SVt_PVCV);
register CV *cv;
if (!subaddr)
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- (const char *)
- (CvCONST(cv)
- ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"),
- name);
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined"
+ ,name);
CopLINE_set(PL_curcop, oldline);
}
}
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
- Perl_croak(aTHX_ (const char*)"Bad symbol for form (GV is unique)");
+ Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
}
#endif
GvMULTI_on(gv);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- (const char *)
- (o
- ? "Format %"SVf" redefined"
- : "Format STDOUT redefined"), (void*)cSVOPo->op_sv);
+ o ? "Format %"SVf" redefined"
+ : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+ return convert(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+ return convert(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
if (op) {
SV *tmpstr = NULL;
const char * const a =
- (const char *)
- (kid->op_type == OP_AELEM ?
- "[]" : "{}");
+ kid->op_type == OP_AELEM ?
+ "[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op->op_type == OP_RV2HV)) &&
(firstop = ((UNOP*)op)->op_first) &&
}
OP *
-Perl_ck_say(pTHX_ OP *o)
-{
- o = ck_listiob(o);
- o->op_type = OP_PRINT;
- cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
- = newSVOP(OP_CONST, 0, newSVpvs("\n"));
- return o;
-}
-
-OP *
Perl_ck_smartmatch(pTHX_ OP *o)
{
dVAR;
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = (const char *)(re ? re->precomp : "STRING");
+ const char *pmstr = re ? re->precomp : "STRING";
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e = NULL;
+ const char *e = NULL;
bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
proto_end = proto + len;
}
if (CvASSERTION(cv)) {
- if (PL_hints & HINT_ASSERTING) {
+ U32 asserthints = 0;
+ HV *const hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
+ if (svp && *svp)
+ asserthints = SvUV(*svp);
+ }
+ if (asserthints & HINT_ASSERTING) {
if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
}
else {
delete_op = 1;
- if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
+ if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
"Impossible to activate assertion call");
}
optional = 1;
proto++;
continue;
+ case '_':
+ /* _ must be at the end */
+ if (proto[1] && proto[1] != ';')
+ goto oops;
case '$':
proto++;
arg++;
arg++;
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
bad_type(arg,
- (const char*)
- (arg == 1 ? "block or sub {}" : "sub {}"),
- gv_ename(namegv), o3);
+ arg == 1 ? "block or sub {}" : "sub {}",
+ gv_ename(namegv), o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
prev = o2;
o2 = o2->op_sibling;
} /* while */
+ if (o2 == cvop && proto && *proto == '_') {
+ /* generate an access to $_ */
+ o2 = newDEFSVOP();
+ o2->op_sibling = prev->op_sibling;
+ prev->op_sibling = o2; /* instead of cvop */
+ }
if (proto && !optional && proto_end > proto &&
- (*proto != '@' && *proto != '%' && *proto != ';'))
+ (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
https://perl5.git.perl.org / perl5.git / blobdiff