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)); */
363 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
364 version = Perl_newSVpvf(aTHX_ "v%s",vs);
367 PUSHs(new_version(version));
373 XS(XS_version_stringify)
377 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
382 if (sv_derived_from(ST(0), "version")) {
383 SV *tmp = SvRV(ST(0));
387 Perl_croak(aTHX_ "lobj is not of type version");
390 PUSHs(vstringify(lobj));
398 XS(XS_version_numify)
402 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
407 if (sv_derived_from(ST(0), "version")) {
408 SV *tmp = SvRV(ST(0));
412 Perl_croak(aTHX_ "lobj is not of type version");
415 PUSHs(vnumify(lobj));
427 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
432 if (sv_derived_from(ST(0), "version")) {
433 SV *tmp = SvRV(ST(0));
437 Perl_croak(aTHX_ "lobj is not of type version");
443 IV swap = (IV)SvIV(ST(2));
445 if ( ! sv_derived_from(robj, "version") )
447 robj = new_version(robj);
453 rs = newSViv(vcmp(rvs,lobj));
457 rs = newSViv(vcmp(lobj,rvs));
468 XS(XS_version_boolean)
472 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
477 if (sv_derived_from(ST(0), "version")) {
478 SV *tmp = SvRV(ST(0));
482 Perl_croak(aTHX_ "lobj is not of type version");
486 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
499 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
503 if (sv_derived_from(ST(0), "version")) {
504 SV *tmp = SvRV(ST(0));
508 Perl_croak(aTHX_ "lobj is not of type version");
511 Perl_croak(aTHX_ "operation not supported with version object");
522 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
527 char *s = SvPV(sv,len);
528 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
541 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
554 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
559 RETVAL = sv_utf8_decode(sv);
560 ST(0) = boolSV(RETVAL);
570 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
576 RETVAL = sv_utf8_upgrade(sv);
577 XSprePUSH; PUSHi((IV)RETVAL);
582 XS(XS_utf8_downgrade)
585 if (items < 1 || items > 2)
586 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
595 failok = (int)SvIV(ST(1));
598 RETVAL = sv_utf8_downgrade(sv, failok);
599 ST(0) = boolSV(RETVAL);
605 XS(XS_utf8_native_to_unicode)
611 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
613 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
617 XS(XS_utf8_unicode_to_native)
623 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
625 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
629 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
632 SV *sv = SvRV(ST(0));
639 else if (items == 2) {
645 /* I hope you really know what you are doing. */
650 XSRETURN_UNDEF; /* Can't happen. */
653 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
656 SV *sv = SvRV(ST(0));
658 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
659 else if (items == 2) {
660 /* I hope you really know what you are doing. */
661 SvREFCNT(sv) = SvIV(ST(1));
662 XSRETURN_IV(SvREFCNT(sv));
664 XSRETURN_UNDEF; /* Can't happen. */
667 /* Maybe this should return the number of placeholders found in scalar context,
668 and a list of them in list context. */
669 XS(XS_Internals_hv_clear_placehold)
672 HV *hv = (HV *) SvRV(ST(0));
674 /* I don't care how many parameters were passed in, but I want to avoid
675 the unused variable warning. */
677 items = (I32)HvPLACEHOLDERS(hv);
681 I32 riter = HvRITER(hv);
682 HE *eiter = HvEITER(hv);
684 /* This may look suboptimal with the items *after* the iternext, but
685 it's quite deliberate. We only get here with items==0 if we've
686 just deleted the last placeholder in the hash. If we've just done
687 that then it means that the hash is in lazy delete mode, and the
688 HE is now only referenced in our iterator. If we just quit the loop
689 and discarded our iterator then the HE leaks. So we do the && the
690 other way to ensure iternext is called just one more time, which
691 has the side effect of triggering the lazy delete. */
692 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
694 SV *val = hv_iterval(hv, entry);
696 if (val == &PL_sv_undef) {
698 /* It seems that I have to go back in the front of the hash
699 API to delete a hash, even though I have a HE structure
700 pointing to the very entry I want to delete, and could hold
701 onto the previous HE that points to it. And it's easier to
702 go in with SVs as I can then specify the precomputed hash,
703 and don't have fun and games with utf8 keys. */
704 SV *key = hv_iterkeysv(entry);
706 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));