{
HV *pmstash = PmopSTASH(cPMOPo);
if (pmstash && SvREFCNT(pmstash)) {
- PMOP *pmop = HvPMROOT(pmstash);
- PMOP *lastpmop = NULL;
- while (pmop) {
- if (cPMOPo == pmop) {
- if (lastpmop)
- lastpmop->op_pmnext = pmop->op_pmnext;
- else
- HvPMROOT(pmstash) = pmop->op_pmnext;
- break;
+ MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP *pmop = (PMOP*) mg->mg_obj;
+ PMOP *lastpmop = NULL;
+ while (pmop) {
+ if (cPMOPo == pmop) {
+ if (lastpmop)
+ lastpmop->op_pmnext = pmop->op_pmnext;
+ else
+ mg->mg_obj = (SV*) pmop->op_pmnext;
+ break;
+ }
+ lastpmop = pmop;
+ pmop = pmop->op_pmnext;
}
- lastpmop = pmop;
- pmop = pmop->op_pmnext;
}
}
PmopSTASH_free(cPMOPo);
built upon these three nroff macros being used in
void context. The pink camel has the details in
the script wrapman near page 319. */
- if (strnEQ(SvPVX(sv), "di", 2) ||
- strnEQ(SvPVX(sv), "ds", 2) ||
- strnEQ(SvPVX(sv), "ig", 2))
+ if (strnEQ(SvPVX_const(sv), "di", 2) ||
+ strnEQ(SvPVX_const(sv), "ds", 2) ||
+ strnEQ(SvPVX_const(sv), "ig", 2))
useless = 0;
}
}
}
STATIC bool
-S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
+S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
{
switch (o->op_type) {
case OP_PIPE_OP:
case OP_SOCKPAIR:
- if (argnum == 2)
+ if (numargs == 2)
return TRUE;
/* FALL THROUGH */
case OP_SYSOPEN:
case OP_SOCKET:
case OP_OPEN_DIR:
case OP_ACCEPT:
- if (argnum == 1)
+ if (numargs == 1)
return TRUE;
/* FALL THROUGH */
default:
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
SAVEINT(PL_expect);
- if (stash)
- stashsv = newSVpv(HvNAME(stash), 0);
- else
- stashsv = &PL_sv_no;
+ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
if (for_my) {
- SV **svp;
/* Don't force the C<use> if we don't need it. */
- svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
+ SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
sizeof(ATTRSMODULE_PM)-1, 0);
if (svp && *svp != &PL_sv_undef)
; /* already in %INC */
pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
/* Build up the real arg-list. */
- if (stash)
- stashsv = newSVpv(HvNAME(stash), 0);
- else
- stashsv = &PL_sv_no;
+ stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
+
arg = newOP(OP_PADSV, 0);
arg->op_targ = target->op_targ;
arg = prepend_elem(OP_LIST,
/* Fake up a method call to import */
meth = newSVpvn("import", 6);
- (void)SvUPGRADE(meth, SVt_PVIV);
+ SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
{
U32 hash;
- PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
SvUV_set(meth, hash);
}
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
return fold_constants((OP *)binop);
}
-static int uvcompare(const void *a, const void *b) __attribute__((nonnull,pure));
-static int
-uvcompare(const void *a, const void *b)
+static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
+static int uvcompare(const void *a, const void *b)
{
if (*((const UV *)a) < (*(const UV *)b))
return -1;
SV *rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
- U8 *t = (U8*)SvPV(tstr, tlen);
- U8 *r = (U8*)SvPV(rstr, rlen);
+ const U8 *t = (U8*)SvPV_const(tstr, tlen);
+ const U8 *r = (U8*)SvPV_const(rstr, rlen);
register I32 i;
register I32 j;
I32 del;
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
SV* listsv = newSVpvn("# comment\n",10);
SV* transv = 0;
- U8* tend = t + tlen;
- U8* rend = r + rlen;
+ const U8* tend = t + tlen;
+ const U8* rend = r + rlen;
STRLEN ulen;
UV tfirst = 1;
UV tlast = 0;
if (!from_utf) {
STRLEN len = tlen;
- tsave = t = bytes_to_utf8(t, &len);
+ t = tsave = bytes_to_utf8(t, &len);
tend = t + len;
}
if (!to_utf && rlen) {
STRLEN len = rlen;
- rsave = r = bytes_to_utf8(r, &len);
+ r = rsave = bytes_to_utf8(r, &len);
rend = r + len;
}
/* link into pm list */
if (type != OP_TRANS && PL_curstash) {
- pmop->op_pmnext = HvPMROOT(PL_curstash);
- HvPMROOT(PL_curstash) = pmop;
+ MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
+
+ if (!mg) {
+ mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
+ }
+ pmop->op_pmnext = (PMOP*)mg->mg_obj;
+ mg->mg_obj = (SV*)pmop;
PmopSTASH_set(pmop,PL_curstash);
}
if (expr->op_type == OP_CONST) {
STRLEN plen;
SV *pat = ((SVOP*)expr)->op_sv;
- char *p = SvPV(pat, plen);
+ const char *p = SvPV_const(pat, plen);
if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
+ U32 was_readonly = SvREADONLY(pat);
+
+ if (was_readonly) {
+ if (SvFAKE(pat)) {
+ sv_force_normal_flags(pat, 0);
+ assert(!SvREADONLY(pat));
+ was_readonly = 0;
+ } else {
+ SvREADONLY_off(pat);
+ }
+ }
+
sv_setpvn(pat, "\\s+", 3);
- p = SvPV(pat, plen);
+
+ SvFLAGS(pat) |= was_readonly;
+
+ p = SvPV_const(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
if (DO_UTF8(pat))
pm->op_pmdynflags |= PMdf_UTF8;
- PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
+ /* FIXME - can we make this function take const char * args? */
+ PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
save_hptr(&PL_curstash);
save_item(PL_curstname);
- name = SvPV(cSVOPo->op_sv, len);
+ name = SvPV_const(cSVOPo->op_sv, len);
PL_curstash = gv_stashpvn(name, len, TRUE);
sv_setpvn(PL_curstname, name, len);
op_free(o);
(void)SvIOK_on(meth);
{
U32 hash;
- PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
SvUV_set(meth, hash);
}
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
- (void)SvUPGRADE(meth, SVt_PVIV);
+ SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
{
U32 hash;
- PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
SvUV_set(meth, hash);
}
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
}
STATIC I32
-S_list_assignment(pTHX_ register const OP *o)
+S_is_list_assignment(pTHX_ register const OP *o)
{
if (!o)
return TRUE;
o = cUNOPo->op_first;
if (o->op_type == OP_COND_EXPR) {
- const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
- const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
+ const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
+ const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
if (t && f)
return TRUE;
}
}
- if (list_assignment(left)) {
+ if (is_list_assignment(left)) {
OP *curop;
PL_modcount = 0;
o = newOP(type, OPf_SPECIAL);
else {
o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
- ? SvPVx(((SVOP*)label)->op_sv, n_a)
+ ? SvPVx_const(((SVOP*)label)->op_sv, n_a)
: ""));
}
op_free(label);
op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
+ CvSTART(cv) = Nullop;
LEAVE;
}
SvPOK_off((SV*)cv); /* forget prototype */
void
Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+ if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
SV* msg = sv_newmortal();
SV* name = Nullsv;
STRLEN n_a;
const char *aname;
GV *gv;
- char *ps;
+ const char *ps;
STRLEN ps_len;
register CV *cv=0;
SV *const_sv;
- const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+ const char * const name = o ? SvPVx_const(cSVOPo->op_sv, n_a) : Nullch;
if (proto) {
assert(proto->op_type == OP_CONST);
- ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
+ ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
}
else
ps = Nullch;
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- aname = SvPVX(sv);
+ aname = SvPVX_const(sv);
}
else
aname = Nullch;
CopFILE(PL_curcop),
(long)PL_subline, (long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, Nullch);
- hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
+ if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
&& (pcv = GvCV(db_postponed)))
{
dSP;
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
+ /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
- && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
+ && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
const line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
/* STUB */
(void)o;
-#ifndef HASATTRIBUTE
- /* No __attribute__, so the compiler doesn't know that croak never returns
- */
- return 0;
-#endif
+ NORETURN_FUNCTION_END;
}
OP *
|| o->op_type == OP_BIT_AND
|| o->op_type == OP_BIT_XOR))
{
- const OP * left = cBINOPo->op_first;
- const OP * right = left->op_sibling;
+ const OP * const left = cBINOPo->op_first;
+ const OP * const right = left->op_sibling;
if ((OP_IS_NUMCOMPARE(left->op_type) &&
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
return o;
}
-#if 0
-OP *
-Perl_ck_gvconst(pTHX_ register OP *o)
-{
- o = fold_constants(o);
- if (o->op_type == OP_CONST)
- o->op_type = OP_GV;
- return o;
-}
-#endif
-
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
if (kid->op_type == OP_CONST) {
int iscv;
GV *gv;
- SV *kidsv = kid->op_sv;
+ SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
SV *rsv = SvRV(kidsv);
- int svtype = SvTYPE(rsv);
+ const int svtype = SvTYPE(rsv);
const char *badtype = Nullch;
switch (o->op_type) {
SV *namesv;
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
- (void)SvUPGRADE(namesv, SVt_PV);
+ SvUPGRADE(namesv, SVt_PV);
if (*name != '$')
sv_setpvn(namesv, "$", 1);
sv_catpvn(namesv, name, len);
OP *kid = cUNOPo->op_first;
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
- if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
+ if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
+ sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
}
else {
kSVOP->op_sv = Nullsv;
OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
OP *last = cLISTOPx(o)->op_last; /* The bareword. */
OP *oa;
- char *mode;
+ const char *mode;
if ((last->op_type == OP_CONST) && /* The bareword. */
(last->op_private & OPpCONST_BARE) &&
(oa = first->op_sibling) && /* The fh. */
(oa = oa->op_sibling) && /* The mode. */
SvPOK(((SVOP*)oa)->op_sv) &&
- (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
+ (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
mode[0] == '>' && mode[1] == '&' && /* A dup open. */
(last == oa->op_sibling)) /* The bareword. */
last->op_private &= ~OPpCONST_STRICT;
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ SV *sv = kid->op_sv;
+ U32 was_readonly = SvREADONLY(sv);
char *s;
- for (s = SvPVX(kid->op_sv); *s; s++) {
+
+ if (was_readonly) {
+ if (SvFAKE(sv)) {
+ sv_force_normal_flags(sv, 0);
+ assert(!SvREADONLY(sv));
+ was_readonly = 0;
+ } else {
+ SvREADONLY_off(sv);
+ }
+ }
+
+ for (s = SvPVX(sv); *s; s++) {
if (*s == ':' && s[1] == ':') {
*s = '/';
Move(s+2, s+1, strlen(s+2)+1, char);
- SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
+ SvCUR_set(sv, SvCUR(sv) - 1);
}
}
- if (SvREADONLY(kid->op_sv)) {
- SvREADONLY_off(kid->op_sv);
- sv_catpvn(kid->op_sv, ".pm", 3);
- SvREADONLY_on(kid->op_sv);
- }
- else
- sv_catpvn(kid->op_sv, ".pm", 3);
+ sv_catpvn(sv, ".pm", 3);
+ SvFLAGS(sv) |= was_readonly;
}
}
}
else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
GV *gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
/* XXX could check prototype here instead of just carping */
SV *sv = sv_newmortal();
gv_efullname3(sv, gv, Nullch);
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
}
break;
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
}
}
break;
if (items != 0) {
#if 0
Perl_croak(aTHX_ "usage: %s::%s()",
- HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
+ HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
#endif
}
EXTEND(sp, 1);
* indent-tabs-mode: t
* End:
*
- * vim: shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff