else {
stash = gv_stashsv(sv, 0);
if (!stash)
- stash = gv_stashpv("UNIVERSAL", 0);
+ stash = gv_stashpvs("UNIVERSAL", 0);
}
return stash ? isa_lookup(stash, name, len, flags) : FALSE;
SV *sv;
SV *rv;
HV *pkg = NULL;
+ GV *iogv;
if (items != 2)
croak_xs_usage(cv, "object-ref, method");
SvGETMAGIC(sv);
- if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
- ))
+ /* Reject undef and empty string. Note that the string form takes
+ precedence here over the numeric form, as (!1)->foo treats the
+ invocant as the empty string, though it is a dualvar. */
+ if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
XSRETURN_UNDEF;
rv = &PL_sv_undef;
sv = MUTABLE_SV(SvRV(sv));
if (SvOBJECT(sv))
pkg = SvSTASH(sv);
+ else if (isGV_with_GP(sv) && GvIO(sv))
+ pkg = SvSTASH(GvIO(sv));
}
+ else if (isGV_with_GP(sv) && GvIO(sv))
+ pkg = SvSTASH(GvIO(sv));
+ else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
+ pkg = SvSTASH(GvIO(iogv));
else {
pkg = gv_stashsv(sv, 0);
if (!pkg)
{
dVAR;
dXSARGS;
- if (items > 3)
+ if (items > 3 || items < 1)
croak_xs_usage(cv, "class, version");
SP -= items;
{
sv = SvRV(svz);
if (items == 1) {
- if (SvREADONLY(sv) && !SvIsCOW(sv))
+ if (SvREADONLY(sv))
XSRETURN_YES;
else
XSRETURN_NO;
}
else if (items == 2) {
if (SvTRUE(ST(1))) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) sv_force_normal(sv);
+#endif
SvREADONLY_on(sv);
+ if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
+ /* for constant.pm; nobody else should be calling this
+ on arrays anyway. */
+ SV **svp;
+ for (svp = AvARRAY(sv) + AvFILLp(sv)
+ ; svp >= AvARRAY(sv)
+ ; --svp)
+ if (*svp) SvPADTMP_on(*svp);
+ }
XSRETURN_YES;
}
else {
/* I hope you really know what you are doing. */
- if (!SvIsCOW(sv)) SvREADONLY_off(sv);
+ SvREADONLY_off(sv);
XSRETURN_NO;
}
}
XSRETURN_UNDEF; /* Can't happen. */
}
-
XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
{
dVAR;
dXSARGS;
SV * const svz = ST(0);
SV * sv;
+ U32 refcnt;
PERL_UNUSED_ARG(cv);
/* [perl #77776] - called as &foo() not foo() */
- if (!SvROK(svz))
+ if ((items != 1 && items != 2) || !SvROK(svz))
croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
sv = SvRV(svz);
- if (items == 1)
- XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
- else if (items == 2) {
/* I hope you really know what you are doing. */
- SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
- XSRETURN_UV(SvREFCNT(sv) - 1);
- }
- XSRETURN_UNDEF; /* Can't happen. */
+ /* idea is for SvREFCNT(sv) to be accessed only once */
+ refcnt = items == 2 ?
+ /* we free one ref on exit */
+ (SvREFCNT(sv) = SvUV(ST(1)) + 1)
+ : SvREFCNT(sv);
+ XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
+
}
XS(XS_Internals_hv_clear_placehold)
if (gv && (io = GvIO(gv))) {
AV* const av = PerlIO_get_layers(aTHX_ input ?
IoIFP(io) : IoOFP(io));
- I32 i;
- const I32 last = av_len(av);
- I32 nitem = 0;
+ SSize_t i;
+ const SSize_t last = av_len(av);
+ SSize_t nitem = 0;
for (i = last; i >= 0; i -= 3) {
SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
XSRETURN(0);
}
-XS(XS_Internals_hash_seed)
-{
- dVAR;
- /* Using dXSARGS would also have dITEM and dSP,
- * which define 2 unused local variables. */
- dAXMARK;
- PERL_UNUSED_ARG(cv);
- PERL_UNUSED_VAR(mark);
- XSRETURN_UV(PERL_HASH_SEED);
-}
-
-XS(XS_Internals_rehash_seed)
-{
- dVAR;
- /* Using dXSARGS would also have dITEM and dSP,
- * which define 2 unused local variables. */
- dAXMARK;
- PERL_UNUSED_ARG(cv);
- PERL_UNUSED_VAR(mark);
- XSRETURN_UV(PL_rehash_seed);
-}
-
-XS(XS_Internals_HvREHASH) /* Subject to change */
-{
- dVAR;
- dXSARGS;
- PERL_UNUSED_ARG(cv);
- if (SvROK(ST(0))) {
- const HV * const hv = (const HV *) SvRV(ST(0));
- if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
- if (HvREHASH(hv))
- XSRETURN_YES;
- else
- XSRETURN_NO;
- }
- }
- Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
-}
XS(XS_re_is_regexp)
{
U32 flags;
SV *ret;
AV *av;
- I32 length;
- I32 i;
+ SSize_t length;
+ SSize_t i;
SV **entry;
if (items > 1)
dXSARGS;
REGEXP *re;
+ EXTEND(SP, 2);
+ SP -= items;
if (items != 1)
croak_xs_usage(cv, "sv");
- SP -= items;
-
/*
Checks if a reference is a regex or not. If the parameter is
not a ref, or is not the result of a qr// then returns false
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
/* return the pattern and the modifiers */
- EXTEND(SP, 2);
PUSHs(pattern);
PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
XSRETURN(2);
pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
(RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
#endif
- XPUSHs(pattern);
+ PUSHs(pattern);
XSRETURN(1);
}
} else {
{"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
{"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
{"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
- {"Internals::hash_seed", XS_Internals_hash_seed, ""},
- {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
- {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
{"re::is_regexp", XS_re_is_regexp, "$"},
{"re::regname", XS_re_regname, ";$$"},
{"re::regnames", XS_re_regnames, ";$"},
https://perl5.git.perl.org / perl5.git / blobdiff