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))
48 if (strEQ(name, "UNIVERSAL"))
52 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
55 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
57 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
60 if (SvIV(subgen) == (IV)PL_sub_generation) {
62 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
63 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
64 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
65 name, HvNAME(stash)) );
70 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
73 sv_setiv(subgen, PL_sub_generation);
77 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
79 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
81 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
85 if (SvTYPE(gv) != SVt_PVGV)
86 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
91 subgen = newSViv(PL_sub_generation);
96 SV** svp = AvARRAY(av);
97 /* NOTE: No support for tied ISA */
98 I32 items = AvFILLp(av) + 1;
101 HV* basestash = gv_stashsv(sv, FALSE);
103 if (ckWARN(WARN_MISC))
104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
105 "Can't locate package %"SVf" for @%s::ISA",
109 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
111 (void)hv_store(hv,name,len,&PL_sv_yes,0);
115 (void)hv_store(hv,name,len,&PL_sv_no,0);
122 =head1 SV Manipulation Functions
124 =for apidoc sv_derived_from
126 Returns a boolean indicating whether the SV is derived from the specified
127 class. This is the function that implements C<UNIVERSAL::isa>. It works
128 for class names as well as for objects.
134 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
148 type = sv_reftype(sv,0);
153 stash = gv_stashsv(sv, FALSE);
156 name_stash = gv_stashpv(name, FALSE);
158 return (type && strEQ(type,name)) ||
159 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
167 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
168 void XS_UNIVERSAL_can(pTHX_ CV *cv);
169 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
171 XS(XS_version_stringify);
172 XS(XS_version_numify);
174 XS(XS_version_boolean);
176 XS(XS_version_is_alpha);
182 XS(XS_utf8_downgrade);
183 XS(XS_utf8_unicode_to_native);
184 XS(XS_utf8_native_to_unicode);
185 XS(XS_Internals_SvREADONLY);
186 XS(XS_Internals_SvREFCNT);
187 XS(XS_Internals_hv_clear_placehold);
188 XS(XS_PerlIO_get_layers);
189 XS(XS_Regexp_DESTROY);
190 XS(XS_Internals_hash_seed);
193 Perl_boot_core_UNIVERSAL(pTHX)
195 char *file = __FILE__;
197 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
198 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
199 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
201 /* register the overloading (type 'A') magic */
202 PL_amagic_generation++;
203 /* Make it findable via fetchmethod */
204 newXS("version::()", XS_version_noop, file);
205 newXS("version::new", XS_version_new, file);
206 newXS("version::(\"\"", XS_version_stringify, file);
207 newXS("version::stringify", XS_version_stringify, file);
208 newXS("version::(0+", XS_version_numify, file);
209 newXS("version::numify", XS_version_numify, file);
210 newXS("version::(cmp", XS_version_vcmp, file);
211 newXS("version::(<=>", XS_version_vcmp, file);
212 newXS("version::vcmp", XS_version_vcmp, file);
213 newXS("version::(bool", XS_version_boolean, file);
214 newXS("version::boolean", XS_version_boolean, file);
215 newXS("version::(nomethod", XS_version_noop, file);
216 newXS("version::noop", XS_version_noop, file);
217 newXS("version::is_alpha", XS_version_is_alpha, file);
219 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
220 newXS("utf8::valid", XS_utf8_valid, file);
221 newXS("utf8::encode", XS_utf8_encode, file);
222 newXS("utf8::decode", XS_utf8_decode, file);
223 newXS("utf8::upgrade", XS_utf8_upgrade, file);
224 newXS("utf8::downgrade", XS_utf8_downgrade, file);
225 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
226 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
227 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
228 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
229 newXSproto("Internals::hv_clear_placeholders",
230 XS_Internals_hv_clear_placehold, file, "\\%");
231 newXSproto("PerlIO::get_layers",
232 XS_PerlIO_get_layers, file, "*;@");
233 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
234 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
246 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
253 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
254 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
257 name = (char *)SvPV(ST(1),n_a);
259 ST(0) = boolSV(sv_derived_from(sv, name));
273 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
280 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
281 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
284 name = (char *)SvPV(ST(1),n_a);
293 pkg = gv_stashsv(sv, FALSE);
297 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
299 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
306 XS(XS_UNIVERSAL_VERSION)
316 sv = (SV*)SvRV(ST(0));
318 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
322 pkg = gv_stashsv(ST(0), FALSE);
325 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
327 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
328 SV *nsv = sv_newmortal();
334 sv = (SV*)&PL_sv_undef;
345 "%s does not define $%s::VERSION--version check failed",
346 HvNAME(pkg), HvNAME(pkg));
348 char *str = SvPVx(ST(0), len);
351 "%s defines neither package nor VERSION--version check failed", str);
354 if ( !sv_derived_from(sv, "version"))
355 sv = new_version(sv);
357 if ( !sv_derived_from(req, "version"))
358 req = new_version(req);
360 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
362 "%s version %"SVf" required--this is only version %"SVf,
363 HvNAME(pkg), req, sv);
375 Perl_croak(aTHX_ "Usage: version::new(class, version)");
378 /* char * class = (char *)SvPV_nolen(ST(0)); */
382 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
383 version = Perl_newSVpvf(aTHX_ "v%s",vs);
386 PUSHs(new_version(version));
392 XS(XS_version_stringify)
396 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
401 if (sv_derived_from(ST(0), "version")) {
402 SV *tmp = SvRV(ST(0));
406 Perl_croak(aTHX_ "lobj is not of type version");
409 PUSHs(vstringify(lobj));
417 XS(XS_version_numify)
421 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
426 if (sv_derived_from(ST(0), "version")) {
427 SV *tmp = SvRV(ST(0));
431 Perl_croak(aTHX_ "lobj is not of type version");
434 PUSHs(vnumify(lobj));
446 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
451 if (sv_derived_from(ST(0), "version")) {
452 SV *tmp = SvRV(ST(0));
456 Perl_croak(aTHX_ "lobj is not of type version");
462 IV swap = (IV)SvIV(ST(2));
464 if ( ! sv_derived_from(robj, "version") )
466 robj = new_version(robj);
472 rs = newSViv(vcmp(rvs,lobj));
476 rs = newSViv(vcmp(lobj,rvs));
487 XS(XS_version_boolean)
491 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
496 if (sv_derived_from(ST(0), "version")) {
497 SV *tmp = SvRV(ST(0));
501 Perl_croak(aTHX_ "lobj is not of type version");
505 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
518 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
522 if (sv_derived_from(ST(0), "version")) {
523 SV *tmp = SvRV(ST(0));
527 Perl_croak(aTHX_ "lobj is not of type version");
530 Perl_croak(aTHX_ "operation not supported with version object");
537 XS(XS_version_is_alpha)
541 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
546 if (sv_derived_from(ST(0), "version")) {
547 SV *tmp = SvRV(ST(0));
551 Perl_croak(aTHX_ "lobj is not of type version");
553 I32 len = av_len((AV *)lobj);
554 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
569 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
586 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
591 char *s = SvPV(sv,len);
592 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
605 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
618 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
623 RETVAL = sv_utf8_decode(sv);
624 ST(0) = boolSV(RETVAL);
634 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
640 RETVAL = sv_utf8_upgrade(sv);
641 XSprePUSH; PUSHi((IV)RETVAL);
646 XS(XS_utf8_downgrade)
649 if (items < 1 || items > 2)
650 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
659 failok = (int)SvIV(ST(1));
662 RETVAL = sv_utf8_downgrade(sv, failok);
663 ST(0) = boolSV(RETVAL);
669 XS(XS_utf8_native_to_unicode)
675 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
677 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
681 XS(XS_utf8_unicode_to_native)
687 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
689 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
693 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
696 SV *sv = SvRV(ST(0));
703 else if (items == 2) {
709 /* I hope you really know what you are doing. */
714 XSRETURN_UNDEF; /* Can't happen. */
717 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
720 SV *sv = SvRV(ST(0));
722 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
723 else if (items == 2) {
724 /* I hope you really know what you are doing. */
725 SvREFCNT(sv) = SvIV(ST(1));
726 XSRETURN_IV(SvREFCNT(sv));
728 XSRETURN_UNDEF; /* Can't happen. */
731 /* Maybe this should return the number of placeholders found in scalar context,
732 and a list of them in list context. */
733 XS(XS_Internals_hv_clear_placehold)
736 HV *hv = (HV *) SvRV(ST(0));
738 /* I don't care how many parameters were passed in, but I want to avoid
739 the unused variable warning. */
741 items = (I32)HvPLACEHOLDERS(hv);
745 I32 riter = HvRITER(hv);
746 HE *eiter = HvEITER(hv);
748 /* This may look suboptimal with the items *after* the iternext, but
749 it's quite deliberate. We only get here with items==0 if we've
750 just deleted the last placeholder in the hash. If we've just done
751 that then it means that the hash is in lazy delete mode, and the
752 HE is now only referenced in our iterator. If we just quit the loop
753 and discarded our iterator then the HE leaks. So we do the && the
754 other way to ensure iternext is called just one more time, which
755 has the side effect of triggering the lazy delete. */
756 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
758 SV *val = hv_iterval(hv, entry);
760 if (val == &PL_sv_placeholder) {
762 /* It seems that I have to go back in the front of the hash
763 API to delete a hash, even though I have a HE structure
764 pointing to the very entry I want to delete, and could hold
765 onto the previous HE that points to it. And it's easier to
766 go in with SVs as I can then specify the precomputed hash,
767 and don't have fun and games with utf8 keys. */
768 SV *key = hv_iterkeysv(entry);
770 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
781 XS(XS_Regexp_DESTROY)
786 XS(XS_PerlIO_get_layers)
789 if (items < 1 || items % 2 == 0)
790 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
797 bool details = FALSE;
802 for (svp = MARK + 2; svp <= SP; svp += 2) {
806 char *key = SvPV(*varp, klen);
810 if (klen == 5 && memEQ(key, "input", 5)) {
811 input = SvTRUE(*valp);
816 if (klen == 6 && memEQ(key, "output", 6)) {
817 input = !SvTRUE(*valp);
822 if (klen == 7 && memEQ(key, "details", 7)) {
823 details = SvTRUE(*valp);
830 "get_layers: unknown argument '%s'",
842 if (SvROK(sv) && isGV(SvRV(sv)))
845 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
848 if (gv && (io = GvIO(gv))) {
850 AV* av = PerlIO_get_layers(aTHX_ input ?
851 IoIFP(io) : IoOFP(io));
853 I32 last = av_len(av);
856 for (i = last; i >= 0; i -= 3) {
860 bool namok, argok, flgok;
862 namsvp = av_fetch(av, i - 2, FALSE);
863 argsvp = av_fetch(av, i - 1, FALSE);
864 flgsvp = av_fetch(av, i, FALSE);
866 namok = namsvp && *namsvp && SvPOK(*namsvp);
867 argok = argsvp && *argsvp && SvPOK(*argsvp);
868 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
872 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
874 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
876 XPUSHi(SvIVX(*flgsvp));
878 XPUSHs(&PL_sv_undef);
883 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
886 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
888 XPUSHs(&PL_sv_undef);
891 IV flags = SvIVX(*flgsvp);
893 if (flags & PERLIO_F_UTF8) {
894 XPUSHs(newSVpvn("utf8", 4));
911 XS(XS_Internals_hash_seed)
913 /* Using dXSARGS would also have dITEM and dSP,
914 * which define 2 unused local variables. */
916 XSRETURN_UV(PL_hash_seed);