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);
191 XS(XS_Internals_rehash_seed);
192 XS(XS_Internals_HvREHASH);
195 Perl_boot_core_UNIVERSAL(pTHX)
197 char *file = __FILE__;
199 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
200 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
201 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
203 /* register the overloading (type 'A') magic */
204 PL_amagic_generation++;
205 /* Make it findable via fetchmethod */
206 newXS("version::()", XS_version_noop, file);
207 newXS("version::new", XS_version_new, file);
208 newXS("version::(\"\"", XS_version_stringify, file);
209 newXS("version::stringify", XS_version_stringify, file);
210 newXS("version::(0+", XS_version_numify, file);
211 newXS("version::numify", XS_version_numify, file);
212 newXS("version::(cmp", XS_version_vcmp, file);
213 newXS("version::(<=>", XS_version_vcmp, file);
214 newXS("version::vcmp", XS_version_vcmp, file);
215 newXS("version::(bool", XS_version_boolean, file);
216 newXS("version::boolean", XS_version_boolean, file);
217 newXS("version::(nomethod", XS_version_noop, file);
218 newXS("version::noop", XS_version_noop, file);
219 newXS("version::is_alpha", XS_version_is_alpha, file);
221 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
222 newXS("utf8::valid", XS_utf8_valid, file);
223 newXS("utf8::encode", XS_utf8_encode, file);
224 newXS("utf8::decode", XS_utf8_decode, file);
225 newXS("utf8::upgrade", XS_utf8_upgrade, file);
226 newXS("utf8::downgrade", XS_utf8_downgrade, file);
227 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
228 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
229 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
230 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
231 newXSproto("Internals::hv_clear_placeholders",
232 XS_Internals_hv_clear_placehold, file, "\\%");
233 newXSproto("PerlIO::get_layers",
234 XS_PerlIO_get_layers, file, "*;@");
235 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
236 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
237 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
238 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
250 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
257 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
258 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
261 name = (char *)SvPV(ST(1),n_a);
263 ST(0) = boolSV(sv_derived_from(sv, name));
277 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
284 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
285 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
288 name = (char *)SvPV(ST(1),n_a);
297 pkg = gv_stashsv(sv, FALSE);
301 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
303 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
310 XS(XS_UNIVERSAL_VERSION)
320 sv = (SV*)SvRV(ST(0));
322 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
326 pkg = gv_stashsv(ST(0), FALSE);
329 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
331 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
332 SV *nsv = sv_newmortal();
338 sv = (SV*)&PL_sv_undef;
349 "%s does not define $%s::VERSION--version check failed",
350 HvNAME(pkg), HvNAME(pkg));
352 char *str = SvPVx(ST(0), len);
355 "%s defines neither package nor VERSION--version check failed", str);
358 if ( !sv_derived_from(sv, "version"))
359 sv = new_version(sv);
361 if ( !sv_derived_from(req, "version"))
362 req = new_version(req);
364 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
366 "%s version %"SVf" required--this is only version %"SVf,
367 HvNAME(pkg), req, sv);
379 Perl_croak(aTHX_ "Usage: version::new(class, version)");
382 /* char * class = (char *)SvPV_nolen(ST(0)); */
386 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
387 version = Perl_newSVpvf(aTHX_ "v%s",vs);
390 PUSHs(new_version(version));
396 XS(XS_version_stringify)
400 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
405 if (sv_derived_from(ST(0), "version")) {
406 SV *tmp = SvRV(ST(0));
410 Perl_croak(aTHX_ "lobj is not of type version");
413 PUSHs(vstringify(lobj));
421 XS(XS_version_numify)
425 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
430 if (sv_derived_from(ST(0), "version")) {
431 SV *tmp = SvRV(ST(0));
435 Perl_croak(aTHX_ "lobj is not of type version");
438 PUSHs(vnumify(lobj));
450 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
455 if (sv_derived_from(ST(0), "version")) {
456 SV *tmp = SvRV(ST(0));
460 Perl_croak(aTHX_ "lobj is not of type version");
466 IV swap = (IV)SvIV(ST(2));
468 if ( ! sv_derived_from(robj, "version") )
470 robj = new_version(robj);
476 rs = newSViv(vcmp(rvs,lobj));
480 rs = newSViv(vcmp(lobj,rvs));
491 XS(XS_version_boolean)
495 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
500 if (sv_derived_from(ST(0), "version")) {
501 SV *tmp = SvRV(ST(0));
505 Perl_croak(aTHX_ "lobj is not of type version");
509 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
522 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
526 if (sv_derived_from(ST(0), "version")) {
527 SV *tmp = SvRV(ST(0));
531 Perl_croak(aTHX_ "lobj is not of type version");
534 Perl_croak(aTHX_ "operation not supported with version object");
541 XS(XS_version_is_alpha)
545 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
550 if (sv_derived_from(ST(0), "version")) {
551 SV *tmp = SvRV(ST(0));
555 Perl_croak(aTHX_ "lobj is not of type version");
557 I32 len = av_len((AV *)lobj);
558 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
573 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
590 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
595 char *s = SvPV(sv,len);
596 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
609 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
622 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
627 RETVAL = sv_utf8_decode(sv);
628 ST(0) = boolSV(RETVAL);
638 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
644 RETVAL = sv_utf8_upgrade(sv);
645 XSprePUSH; PUSHi((IV)RETVAL);
650 XS(XS_utf8_downgrade)
653 if (items < 1 || items > 2)
654 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
663 failok = (int)SvIV(ST(1));
666 RETVAL = sv_utf8_downgrade(sv, failok);
667 ST(0) = boolSV(RETVAL);
673 XS(XS_utf8_native_to_unicode)
679 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
681 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
685 XS(XS_utf8_unicode_to_native)
691 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
693 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
697 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
700 SV *sv = SvRV(ST(0));
707 else if (items == 2) {
713 /* I hope you really know what you are doing. */
718 XSRETURN_UNDEF; /* Can't happen. */
721 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
724 SV *sv = SvRV(ST(0));
726 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
727 else if (items == 2) {
728 /* I hope you really know what you are doing. */
729 SvREFCNT(sv) = SvIV(ST(1));
730 XSRETURN_IV(SvREFCNT(sv));
732 XSRETURN_UNDEF; /* Can't happen. */
735 /* Maybe this should return the number of placeholders found in scalar context,
736 and a list of them in list context. */
737 XS(XS_Internals_hv_clear_placehold)
740 HV *hv = (HV *) SvRV(ST(0));
742 /* I don't care how many parameters were passed in, but I want to avoid
743 the unused variable warning. */
745 items = (I32)HvPLACEHOLDERS(hv);
749 I32 riter = HvRITER(hv);
750 HE *eiter = HvEITER(hv);
752 /* This may look suboptimal with the items *after* the iternext, but
753 it's quite deliberate. We only get here with items==0 if we've
754 just deleted the last placeholder in the hash. If we've just done
755 that then it means that the hash is in lazy delete mode, and the
756 HE is now only referenced in our iterator. If we just quit the loop
757 and discarded our iterator then the HE leaks. So we do the && the
758 other way to ensure iternext is called just one more time, which
759 has the side effect of triggering the lazy delete. */
760 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
762 SV *val = hv_iterval(hv, entry);
764 if (val == &PL_sv_placeholder) {
766 /* It seems that I have to go back in the front of the hash
767 API to delete a hash, even though I have a HE structure
768 pointing to the very entry I want to delete, and could hold
769 onto the previous HE that points to it. And it's easier to
770 go in with SVs as I can then specify the precomputed hash,
771 and don't have fun and games with utf8 keys. */
772 SV *key = hv_iterkeysv(entry);
774 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
785 XS(XS_Regexp_DESTROY)
790 XS(XS_PerlIO_get_layers)
793 if (items < 1 || items % 2 == 0)
794 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
801 bool details = FALSE;
806 for (svp = MARK + 2; svp <= SP; svp += 2) {
810 char *key = SvPV(*varp, klen);
814 if (klen == 5 && memEQ(key, "input", 5)) {
815 input = SvTRUE(*valp);
820 if (klen == 6 && memEQ(key, "output", 6)) {
821 input = !SvTRUE(*valp);
826 if (klen == 7 && memEQ(key, "details", 7)) {
827 details = SvTRUE(*valp);
834 "get_layers: unknown argument '%s'",
846 if (SvROK(sv) && isGV(SvRV(sv)))
849 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
852 if (gv && (io = GvIO(gv))) {
854 AV* av = PerlIO_get_layers(aTHX_ input ?
855 IoIFP(io) : IoOFP(io));
857 I32 last = av_len(av);
860 for (i = last; i >= 0; i -= 3) {
864 bool namok, argok, flgok;
866 namsvp = av_fetch(av, i - 2, FALSE);
867 argsvp = av_fetch(av, i - 1, FALSE);
868 flgsvp = av_fetch(av, i, FALSE);
870 namok = namsvp && *namsvp && SvPOK(*namsvp);
871 argok = argsvp && *argsvp && SvPOK(*argsvp);
872 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
876 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
878 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
880 XPUSHi(SvIVX(*flgsvp));
882 XPUSHs(&PL_sv_undef);
887 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
890 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
892 XPUSHs(&PL_sv_undef);
895 IV flags = SvIVX(*flgsvp);
897 if (flags & PERLIO_F_UTF8) {
898 XPUSHs(newSVpvn("utf8", 4));
915 XS(XS_Internals_hash_seed)
917 /* Using dXSARGS would also have dITEM and dSP,
918 * which define 2 unused local variables. */
920 XSRETURN_UV(PERL_HASH_SEED);
923 XS(XS_Internals_rehash_seed)
925 /* Using dXSARGS would also have dITEM and dSP,
926 * which define 2 unused local variables. */
928 XSRETURN_UV(PL_rehash_seed);
931 XS(XS_Internals_HvREHASH) /* Subject to change */
935 HV *hv = (HV *) SvRV(ST(0));
936 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
943 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");