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 /* create the package stash for version objects */
190 HV *hv = get_hv("version::OVERLOAD",TRUE);
191 SV *sv = *hv_fetch(hv,"register",8,1);
194 /* Make it findable via fetchmethod */
195 newXS("version::new", XS_version_new, file);
196 newXS("version::(\"\"", XS_version_stringify, file);
197 newXS("version::stringify", XS_version_stringify, file);
198 newXS("version::(0+", XS_version_numify, file);
199 newXS("version::numify", XS_version_numify, file);
200 newXS("version::(cmp", XS_version_vcmp, file);
201 newXS("version::(<=>", XS_version_vcmp, file);
202 newXS("version::vcmp", XS_version_vcmp, file);
203 newXS("version::(bool", XS_version_boolean, file);
204 newXS("version::boolean", XS_version_boolean, file);
205 newXS("version::(nomethod", XS_version_noop, file);
206 newXS("version::noop", XS_version_noop, file);
208 newXS("utf8::valid", XS_utf8_valid, file);
209 newXS("utf8::encode", XS_utf8_encode, file);
210 newXS("utf8::decode", XS_utf8_decode, file);
211 newXS("utf8::upgrade", XS_utf8_upgrade, file);
212 newXS("utf8::downgrade", XS_utf8_downgrade, file);
213 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
214 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
215 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
216 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
217 newXSproto("Internals::hv_clear_placeholders",
218 XS_Internals_hv_clear_placehold, file, "\\%");
230 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
237 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
240 name = (char *)SvPV(ST(1),n_a);
242 ST(0) = boolSV(sv_derived_from(sv, name));
256 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
263 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(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 (!SvNIOK(sv) && SvPOK(sv)) {
337 char *str = SvPVx(sv,len);
340 /* XXX could DWIM "1.2.3" here */
341 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
345 if (SvNOK(req) && SvPOK(req)) {
346 /* they said C<use Foo v1.2.3> and $Foo::VERSION
347 * doesn't look like a float: do string compare */
348 if (sv_cmp(req,sv) == 1) {
349 Perl_croak(aTHX_ "%s v%"VDf" required--"
350 "this is only v%"VDf,
351 HvNAME(pkg), req, sv);
355 /* they said C<use Foo 1.002_003> and $Foo::VERSION
356 * doesn't look like a float: force numeric compare */
357 (void)SvUPGRADE(sv, SVt_PVNV);
358 SvNVX(sv) = str_to_version(sv);
363 /* if we get here, we're looking for a numeric comparison,
364 * so force the required version into a float, even if they
365 * said C<use Foo v1.2.3> */
366 if (SvNOK(req) && SvPOK(req)) {
368 req = sv_newmortal();
372 if (SvNV(req) > SvNV(sv))
373 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
374 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
387 Perl_croak(aTHX_ "Usage: version::new(class, version)");
390 /* char * class = (char *)SvPV_nolen(ST(0)); */
391 SV * version = ST(1);
394 PUSHs(new_version(version));
402 XS(XS_version_stringify)
406 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
411 if (sv_derived_from(ST(0), "version")) {
412 SV *tmp = SvRV(ST(0));
416 Perl_croak(aTHX_ "lobj is not of type version");
419 SV *vs = NEWSV(92,5);
420 if ( lobj == SvRV(PL_patchlevel) )
432 XS(XS_version_numify)
436 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
441 if (sv_derived_from(ST(0), "version")) {
442 SV *tmp = SvRV(ST(0));
446 Perl_croak(aTHX_ "lobj is not of type version");
449 SV *vs = NEWSV(92,5);
463 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
468 if (sv_derived_from(ST(0), "version")) {
469 SV *tmp = SvRV(ST(0));
473 Perl_croak(aTHX_ "lobj is not of type version");
479 IV swap = (IV)SvIV(ST(2));
481 if ( ! sv_derived_from(robj, "version") )
483 robj = new_version(robj);
489 rs = newSViv(sv_cmp(rvs,lobj));
493 rs = newSViv(sv_cmp(lobj,rvs));
504 XS(XS_version_boolean)
508 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
513 if (sv_derived_from(ST(0), "version")) {
514 SV *tmp = SvRV(ST(0));
518 Perl_croak(aTHX_ "lobj is not of type version");
522 rs = newSViv(sv_cmp(lobj,Nullsv));
535 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
539 if (sv_derived_from(ST(0), "version")) {
540 SV *tmp = SvRV(ST(0));
544 Perl_croak(aTHX_ "lobj is not of type version");
547 Perl_croak(aTHX_ "operation not supported with version object");
558 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
563 char *s = SvPV(sv,len);
564 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
577 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
590 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
595 RETVAL = sv_utf8_decode(sv);
596 ST(0) = boolSV(RETVAL);
606 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
612 RETVAL = sv_utf8_upgrade(sv);
613 XSprePUSH; PUSHi((IV)RETVAL);
618 XS(XS_utf8_downgrade)
621 if (items < 1 || items > 2)
622 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
631 failok = (int)SvIV(ST(1));
634 RETVAL = sv_utf8_downgrade(sv, failok);
635 ST(0) = boolSV(RETVAL);
641 XS(XS_utf8_native_to_unicode)
647 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
649 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
653 XS(XS_utf8_unicode_to_native)
659 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
661 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
665 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
668 SV *sv = SvRV(ST(0));
675 else if (items == 2) {
681 /* I hope you really know what you are doing. */
686 XSRETURN_UNDEF; /* Can't happen. */
689 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
692 SV *sv = SvRV(ST(0));
694 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
695 else if (items == 2) {
696 /* I hope you really know what you are doing. */
697 SvREFCNT(sv) = SvIV(ST(1));
698 XSRETURN_IV(SvREFCNT(sv));
700 XSRETURN_UNDEF; /* Can't happen. */
703 /* Maybe this should return the number of placeholders found in scalar context,
704 and a list of them in list context. */
705 XS(XS_Internals_hv_clear_placehold)
708 HV *hv = (HV *) SvRV(ST(0));
710 /* I don't care how many parameters were passed in, but I want to avoid
711 the unused variable warning. */
713 items = (I32)HvPLACEHOLDERS(hv);
717 I32 riter = HvRITER(hv);
718 HE *eiter = HvEITER(hv);
720 /* This may look suboptimal with the items *after* the iternext, but
721 it's quite deliberate. We only get here with items==0 if we've
722 just deleted the last placeholder in the hash. If we've just done
723 that then it means that the hash is in lazy delete mode, and the
724 HE is now only referenced in our iterator. If we just quit the loop
725 and discarded our iterator then the HE leaks. So we do the && the
726 other way to ensure iternext is called just one more time, which
727 has the side effect of triggering the lazy delete. */
728 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
730 SV *val = hv_iterval(hv, entry);
732 if (val == &PL_sv_undef) {
734 /* It seems that I have to go back in the front of the hash
735 API to delete a hash, even though I have a HE structure
736 pointing to the very entry I want to delete, and could hold
737 onto the previous HE that points to it. And it's easier to
738 go in with SVs as I can then specify the precomputed hash,
739 and don't have fun and games with utf8 keys. */
740 SV *key = hv_iterkeysv(entry);
742 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));