3 * Copyright (c) 1997-2003, 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 #include "perliol.h" /* For the PERLIO_F_XXX */
25 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
26 * The main guts of traverse_isa was actually copied from gv_fetchmeth
30 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
39 /* A stash/class can go by many names (ie. User == main::User), so
40 we compare the stash itself just in case */
41 if (name_stash && (stash == name_stash))
44 if (strEQ(HvNAME(stash), name))
48 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
51 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
53 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
56 if (SvIV(subgen) == (IV)PL_sub_generation) {
58 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
59 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
60 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
61 name, HvNAME(stash)) );
66 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
69 sv_setiv(subgen, PL_sub_generation);
73 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
75 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
77 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
81 if (SvTYPE(gv) != SVt_PVGV)
82 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
87 subgen = newSViv(PL_sub_generation);
92 SV** svp = AvARRAY(av);
93 /* NOTE: No support for tied ISA */
94 I32 items = AvFILLp(av) + 1;
97 HV* basestash = gv_stashsv(sv, FALSE);
99 if (ckWARN(WARN_MISC))
100 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
101 "Can't locate package %"SVf" for @%s::ISA",
105 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
107 (void)hv_store(hv,name,len,&PL_sv_yes,0);
111 (void)hv_store(hv,name,len,&PL_sv_no,0);
115 return boolSV(strEQ(name, "UNIVERSAL"));
119 =head1 SV Manipulation Functions
121 =for apidoc sv_derived_from
123 Returns a boolean indicating whether the SV is derived from the specified
124 class. This is the function that implements C<UNIVERSAL::isa>. It works
125 for class names as well as for objects.
131 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
145 type = sv_reftype(sv,0);
150 stash = gv_stashsv(sv, FALSE);
153 name_stash = gv_stashpv(name, FALSE);
155 return (type && strEQ(type,name)) ||
156 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
164 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
165 void XS_UNIVERSAL_can(pTHX_ CV *cv);
166 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
168 XS(XS_version_stringify);
169 XS(XS_version_numify);
171 XS(XS_version_boolean);
177 XS(XS_utf8_downgrade);
178 XS(XS_utf8_unicode_to_native);
179 XS(XS_utf8_native_to_unicode);
180 XS(XS_Internals_SvREADONLY);
181 XS(XS_Internals_SvREFCNT);
182 XS(XS_Internals_hv_clear_placehold);
183 XS(XS_PerlIO_get_layers);
186 Perl_boot_core_UNIVERSAL(pTHX)
188 char *file = __FILE__;
190 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
191 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
192 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
194 /* register the overloading (type 'A') magic */
195 PL_amagic_generation++;
196 /* Make it findable via fetchmethod */
197 newXS("version::()", XS_version_noop, file);
198 newXS("version::new", XS_version_new, file);
199 newXS("version::(\"\"", XS_version_stringify, file);
200 newXS("version::stringify", XS_version_stringify, file);
201 newXS("version::(0+", XS_version_numify, file);
202 newXS("version::numify", XS_version_numify, file);
203 newXS("version::(cmp", XS_version_vcmp, file);
204 newXS("version::(<=>", XS_version_vcmp, file);
205 newXS("version::vcmp", XS_version_vcmp, file);
206 newXS("version::(bool", XS_version_boolean, file);
207 newXS("version::boolean", XS_version_boolean, file);
208 newXS("version::(nomethod", XS_version_noop, file);
209 newXS("version::noop", XS_version_noop, file);
211 newXS("utf8::valid", XS_utf8_valid, file);
212 newXS("utf8::encode", XS_utf8_encode, file);
213 newXS("utf8::decode", XS_utf8_decode, file);
214 newXS("utf8::upgrade", XS_utf8_upgrade, file);
215 newXS("utf8::downgrade", XS_utf8_downgrade, file);
216 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
217 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
218 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
219 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
220 newXSproto("Internals::hv_clear_placeholders",
221 XS_Internals_hv_clear_placehold, file, "\\%");
222 newXS("PerlIO::get_layers", XS_PerlIO_get_layers, file);
234 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
241 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
242 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
245 name = (char *)SvPV(ST(1),n_a);
247 ST(0) = boolSV(sv_derived_from(sv, name));
261 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
268 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
269 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
272 name = (char *)SvPV(ST(1),n_a);
281 pkg = gv_stashsv(sv, FALSE);
285 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
287 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
294 XS(XS_UNIVERSAL_VERSION)
304 sv = (SV*)SvRV(ST(0));
306 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
310 pkg = gv_stashsv(ST(0), FALSE);
313 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
315 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
316 SV *nsv = sv_newmortal();
322 sv = (SV*)&PL_sv_undef;
333 "%s does not define $%s::VERSION--version check failed",
334 HvNAME(pkg), HvNAME(pkg));
336 char *str = SvPVx(ST(0), len);
339 "%s defines neither package nor VERSION--version check failed", str);
342 if ( !sv_derived_from(sv, "version"))
343 sv = new_version(sv);
345 if ( !sv_derived_from(req, "version"))
346 req = new_version(req);
348 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
350 "%s version %"SVf" required--this is only version %"SVf,
351 HvNAME(pkg), req, sv);
363 Perl_croak(aTHX_ "Usage: version::new(class, version)");
366 /* char * class = (char *)SvPV_nolen(ST(0)); */
370 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
371 version = Perl_newSVpvf(aTHX_ "v%s",vs);
374 PUSHs(new_version(version));
380 XS(XS_version_stringify)
384 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
389 if (sv_derived_from(ST(0), "version")) {
390 SV *tmp = SvRV(ST(0));
394 Perl_croak(aTHX_ "lobj is not of type version");
397 PUSHs(vstringify(lobj));
405 XS(XS_version_numify)
409 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
414 if (sv_derived_from(ST(0), "version")) {
415 SV *tmp = SvRV(ST(0));
419 Perl_croak(aTHX_ "lobj is not of type version");
422 PUSHs(vnumify(lobj));
434 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
439 if (sv_derived_from(ST(0), "version")) {
440 SV *tmp = SvRV(ST(0));
444 Perl_croak(aTHX_ "lobj is not of type version");
450 IV swap = (IV)SvIV(ST(2));
452 if ( ! sv_derived_from(robj, "version") )
454 robj = new_version(robj);
460 rs = newSViv(vcmp(rvs,lobj));
464 rs = newSViv(vcmp(lobj,rvs));
475 XS(XS_version_boolean)
479 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
484 if (sv_derived_from(ST(0), "version")) {
485 SV *tmp = SvRV(ST(0));
489 Perl_croak(aTHX_ "lobj is not of type version");
493 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
506 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
510 if (sv_derived_from(ST(0), "version")) {
511 SV *tmp = SvRV(ST(0));
515 Perl_croak(aTHX_ "lobj is not of type version");
518 Perl_croak(aTHX_ "operation not supported with version object");
529 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
534 char *s = SvPV(sv,len);
535 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
548 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
561 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
566 RETVAL = sv_utf8_decode(sv);
567 ST(0) = boolSV(RETVAL);
577 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
583 RETVAL = sv_utf8_upgrade(sv);
584 XSprePUSH; PUSHi((IV)RETVAL);
589 XS(XS_utf8_downgrade)
592 if (items < 1 || items > 2)
593 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
602 failok = (int)SvIV(ST(1));
605 RETVAL = sv_utf8_downgrade(sv, failok);
606 ST(0) = boolSV(RETVAL);
612 XS(XS_utf8_native_to_unicode)
618 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
620 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
624 XS(XS_utf8_unicode_to_native)
630 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
632 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
636 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
639 SV *sv = SvRV(ST(0));
646 else if (items == 2) {
652 /* I hope you really know what you are doing. */
657 XSRETURN_UNDEF; /* Can't happen. */
660 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
663 SV *sv = SvRV(ST(0));
665 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
666 else if (items == 2) {
667 /* I hope you really know what you are doing. */
668 SvREFCNT(sv) = SvIV(ST(1));
669 XSRETURN_IV(SvREFCNT(sv));
671 XSRETURN_UNDEF; /* Can't happen. */
674 /* Maybe this should return the number of placeholders found in scalar context,
675 and a list of them in list context. */
676 XS(XS_Internals_hv_clear_placehold)
679 HV *hv = (HV *) SvRV(ST(0));
681 /* I don't care how many parameters were passed in, but I want to avoid
682 the unused variable warning. */
684 items = (I32)HvPLACEHOLDERS(hv);
688 I32 riter = HvRITER(hv);
689 HE *eiter = HvEITER(hv);
691 /* This may look suboptimal with the items *after* the iternext, but
692 it's quite deliberate. We only get here with items==0 if we've
693 just deleted the last placeholder in the hash. If we've just done
694 that then it means that the hash is in lazy delete mode, and the
695 HE is now only referenced in our iterator. If we just quit the loop
696 and discarded our iterator then the HE leaks. So we do the && the
697 other way to ensure iternext is called just one more time, which
698 has the side effect of triggering the lazy delete. */
699 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
701 SV *val = hv_iterval(hv, entry);
703 if (val == &PL_sv_undef) {
705 /* It seems that I have to go back in the front of the hash
706 API to delete a hash, even though I have a HE structure
707 pointing to the very entry I want to delete, and could hold
708 onto the previous HE that points to it. And it's easier to
709 go in with SVs as I can then specify the precomputed hash,
710 and don't have fun and games with utf8 keys. */
711 SV *key = hv_iterkeysv(entry);
713 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
724 XS(XS_PerlIO_get_layers)
727 if (items < 1 || items % 2 == 0)
728 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
735 bool details = FALSE;
738 SV **popuntil = MARK + 1;
741 for (svp = MARK + 2; svp <= SP; svp += 2) {
745 char *key = SvPV(*varp, klen);
749 if (klen == 5 && memEQ(key, "input", 5)) {
750 input = SvTRUE(*valp);
755 if (klen == 6 && memEQ(key, "output", 6)) {
756 input = !SvTRUE(*valp);
761 if (klen == 7 && memEQ(key, "details", 7)) {
762 details = SvTRUE(*valp);
769 "get_layers: unknown argument '%s'",
781 if (SvROK(sv) && isGV(SvRV(sv)))
784 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
787 if (gv && (io = GvIO(gv))) {
789 AV* av = PerlIO_get_layers(aTHX_ input ?
790 IoIFP(io) : IoOFP(io));
792 I32 last = av_len(av);
795 for (i = last; i >= 0; i -= 3) {
799 bool namok, argok, flgok;
801 namsvp = av_fetch(av, i - 2, FALSE);
802 argsvp = av_fetch(av, i - 1, FALSE);
803 flgsvp = av_fetch(av, i, FALSE);
805 namok = namsvp && *namsvp && SvPOK(*namsvp);
806 argok = argsvp && *argsvp && SvPOK(*argsvp);
807 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
811 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
813 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
815 XPUSHi(SvIVX(*flgsvp));
817 XPUSHs(&PL_sv_undef);
822 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
825 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
827 XPUSHs(&PL_sv_undef);
830 IV flags = SvIVX(*flgsvp);
832 if (flags & PERLIO_F_UTF8) {
833 XPUSHs(newSVpvn("utf8", 4));