+/* universal.c
+ *
+ * Copyright (c) 1997-2002, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
#include "EXTERN.h"
#define PERL_IN_UNIVERSAL_C
#include "perl.h"
*/
STATIC SV *
-S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
+S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
+ int len, int level)
{
AV* av;
GV* gv;
HV* hv = Nullhv;
SV* subgen = Nullsv;
- if (!stash)
- return &PL_sv_undef;
+ /* A stash/class can go by many names (ie. User == main::User), so
+ we compare the stash itself just in case */
+ if (name_stash && (stash == name_stash))
+ return &PL_sv_yes;
if (strEQ(HvNAME(stash), name))
return &PL_sv_yes;
SvPVX(sv), HvNAME(stash));
continue;
}
- if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+ if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
+ len, level + 1)) {
(void)hv_store(hv,name,len,&PL_sv_yes,0);
return &PL_sv_yes;
}
}
/*
+=head1 SV Manipulation Functions
+
=for apidoc sv_derived_from
Returns a boolean indicating whether the SV is derived from the specified
{
char *type;
HV *stash;
+ HV *name_stash;
stash = Nullhv;
type = Nullch;
stash = gv_stashsv(sv, FALSE);
}
+ name_stash = gv_stashpv(name, FALSE);
+
return (type && strEQ(type,name)) ||
- (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
+ (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
+ == &PL_sv_yes)
? TRUE
: FALSE ;
}
#include "XSUB.h"
-void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
-void XS_UNIVERSAL_can(pTHXo_ CV *cv);
-void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv);
+void XS_UNIVERSAL_isa(pTHX_ CV *cv);
+void XS_UNIVERSAL_can(pTHX_ CV *cv);
+void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
XS(XS_utf8_valid);
XS(XS_utf8_encode);
XS(XS_utf8_decode);
XS(XS_utf8_downgrade);
XS(XS_utf8_unicode_to_native);
XS(XS_utf8_native_to_unicode);
+XS(XS_access_readonly);
void
Perl_boot_core_UNIVERSAL(pTHX)
newXS("utf8::downgrade", XS_utf8_downgrade, file);
newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
+ newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
}
if (SvNV(req) > SvNV(sv))
Perl_croak(aTHX_ "%s version %s required--this is only version %s",
- HvNAME(pkg), SvPV(req,len), SvPV(sv,len));
+ HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
}
finish:
{
dXSARGS;
UV uv = SvUV(ST(0));
+
+ if (items > 1)
+ Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
+
ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
XSRETURN(1);
}
{
dXSARGS;
UV uv = SvUV(ST(0));
+
+ if (items > 1)
+ Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
+
ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
XSRETURN(1);
}
+XS(XS_access_readonly)
+{
+ dXSARGS;
+ SV *sv = SvRV(ST(0));
+ IV old = SvREADONLY(sv);
+ if (items == 2) {
+ if (SvTRUE(ST(1))) {
+ SvREADONLY_on(sv);
+ }
+ else {
+ SvREADONLY_off(sv);
+ }
+ }
+ if (old)
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+}