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::()", XS_version_noop, file);
196 newXS("version::new", XS_version_new, file);
197 newXS("version::(\"\"", XS_version_stringify, file);
198 newXS("version::stringify", XS_version_stringify, file);
199 newXS("version::(0+", XS_version_numify, file);
200 newXS("version::numify", XS_version_numify, file);
201 newXS("version::(cmp", XS_version_vcmp, file);
202 newXS("version::(<=>", XS_version_vcmp, file);
203 newXS("version::vcmp", XS_version_vcmp, file);
204 newXS("version::(bool", XS_version_boolean, file);
205 newXS("version::boolean", XS_version_boolean, file);
206 newXS("version::(nomethod", XS_version_noop, file);
207 newXS("version::noop", XS_version_noop, file);
209 newXS("utf8::valid", XS_utf8_valid, file);
210 newXS("utf8::encode", XS_utf8_encode, file);
211 newXS("utf8::decode", XS_utf8_decode, file);
212 newXS("utf8::upgrade", XS_utf8_upgrade, file);
213 newXS("utf8::downgrade", XS_utf8_downgrade, file);
214 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
215 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
216 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
217 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
218 newXSproto("Internals::hv_clear_placeholders",
219 XS_Internals_hv_clear_placehold, file, "\\%");
231 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
238 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
241 name = (char *)SvPV(ST(1),n_a);
243 ST(0) = boolSV(sv_derived_from(sv, name));
257 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
264 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
267 name = (char *)SvPV(ST(1),n_a);
276 pkg = gv_stashsv(sv, FALSE);
280 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
282 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
289 XS(XS_UNIVERSAL_VERSION)
299 sv = (SV*)SvRV(ST(0));
301 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
305 pkg = gv_stashsv(ST(0), FALSE);
308 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
310 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
311 SV *nsv = sv_newmortal();
317 sv = (SV*)&PL_sv_undef;
328 "%s does not define $%s::VERSION--version check failed",
329 HvNAME(pkg), HvNAME(pkg));
331 char *str = SvPVx(ST(0), len);
334 "%s defines neither package nor VERSION--version check failed", str);
337 if (!SvNIOK(sv) && SvPOK(sv)) {
338 char *str = SvPVx(sv,len);
341 /* XXX could DWIM "1.2.3" here */
342 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
346 if (SvNOK(req) && SvPOK(req)) {
347 /* they said C<use Foo v1.2.3> and $Foo::VERSION
348 * doesn't look like a float: do string compare */
349 if (sv_cmp(req,sv) == 1) {
350 Perl_croak(aTHX_ "%s v%"VDf" required--"
351 "this is only v%"VDf,
352 HvNAME(pkg), req, sv);
356 /* they said C<use Foo 1.002_003> and $Foo::VERSION
357 * doesn't look like a float: force numeric compare */
358 (void)SvUPGRADE(sv, SVt_PVNV);
359 SvNVX(sv) = str_to_version(sv);
364 /* if we get here, we're looking for a numeric comparison,
365 * so force the required version into a float, even if they
366 * said C<use Foo v1.2.3> */
367 if (SvNOK(req) && SvPOK(req)) {
369 req = sv_newmortal();
373 if (SvNV(req) > SvNV(sv))
374 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
375 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
388 Perl_croak(aTHX_ "Usage: version::new(class, version)");
391 /* char * class = (char *)SvPV_nolen(ST(0)); */
392 SV * version = ST(1);
395 PUSHs(new_version(version));
403 XS(XS_version_stringify)
407 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
412 if (sv_derived_from(ST(0), "version")) {
413 SV *tmp = SvRV(ST(0));
417 Perl_croak(aTHX_ "lobj is not of type version");
420 SV *vs = NEWSV(92,5);
421 if ( lobj == SvRV(PL_patchlevel) )
433 XS(XS_version_numify)
437 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
442 if (sv_derived_from(ST(0), "version")) {
443 SV *tmp = SvRV(ST(0));
447 Perl_croak(aTHX_ "lobj is not of type version");
450 SV *vs = NEWSV(92,5);
464 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
469 if (sv_derived_from(ST(0), "version")) {
470 SV *tmp = SvRV(ST(0));
474 Perl_croak(aTHX_ "lobj is not of type version");
480 IV swap = (IV)SvIV(ST(2));
482 if ( ! sv_derived_from(robj, "version") )
484 robj = new_version(robj);
490 rs = newSViv(sv_cmp(rvs,lobj));
494 rs = newSViv(sv_cmp(lobj,rvs));
505 XS(XS_version_boolean)
509 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
514 if (sv_derived_from(ST(0), "version")) {
515 SV *tmp = SvRV(ST(0));
519 Perl_croak(aTHX_ "lobj is not of type version");
523 rs = newSViv(sv_cmp(lobj,Nullsv));
536 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
540 if (sv_derived_from(ST(0), "version")) {
541 SV *tmp = SvRV(ST(0));
545 Perl_croak(aTHX_ "lobj is not of type version");
548 Perl_croak(aTHX_ "operation not supported with version object");
559 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
564 char *s = SvPV(sv,len);
565 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
578 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
591 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
596 RETVAL = sv_utf8_decode(sv);
597 ST(0) = boolSV(RETVAL);
607 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
613 RETVAL = sv_utf8_upgrade(sv);
614 XSprePUSH; PUSHi((IV)RETVAL);
619 XS(XS_utf8_downgrade)
622 if (items < 1 || items > 2)
623 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
632 failok = (int)SvIV(ST(1));
635 RETVAL = sv_utf8_downgrade(sv, failok);
636 ST(0) = boolSV(RETVAL);
642 XS(XS_utf8_native_to_unicode)
648 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
650 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
654 XS(XS_utf8_unicode_to_native)
660 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
662 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
666 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
669 SV *sv = SvRV(ST(0));
676 else if (items == 2) {
682 /* I hope you really know what you are doing. */
687 XSRETURN_UNDEF; /* Can't happen. */
690 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
693 SV *sv = SvRV(ST(0));
695 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
696 else if (items == 2) {
697 /* I hope you really know what you are doing. */
698 SvREFCNT(sv) = SvIV(ST(1));
699 XSRETURN_IV(SvREFCNT(sv));
701 XSRETURN_UNDEF; /* Can't happen. */
704 /* Maybe this should return the number of placeholders found in scalar context,
705 and a list of them in list context. */
706 XS(XS_Internals_hv_clear_placehold)
709 HV *hv = (HV *) SvRV(ST(0));
711 /* I don't care how many parameters were passed in, but I want to avoid
712 the unused variable warning. */
714 items = (I32)HvPLACEHOLDERS(hv);
718 I32 riter = HvRITER(hv);
719 HE *eiter = HvEITER(hv);
721 /* This may look suboptimal with the items *after* the iternext, but
722 it's quite deliberate. We only get here with items==0 if we've
723 just deleted the last placeholder in the hash. If we've just done
724 that then it means that the hash is in lazy delete mode, and the
725 HE is now only referenced in our iterator. If we just quit the loop
726 and discarded our iterator then the HE leaks. So we do the && the
727 other way to ensure iternext is called just one more time, which
728 has the side effect of triggering the lazy delete. */
729 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
731 SV *val = hv_iterval(hv, entry);
733 if (val == &PL_sv_undef) {
735 /* It seems that I have to go back in the front of the hash
736 API to delete a hash, even though I have a HE structure
737 pointing to the very entry I want to delete, and could hold
738 onto the previous HE that points to it. And it's easier to
739 go in with SVs as I can then specify the precomputed hash,
740 and don't have fun and games with utf8 keys. */
741 SV *key = hv_iterkeysv(entry);
743 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));