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 %"SVf" for @%s::ISA",
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))
236 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
239 name = (char *)SvPV(ST(1),n_a);
241 ST(0) = boolSV(sv_derived_from(sv, name));
255 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
262 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
263 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
266 name = (char *)SvPV(ST(1),n_a);
275 pkg = gv_stashsv(sv, FALSE);
279 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
281 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
288 XS(XS_UNIVERSAL_VERSION)
298 sv = (SV*)SvRV(ST(0));
300 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
304 pkg = gv_stashsv(ST(0), FALSE);
307 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
309 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
310 SV *nsv = sv_newmortal();
316 sv = (SV*)&PL_sv_undef;
327 "%s does not define $%s::VERSION--version check failed",
328 HvNAME(pkg), HvNAME(pkg));
330 char *str = SvPVx(ST(0), len);
333 "%s defines neither package nor VERSION--version check failed", str);
336 if ( !sv_derived_from(sv, "version"))
337 sv = new_version(sv);
339 if ( !sv_derived_from(req, "version"))
340 req = new_version(req);
342 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
343 Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
344 HvNAME(pkg), req, sv);
356 Perl_croak(aTHX_ "Usage: version::new(class, version)");
359 /* char * class = (char *)SvPV_nolen(ST(0)); */
360 SV * version = ST(1);
363 PUSHs(new_version(version));
371 XS(XS_version_stringify)
375 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
380 if (sv_derived_from(ST(0), "version")) {
381 SV *tmp = SvRV(ST(0));
385 Perl_croak(aTHX_ "lobj is not of type version");
388 PUSHs(vstringify(lobj));
396 XS(XS_version_numify)
400 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
405 if (sv_derived_from(ST(0), "version")) {
406 SV *tmp = SvRV(ST(0));
410 Perl_croak(aTHX_ "lobj is not of type version");
413 PUSHs(vnumify(lobj));
425 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
430 if (sv_derived_from(ST(0), "version")) {
431 SV *tmp = SvRV(ST(0));
435 Perl_croak(aTHX_ "lobj is not of type version");
441 IV swap = (IV)SvIV(ST(2));
443 if ( ! sv_derived_from(robj, "version") )
445 robj = new_version(robj);
451 rs = newSViv(vcmp(rvs,lobj));
455 rs = newSViv(vcmp(lobj,rvs));
466 XS(XS_version_boolean)
470 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
475 if (sv_derived_from(ST(0), "version")) {
476 SV *tmp = SvRV(ST(0));
480 Perl_croak(aTHX_ "lobj is not of type version");
484 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
497 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
501 if (sv_derived_from(ST(0), "version")) {
502 SV *tmp = SvRV(ST(0));
506 Perl_croak(aTHX_ "lobj is not of type version");
509 Perl_croak(aTHX_ "operation not supported with version object");
520 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
525 char *s = SvPV(sv,len);
526 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
539 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
552 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
557 RETVAL = sv_utf8_decode(sv);
558 ST(0) = boolSV(RETVAL);
568 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
574 RETVAL = sv_utf8_upgrade(sv);
575 XSprePUSH; PUSHi((IV)RETVAL);
580 XS(XS_utf8_downgrade)
583 if (items < 1 || items > 2)
584 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
593 failok = (int)SvIV(ST(1));
596 RETVAL = sv_utf8_downgrade(sv, failok);
597 ST(0) = boolSV(RETVAL);
603 XS(XS_utf8_native_to_unicode)
609 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
611 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
615 XS(XS_utf8_unicode_to_native)
621 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
623 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
627 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
630 SV *sv = SvRV(ST(0));
637 else if (items == 2) {
643 /* I hope you really know what you are doing. */
648 XSRETURN_UNDEF; /* Can't happen. */
651 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
654 SV *sv = SvRV(ST(0));
656 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
657 else if (items == 2) {
658 /* I hope you really know what you are doing. */
659 SvREFCNT(sv) = SvIV(ST(1));
660 XSRETURN_IV(SvREFCNT(sv));
662 XSRETURN_UNDEF; /* Can't happen. */
665 /* Maybe this should return the number of placeholders found in scalar context,
666 and a list of them in list context. */
667 XS(XS_Internals_hv_clear_placehold)
670 HV *hv = (HV *) SvRV(ST(0));
672 /* I don't care how many parameters were passed in, but I want to avoid
673 the unused variable warning. */
675 items = (I32)HvPLACEHOLDERS(hv);
679 I32 riter = HvRITER(hv);
680 HE *eiter = HvEITER(hv);
682 /* This may look suboptimal with the items *after* the iternext, but
683 it's quite deliberate. We only get here with items==0 if we've
684 just deleted the last placeholder in the hash. If we've just done
685 that then it means that the hash is in lazy delete mode, and the
686 HE is now only referenced in our iterator. If we just quit the loop
687 and discarded our iterator then the HE leaks. So we do the && the
688 other way to ensure iternext is called just one more time, which
689 has the side effect of triggering the lazy delete. */
690 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
692 SV *val = hv_iterval(hv, entry);
694 if (val == &PL_sv_undef) {
696 /* It seems that I have to go back in the front of the hash
697 API to delete a hash, even though I have a HE structure
698 pointing to the very entry I want to delete, and could hold
699 onto the previous HE that points to it. And it's easier to
700 go in with SVs as I can then specify the precomputed hash,
701 and don't have fun and games with utf8 keys. */
702 SV *key = hv_iterkeysv(entry);
704 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));