/* universal.c
*
* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- * 2005, by Larry Wall and others
+ * 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
int len, int level)
{
+ dVAR;
AV* av;
GV* gv;
GV** gvp;
- HV* hv = Nullhv;
- SV* subgen = Nullsv;
+ HV* hv = NULL;
+ SV* subgen = NULL;
const char *hvname;
/* A stash/class can go by many names (ie. User == main::User), so
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
hvname);
- gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
+ gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
&& (hv = GvHV(gv)))
}
}
- gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
if (!hv || !subgen) {
- gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
+ gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
gv = *gvp;
bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
{
- const char *type = Nullch;
- HV *stash = Nullhv;
- HV *name_stash;
+ dVAR;
+ HV *stash;
SvGETMAGIC(sv);
if (SvROK(sv)) {
+ const char *type;
sv = SvRV(sv);
type = sv_reftype(sv,0);
- if (SvOBJECT(sv))
- stash = SvSTASH(sv);
+ if (type && strEQ(type,name))
+ return TRUE;
+ stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
}
else {
stash = gv_stashsv(sv, FALSE);
}
- name_stash = gv_stashpv(name, FALSE);
+ if (stash) {
+ HV * const name_stash = gv_stashpv(name, FALSE);
+ return isa_lookup(stash, name, name_stash, strlen(name), 0) == &PL_sv_yes;
+ }
+ else
+ return FALSE;
- return (type && strEQ(type,name)) ||
- (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
- == &PL_sv_yes)
- ? TRUE
- : FALSE ;
}
#include "XSUB.h"
XS(XS_Internals_hash_seed);
XS(XS_Internals_rehash_seed);
XS(XS_Internals_HvREHASH);
+XS(XS_Internals_inc_sub_generation);
void
Perl_boot_core_UNIVERSAL(pTHX)
{
+ dVAR;
const char file[] = __FILE__;
newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
+ newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation,
+ file, "");
}
XS(XS_UNIVERSAL_isa)
{
+ dVAR;
dXSARGS;
if (items != 2)
XS(XS_UNIVERSAL_can)
{
+ dVAR;
dXSARGS;
SV *sv;
const char *name;
XS(XS_UNIVERSAL_VERSION)
{
+ dVAR;
dXSARGS;
HV *pkg;
GV **gvp;
pkg = gv_stashsv(ST(0), FALSE);
}
- gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
+ gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : Null(GV**);
if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
SV * const nsv = sv_newmortal();
sv = nsv;
if ( !sv_derived_from(sv, "version"))
upg_version(sv);
- undef = Nullch;
+ undef = NULL;
}
else {
sv = (SV*)&PL_sv_undef;
XS(XS_version_new)
{
+ dVAR;
dXSARGS;
if (items > 3)
Perl_croak(aTHX_ "Usage: version::new(class, version)");
XS(XS_version_stringify)
{
+ dVAR;
dXSARGS;
if (items < 1)
Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
XS(XS_version_numify)
{
+ dVAR;
dXSARGS;
if (items < 1)
Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
XS(XS_version_normal)
{
+ dVAR;
dXSARGS;
if (items < 1)
Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
XS(XS_version_vcmp)
{
+ dVAR;
dXSARGS;
if (items < 1)
Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
XS(XS_version_boolean)
{
- dXSARGS;
- if (items < 1)
- Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
- SP -= items;
+ dVAR;
+ dXSARGS;
+ if (items < 1)
+ Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
+ SP -= items;
if (sv_derived_from(ST(0), "version")) {
SV * const lobj = SvRV(ST(0));
- SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
+ SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
PUSHs(sv_2mortal(rs));
PUTBACK;
return;
XS(XS_version_noop)
{
+ dVAR;
dXSARGS;
if (items < 1)
Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
XS(XS_version_is_alpha)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
XS(XS_version_qv)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: version::qv(ver)");
XS(XS_utf8_is_utf8)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
XS(XS_utf8_valid)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
XS(XS_utf8_encode)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
XS(XS_utf8_decode)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
XS(XS_utf8_upgrade)
{
+ dVAR;
dXSARGS;
if (items != 1)
Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
XS(XS_utf8_downgrade)
{
+ dVAR;
dXSARGS;
if (items < 1 || items > 2)
Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
XS(XS_utf8_native_to_unicode)
{
+ dVAR;
dXSARGS;
const UV uv = SvUV(ST(0));
XS(XS_utf8_unicode_to_native)
{
+ dVAR;
dXSARGS;
const UV uv = SvUV(ST(0));
XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
{
+ dVAR;
dXSARGS;
SV * const sv = SvRV(ST(0));
XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
{
+ dVAR;
dXSARGS;
SV * const sv = SvRV(ST(0));
XS(XS_Internals_hv_clear_placehold)
{
+ dVAR;
dXSARGS;
if (items != 1)
XS(XS_PerlIO_get_layers)
{
+ dVAR;
dXSARGS;
if (items < 1 || items % 2 == 0)
Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
if (!isGV(sv)) {
if (SvROK(sv) && isGV(SvRV(sv)))
gv = (GV*)SvRV(sv);
- else
- gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
+ else if (SvPOKp(sv))
+ gv = gv_fetchsv(sv, 0, SVt_PVIO);
}
if (gv && (io = GvIO(gv))) {
const IV flags = SvIVX(*flgsvp);
if (flags & PERLIO_F_UTF8) {
- XPUSHs(newSVpvn("utf8", 4));
+ XPUSHs(newSVpvs("utf8"));
nitem++;
}
}
XS(XS_Internals_hash_seed)
{
+ dVAR;
/* Using dXSARGS would also have dITEM and dSP,
* which define 2 unused local variables. */
dAXMARK;
XS(XS_Internals_rehash_seed)
{
+ dVAR;
/* Using dXSARGS would also have dITEM and dSP,
* which define 2 unused local variables. */
dAXMARK;
XS(XS_Internals_HvREHASH) /* Subject to change */
{
+ dVAR;
dXSARGS;
if (SvROK(ST(0))) {
const HV * const hv = (HV *) SvRV(ST(0));
Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
}
+XS(XS_Internals_inc_sub_generation)
+{
+ dVAR;
+ /* Using dXSARGS would also have dITEM and dSP,
+ * which define 2 unused local variables. */
+ dAXMARK;
+ PERL_UNUSED_ARG(cv);
+ PERL_UNUSED_VAR(mark);
+ ++PL_sub_generation;
+ XSRETURN_EMPTY;
+}
+
/*
* Local variables:
* c-indentation-style: bsd