3 * Copyright (c) 1997-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "The roots of those mountains must be roots indeed; there must be
12 * great secrets buried there which have not been discovered since the
13 * beginning." --Gandalf, relating Gollum's story
17 #define PERL_IN_UNIVERSAL_C
21 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
22 * The main guts of traverse_isa was actually copied from gv_fetchmeth
26 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
35 /* A stash/class can go by many names (ie. User == main::User), so
36 we compare the stash itself just in case */
37 if (name_stash && (stash == name_stash))
40 if (strEQ(HvNAME(stash), name))
44 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
47 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
49 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
52 if (SvIV(subgen) == (IV)PL_sub_generation) {
54 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
55 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
56 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
57 name, HvNAME(stash)) );
62 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
65 sv_setiv(subgen, PL_sub_generation);
69 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
71 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
73 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
77 if (SvTYPE(gv) != SVt_PVGV)
78 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
83 subgen = newSViv(PL_sub_generation);
88 SV** svp = AvARRAY(av);
89 /* NOTE: No support for tied ISA */
90 I32 items = AvFILLp(av) + 1;
93 HV* basestash = gv_stashsv(sv, FALSE);
95 if (ckWARN(WARN_MISC))
96 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
97 "Can't locate package %s for @%s::ISA",
98 SvPVX(sv), HvNAME(stash));
101 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
103 (void)hv_store(hv,name,len,&PL_sv_yes,0);
107 (void)hv_store(hv,name,len,&PL_sv_no,0);
111 return boolSV(strEQ(name, "UNIVERSAL"));
115 =head1 SV Manipulation Functions
117 =for apidoc sv_derived_from
119 Returns a boolean indicating whether the SV is derived from the specified
120 class. This is the function that implements C<UNIVERSAL::isa>. It works
121 for class names as well as for objects.
127 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
141 type = sv_reftype(sv,0);
146 stash = gv_stashsv(sv, FALSE);
149 name_stash = gv_stashpv(name, FALSE);
151 return (type && strEQ(type,name)) ||
152 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
160 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
161 void XS_UNIVERSAL_can(pTHX_ CV *cv);
162 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
164 XS(XS_version_stringify);
165 XS(XS_version_numify);
167 XS(XS_version_boolean);
173 XS(XS_utf8_downgrade);
174 XS(XS_utf8_unicode_to_native);
175 XS(XS_utf8_native_to_unicode);
176 XS(XS_Internals_SvREADONLY);
177 XS(XS_Internals_SvREFCNT);
178 XS(XS_Internals_hv_clear_placehold);
181 Perl_boot_core_UNIVERSAL(pTHX)
183 char *file = __FILE__;
185 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
186 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
187 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
189 /* register the overloading (type 'A') magic */
190 PL_amagic_generation++;
191 /* Make it findable via fetchmethod */
192 newXS("version::()", XS_version_noop, file);
193 newXS("version::new", XS_version_new, file);
194 newXS("version::(\"\"", XS_version_stringify, file);
195 newXS("version::stringify", XS_version_stringify, file);
196 newXS("version::(0+", XS_version_numify, file);
197 newXS("version::numify", XS_version_numify, file);
198 newXS("version::(cmp", XS_version_vcmp, file);
199 newXS("version::(<=>", XS_version_vcmp, file);
200 newXS("version::vcmp", XS_version_vcmp, file);
201 newXS("version::(bool", XS_version_boolean, file);
202 newXS("version::boolean", XS_version_boolean, file);
203 newXS("version::(nomethod", XS_version_noop, file);
204 newXS("version::noop", XS_version_noop, file);
206 newXS("utf8::valid", XS_utf8_valid, file);
207 newXS("utf8::encode", XS_utf8_encode, file);
208 newXS("utf8::decode", XS_utf8_decode, file);
209 newXS("utf8::upgrade", XS_utf8_upgrade, file);
210 newXS("utf8::downgrade", XS_utf8_downgrade, file);
211 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
212 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
213 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
214 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
215 newXSproto("Internals::hv_clear_placeholders",
216 XS_Internals_hv_clear_placehold, file, "\\%");
228 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
235 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
238 name = (char *)SvPV(ST(1),n_a);
240 ST(0) = boolSV(sv_derived_from(sv, name));
254 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
261 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
264 name = (char *)SvPV(ST(1),n_a);
273 pkg = gv_stashsv(sv, FALSE);
277 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
279 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
286 XS(XS_UNIVERSAL_VERSION)
296 sv = (SV*)SvRV(ST(0));
298 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
302 pkg = gv_stashsv(ST(0), FALSE);
305 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
307 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
308 SV *nsv = sv_newmortal();
314 sv = (SV*)&PL_sv_undef;
325 "%s does not define $%s::VERSION--version check failed",
326 HvNAME(pkg), HvNAME(pkg));
328 char *str = SvPVx(ST(0), len);
331 "%s defines neither package nor VERSION--version check failed", str);
334 if ( !sv_derived_from(sv, "version"))
335 sv = new_version(sv);
337 if ( !sv_derived_from(req, "version"))
338 req = new_version(req);
340 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
341 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
342 HvNAME(pkg), SvPV(req,PL_na), SvPV(sv,PL_na));
354 Perl_croak(aTHX_ "Usage: version::new(class, version)");
357 /* char * class = (char *)SvPV_nolen(ST(0)); */
358 SV * version = ST(1);
361 PUSHs(new_version(version));
369 XS(XS_version_stringify)
373 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
378 if (sv_derived_from(ST(0), "version")) {
379 SV *tmp = SvRV(ST(0));
383 Perl_croak(aTHX_ "lobj is not of type version");
386 PUSHs(vstringify(lobj));
394 XS(XS_version_numify)
398 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
403 if (sv_derived_from(ST(0), "version")) {
404 SV *tmp = SvRV(ST(0));
408 Perl_croak(aTHX_ "lobj is not of type version");
411 PUSHs(vnumify(lobj));
423 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
428 if (sv_derived_from(ST(0), "version")) {
429 SV *tmp = SvRV(ST(0));
433 Perl_croak(aTHX_ "lobj is not of type version");
439 IV swap = (IV)SvIV(ST(2));
441 if ( ! sv_derived_from(robj, "version") )
443 robj = new_version(robj);
449 rs = newSViv(vcmp(rvs,lobj));
453 rs = newSViv(vcmp(lobj,rvs));
464 XS(XS_version_boolean)
468 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
473 if (sv_derived_from(ST(0), "version")) {
474 SV *tmp = SvRV(ST(0));
478 Perl_croak(aTHX_ "lobj is not of type version");
482 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
495 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
499 if (sv_derived_from(ST(0), "version")) {
500 SV *tmp = SvRV(ST(0));
504 Perl_croak(aTHX_ "lobj is not of type version");
507 Perl_croak(aTHX_ "operation not supported with version object");
518 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
523 char *s = SvPV(sv,len);
524 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
537 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
550 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
555 RETVAL = sv_utf8_decode(sv);
556 ST(0) = boolSV(RETVAL);
566 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
572 RETVAL = sv_utf8_upgrade(sv);
573 XSprePUSH; PUSHi((IV)RETVAL);
578 XS(XS_utf8_downgrade)
581 if (items < 1 || items > 2)
582 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
591 failok = (int)SvIV(ST(1));
594 RETVAL = sv_utf8_downgrade(sv, failok);
595 ST(0) = boolSV(RETVAL);
601 XS(XS_utf8_native_to_unicode)
607 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
609 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
613 XS(XS_utf8_unicode_to_native)
619 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
621 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
625 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
628 SV *sv = SvRV(ST(0));
635 else if (items == 2) {
641 /* I hope you really know what you are doing. */
646 XSRETURN_UNDEF; /* Can't happen. */
649 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
652 SV *sv = SvRV(ST(0));
654 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
655 else if (items == 2) {
656 /* I hope you really know what you are doing. */
657 SvREFCNT(sv) = SvIV(ST(1));
658 XSRETURN_IV(SvREFCNT(sv));
660 XSRETURN_UNDEF; /* Can't happen. */
663 /* Maybe this should return the number of placeholders found in scalar context,
664 and a list of them in list context. */
665 XS(XS_Internals_hv_clear_placehold)
668 HV *hv = (HV *) SvRV(ST(0));
670 /* I don't care how many parameters were passed in, but I want to avoid
671 the unused variable warning. */
673 items = (I32)HvPLACEHOLDERS(hv);
677 I32 riter = HvRITER(hv);
678 HE *eiter = HvEITER(hv);
680 /* This may look suboptimal with the items *after* the iternext, but
681 it's quite deliberate. We only get here with items==0 if we've
682 just deleted the last placeholder in the hash. If we've just done
683 that then it means that the hash is in lazy delete mode, and the
684 HE is now only referenced in our iterator. If we just quit the loop
685 and discarded our iterator then the HE leaks. So we do the && the
686 other way to ensure iternext is called just one more time, which
687 has the side effect of triggering the lazy delete. */
688 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
690 SV *val = hv_iterval(hv, entry);
692 if (val == &PL_sv_undef) {
694 /* It seems that I have to go back in the front of the hash
695 API to delete a hash, even though I have a HE structure
696 pointing to the very entry I want to delete, and could hold
697 onto the previous HE that points to it. And it's easier to
698 go in with SVs as I can then specify the precomputed hash,
699 and don't have fun and games with utf8 keys. */
700 SV *key = hv_iterkeysv(entry);
702 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));