3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "The roots of those mountains must be roots indeed; there must be
13 * great secrets buried there which have not been discovered since the
14 * beginning." --Gandalf, relating Gollum's story
18 #define PERL_IN_UNIVERSAL_C
22 #include "perliol.h" /* For the PERLIO_F_XXX */
26 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
27 * The main guts of traverse_isa was actually copied from gv_fetchmeth
31 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
40 /* A stash/class can go by many names (ie. User == main::User), so
41 we compare the stash itself just in case */
42 if (name_stash && (stash == name_stash))
45 if (strEQ(HvNAME(stash), name))
49 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
52 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
54 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
57 if (SvIV(subgen) == (IV)PL_sub_generation) {
59 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
60 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
61 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
62 name, HvNAME(stash)) );
67 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
70 sv_setiv(subgen, PL_sub_generation);
74 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
76 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
78 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
82 if (SvTYPE(gv) != SVt_PVGV)
83 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
88 subgen = newSViv(PL_sub_generation);
93 SV** svp = AvARRAY(av);
94 /* NOTE: No support for tied ISA */
95 I32 items = AvFILLp(av) + 1;
98 HV* basestash = gv_stashsv(sv, FALSE);
100 if (ckWARN(WARN_MISC))
101 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
102 "Can't locate package %"SVf" for @%s::ISA",
106 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
108 (void)hv_store(hv,name,len,&PL_sv_yes,0);
112 (void)hv_store(hv,name,len,&PL_sv_no,0);
116 return boolSV(strEQ(name, "UNIVERSAL"));
120 =head1 SV Manipulation Functions
122 =for apidoc sv_derived_from
124 Returns a boolean indicating whether the SV is derived from the specified
125 class. This is the function that implements C<UNIVERSAL::isa>. It works
126 for class names as well as for objects.
132 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
146 type = sv_reftype(sv,0);
151 stash = gv_stashsv(sv, FALSE);
154 name_stash = gv_stashpv(name, FALSE);
156 return (type && strEQ(type,name)) ||
157 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
165 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
166 void XS_UNIVERSAL_can(pTHX_ CV *cv);
167 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
169 XS(XS_version_stringify);
170 XS(XS_version_numify);
172 XS(XS_version_boolean);
179 XS(XS_utf8_downgrade);
180 XS(XS_utf8_unicode_to_native);
181 XS(XS_utf8_native_to_unicode);
182 XS(XS_Internals_SvREADONLY);
183 XS(XS_Internals_SvREFCNT);
184 XS(XS_Internals_hv_clear_placehold);
185 XS(XS_PerlIO_get_layers);
186 XS(XS_Regexp_DESTROY);
189 Perl_boot_core_UNIVERSAL(pTHX)
191 char *file = __FILE__;
193 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
194 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
195 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
197 /* register the overloading (type 'A') magic */
198 PL_amagic_generation++;
199 /* Make it findable via fetchmethod */
200 newXS("version::()", XS_version_noop, file);
201 newXS("version::new", XS_version_new, file);
202 newXS("version::(\"\"", XS_version_stringify, file);
203 newXS("version::stringify", XS_version_stringify, file);
204 newXS("version::(0+", XS_version_numify, file);
205 newXS("version::numify", XS_version_numify, file);
206 newXS("version::(cmp", XS_version_vcmp, file);
207 newXS("version::(<=>", XS_version_vcmp, file);
208 newXS("version::vcmp", XS_version_vcmp, file);
209 newXS("version::(bool", XS_version_boolean, file);
210 newXS("version::boolean", XS_version_boolean, file);
211 newXS("version::(nomethod", XS_version_noop, file);
212 newXS("version::noop", XS_version_noop, file);
214 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
215 newXS("utf8::valid", XS_utf8_valid, file);
216 newXS("utf8::encode", XS_utf8_encode, file);
217 newXS("utf8::decode", XS_utf8_decode, file);
218 newXS("utf8::upgrade", XS_utf8_upgrade, file);
219 newXS("utf8::downgrade", XS_utf8_downgrade, file);
220 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
221 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
222 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
223 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
224 newXSproto("Internals::hv_clear_placeholders",
225 XS_Internals_hv_clear_placehold, file, "\\%");
226 newXSproto("PerlIO::get_layers",
227 XS_PerlIO_get_layers, file, "*;@");
228 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
240 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
247 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
248 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
251 name = (char *)SvPV(ST(1),n_a);
253 ST(0) = boolSV(sv_derived_from(sv, name));
267 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
274 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
275 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
278 name = (char *)SvPV(ST(1),n_a);
287 pkg = gv_stashsv(sv, FALSE);
291 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
293 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
300 XS(XS_UNIVERSAL_VERSION)
310 sv = (SV*)SvRV(ST(0));
312 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
316 pkg = gv_stashsv(ST(0), FALSE);
319 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
321 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
322 SV *nsv = sv_newmortal();
328 sv = (SV*)&PL_sv_undef;
339 "%s does not define $%s::VERSION--version check failed",
340 HvNAME(pkg), HvNAME(pkg));
342 char *str = SvPVx(ST(0), len);
345 "%s defines neither package nor VERSION--version check failed", str);
348 if ( !sv_derived_from(sv, "version"))
349 sv = new_version(sv);
351 if ( !sv_derived_from(req, "version"))
352 req = new_version(req);
354 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
356 "%s version %"SVf" required--this is only version %"SVf,
357 HvNAME(pkg), req, sv);
369 Perl_croak(aTHX_ "Usage: version::new(class, version)");
372 /* char * class = (char *)SvPV_nolen(ST(0)); */
376 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
377 version = Perl_newSVpvf(aTHX_ "v%s",vs);
380 PUSHs(new_version(version));
386 XS(XS_version_stringify)
390 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
395 if (sv_derived_from(ST(0), "version")) {
396 SV *tmp = SvRV(ST(0));
400 Perl_croak(aTHX_ "lobj is not of type version");
403 PUSHs(vstringify(lobj));
411 XS(XS_version_numify)
415 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
420 if (sv_derived_from(ST(0), "version")) {
421 SV *tmp = SvRV(ST(0));
425 Perl_croak(aTHX_ "lobj is not of type version");
428 PUSHs(vnumify(lobj));
440 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
445 if (sv_derived_from(ST(0), "version")) {
446 SV *tmp = SvRV(ST(0));
450 Perl_croak(aTHX_ "lobj is not of type version");
456 IV swap = (IV)SvIV(ST(2));
458 if ( ! sv_derived_from(robj, "version") )
460 robj = new_version(robj);
466 rs = newSViv(vcmp(rvs,lobj));
470 rs = newSViv(vcmp(lobj,rvs));
481 XS(XS_version_boolean)
485 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
490 if (sv_derived_from(ST(0), "version")) {
491 SV *tmp = SvRV(ST(0));
495 Perl_croak(aTHX_ "lobj is not of type version");
499 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
512 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
516 if (sv_derived_from(ST(0), "version")) {
517 SV *tmp = SvRV(ST(0));
521 Perl_croak(aTHX_ "lobj is not of type version");
524 Perl_croak(aTHX_ "operation not supported with version object");
535 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
552 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
557 char *s = SvPV(sv,len);
558 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
571 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
584 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
589 RETVAL = sv_utf8_decode(sv);
590 ST(0) = boolSV(RETVAL);
600 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
606 RETVAL = sv_utf8_upgrade(sv);
607 XSprePUSH; PUSHi((IV)RETVAL);
612 XS(XS_utf8_downgrade)
615 if (items < 1 || items > 2)
616 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
625 failok = (int)SvIV(ST(1));
628 RETVAL = sv_utf8_downgrade(sv, failok);
629 ST(0) = boolSV(RETVAL);
635 XS(XS_utf8_native_to_unicode)
641 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
643 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
647 XS(XS_utf8_unicode_to_native)
653 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
655 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
659 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
662 SV *sv = SvRV(ST(0));
669 else if (items == 2) {
675 /* I hope you really know what you are doing. */
680 XSRETURN_UNDEF; /* Can't happen. */
683 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
686 SV *sv = SvRV(ST(0));
688 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
689 else if (items == 2) {
690 /* I hope you really know what you are doing. */
691 SvREFCNT(sv) = SvIV(ST(1));
692 XSRETURN_IV(SvREFCNT(sv));
694 XSRETURN_UNDEF; /* Can't happen. */
697 /* Maybe this should return the number of placeholders found in scalar context,
698 and a list of them in list context. */
699 XS(XS_Internals_hv_clear_placehold)
702 HV *hv = (HV *) SvRV(ST(0));
704 /* I don't care how many parameters were passed in, but I want to avoid
705 the unused variable warning. */
707 items = (I32)HvPLACEHOLDERS(hv);
711 I32 riter = HvRITER(hv);
712 HE *eiter = HvEITER(hv);
714 /* This may look suboptimal with the items *after* the iternext, but
715 it's quite deliberate. We only get here with items==0 if we've
716 just deleted the last placeholder in the hash. If we've just done
717 that then it means that the hash is in lazy delete mode, and the
718 HE is now only referenced in our iterator. If we just quit the loop
719 and discarded our iterator then the HE leaks. So we do the && the
720 other way to ensure iternext is called just one more time, which
721 has the side effect of triggering the lazy delete. */
722 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
724 SV *val = hv_iterval(hv, entry);
726 if (val == &PL_sv_undef) {
728 /* It seems that I have to go back in the front of the hash
729 API to delete a hash, even though I have a HE structure
730 pointing to the very entry I want to delete, and could hold
731 onto the previous HE that points to it. And it's easier to
732 go in with SVs as I can then specify the precomputed hash,
733 and don't have fun and games with utf8 keys. */
734 SV *key = hv_iterkeysv(entry);
736 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
747 XS(XS_Regexp_DESTROY)
752 XS(XS_PerlIO_get_layers)
755 if (items < 1 || items % 2 == 0)
756 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
763 bool details = FALSE;
768 for (svp = MARK + 2; svp <= SP; svp += 2) {
772 char *key = SvPV(*varp, klen);
776 if (klen == 5 && memEQ(key, "input", 5)) {
777 input = SvTRUE(*valp);
782 if (klen == 6 && memEQ(key, "output", 6)) {
783 input = !SvTRUE(*valp);
788 if (klen == 7 && memEQ(key, "details", 7)) {
789 details = SvTRUE(*valp);
796 "get_layers: unknown argument '%s'",
808 if (SvROK(sv) && isGV(SvRV(sv)))
811 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
814 if (gv && (io = GvIO(gv))) {
816 AV* av = PerlIO_get_layers(aTHX_ input ?
817 IoIFP(io) : IoOFP(io));
819 I32 last = av_len(av);
822 for (i = last; i >= 0; i -= 3) {
826 bool namok, argok, flgok;
828 namsvp = av_fetch(av, i - 2, FALSE);
829 argsvp = av_fetch(av, i - 1, FALSE);
830 flgsvp = av_fetch(av, i, FALSE);
832 namok = namsvp && *namsvp && SvPOK(*namsvp);
833 argok = argsvp && *argsvp && SvPOK(*argsvp);
834 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
838 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
840 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
842 XPUSHi(SvIVX(*flgsvp));
844 XPUSHs(&PL_sv_undef);
849 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
852 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
854 XPUSHs(&PL_sv_undef);
857 IV flags = SvIVX(*flgsvp);
859 if (flags & PERLIO_F_UTF8) {
860 XPUSHs(newSVpvn("utf8", 4));