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_HvREHASH);
194 Perl_boot_core_UNIVERSAL(pTHX)
196 char *file = __FILE__;
198 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
199 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
200 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
202 /* register the overloading (type 'A') magic */
203 PL_amagic_generation++;
204 /* Make it findable via fetchmethod */
205 newXS("version::()", XS_version_noop, file);
206 newXS("version::new", XS_version_new, file);
207 newXS("version::(\"\"", XS_version_stringify, file);
208 newXS("version::stringify", XS_version_stringify, file);
209 newXS("version::(0+", XS_version_numify, file);
210 newXS("version::numify", XS_version_numify, file);
211 newXS("version::(cmp", XS_version_vcmp, file);
212 newXS("version::(<=>", XS_version_vcmp, file);
213 newXS("version::vcmp", XS_version_vcmp, file);
214 newXS("version::(bool", XS_version_boolean, file);
215 newXS("version::boolean", XS_version_boolean, file);
216 newXS("version::(nomethod", XS_version_noop, file);
217 newXS("version::noop", XS_version_noop, file);
218 newXS("version::is_alpha", XS_version_is_alpha, file);
220 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
221 newXS("utf8::valid", XS_utf8_valid, file);
222 newXS("utf8::encode", XS_utf8_encode, file);
223 newXS("utf8::decode", XS_utf8_decode, file);
224 newXS("utf8::upgrade", XS_utf8_upgrade, file);
225 newXS("utf8::downgrade", XS_utf8_downgrade, file);
226 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
227 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
228 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
229 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
230 newXSproto("Internals::hv_clear_placeholders",
231 XS_Internals_hv_clear_placehold, file, "\\%");
232 newXSproto("PerlIO::get_layers",
233 XS_PerlIO_get_layers, file, "*;@");
234 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
235 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
236 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
248 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
255 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
256 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
259 name = (char *)SvPV(ST(1),n_a);
261 ST(0) = boolSV(sv_derived_from(sv, name));
275 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
282 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
283 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
286 name = (char *)SvPV(ST(1),n_a);
295 pkg = gv_stashsv(sv, FALSE);
299 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
301 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
308 XS(XS_UNIVERSAL_VERSION)
318 sv = (SV*)SvRV(ST(0));
320 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
324 pkg = gv_stashsv(ST(0), FALSE);
327 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
329 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
330 SV *nsv = sv_newmortal();
336 sv = (SV*)&PL_sv_undef;
347 "%s does not define $%s::VERSION--version check failed",
348 HvNAME(pkg), HvNAME(pkg));
350 char *str = SvPVx(ST(0), len);
353 "%s defines neither package nor VERSION--version check failed", str);
356 if ( !sv_derived_from(sv, "version"))
357 sv = new_version(sv);
359 if ( !sv_derived_from(req, "version"))
360 req = new_version(req);
362 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
364 "%s version %"SVf" required--this is only version %"SVf,
365 HvNAME(pkg), req, sv);
377 Perl_croak(aTHX_ "Usage: version::new(class, version)");
380 /* char * class = (char *)SvPV_nolen(ST(0)); */
384 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
385 version = Perl_newSVpvf(aTHX_ "v%s",vs);
388 PUSHs(new_version(version));
394 XS(XS_version_stringify)
398 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
403 if (sv_derived_from(ST(0), "version")) {
404 SV *tmp = SvRV(ST(0));
408 Perl_croak(aTHX_ "lobj is not of type version");
411 PUSHs(vstringify(lobj));
419 XS(XS_version_numify)
423 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
428 if (sv_derived_from(ST(0), "version")) {
429 SV *tmp = SvRV(ST(0));
433 Perl_croak(aTHX_ "lobj is not of type version");
436 PUSHs(vnumify(lobj));
448 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
453 if (sv_derived_from(ST(0), "version")) {
454 SV *tmp = SvRV(ST(0));
458 Perl_croak(aTHX_ "lobj is not of type version");
464 IV swap = (IV)SvIV(ST(2));
466 if ( ! sv_derived_from(robj, "version") )
468 robj = new_version(robj);
474 rs = newSViv(vcmp(rvs,lobj));
478 rs = newSViv(vcmp(lobj,rvs));
489 XS(XS_version_boolean)
493 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
498 if (sv_derived_from(ST(0), "version")) {
499 SV *tmp = SvRV(ST(0));
503 Perl_croak(aTHX_ "lobj is not of type version");
507 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
520 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
524 if (sv_derived_from(ST(0), "version")) {
525 SV *tmp = SvRV(ST(0));
529 Perl_croak(aTHX_ "lobj is not of type version");
532 Perl_croak(aTHX_ "operation not supported with version object");
539 XS(XS_version_is_alpha)
543 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
548 if (sv_derived_from(ST(0), "version")) {
549 SV *tmp = SvRV(ST(0));
553 Perl_croak(aTHX_ "lobj is not of type version");
555 I32 len = av_len((AV *)lobj);
556 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
571 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
588 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
593 char *s = SvPV(sv,len);
594 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
607 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
620 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
625 RETVAL = sv_utf8_decode(sv);
626 ST(0) = boolSV(RETVAL);
636 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
642 RETVAL = sv_utf8_upgrade(sv);
643 XSprePUSH; PUSHi((IV)RETVAL);
648 XS(XS_utf8_downgrade)
651 if (items < 1 || items > 2)
652 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
661 failok = (int)SvIV(ST(1));
664 RETVAL = sv_utf8_downgrade(sv, failok);
665 ST(0) = boolSV(RETVAL);
671 XS(XS_utf8_native_to_unicode)
677 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
679 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
683 XS(XS_utf8_unicode_to_native)
689 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
691 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
695 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
698 SV *sv = SvRV(ST(0));
705 else if (items == 2) {
711 /* I hope you really know what you are doing. */
716 XSRETURN_UNDEF; /* Can't happen. */
719 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
722 SV *sv = SvRV(ST(0));
724 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
725 else if (items == 2) {
726 /* I hope you really know what you are doing. */
727 SvREFCNT(sv) = SvIV(ST(1));
728 XSRETURN_IV(SvREFCNT(sv));
730 XSRETURN_UNDEF; /* Can't happen. */
733 /* Maybe this should return the number of placeholders found in scalar context,
734 and a list of them in list context. */
735 XS(XS_Internals_hv_clear_placehold)
738 HV *hv = (HV *) SvRV(ST(0));
740 /* I don't care how many parameters were passed in, but I want to avoid
741 the unused variable warning. */
743 items = (I32)HvPLACEHOLDERS(hv);
747 I32 riter = HvRITER(hv);
748 HE *eiter = HvEITER(hv);
750 /* This may look suboptimal with the items *after* the iternext, but
751 it's quite deliberate. We only get here with items==0 if we've
752 just deleted the last placeholder in the hash. If we've just done
753 that then it means that the hash is in lazy delete mode, and the
754 HE is now only referenced in our iterator. If we just quit the loop
755 and discarded our iterator then the HE leaks. So we do the && the
756 other way to ensure iternext is called just one more time, which
757 has the side effect of triggering the lazy delete. */
758 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
760 SV *val = hv_iterval(hv, entry);
762 if (val == &PL_sv_placeholder) {
764 /* It seems that I have to go back in the front of the hash
765 API to delete a hash, even though I have a HE structure
766 pointing to the very entry I want to delete, and could hold
767 onto the previous HE that points to it. And it's easier to
768 go in with SVs as I can then specify the precomputed hash,
769 and don't have fun and games with utf8 keys. */
770 SV *key = hv_iterkeysv(entry);
772 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
783 XS(XS_Regexp_DESTROY)
788 XS(XS_PerlIO_get_layers)
791 if (items < 1 || items % 2 == 0)
792 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
799 bool details = FALSE;
804 for (svp = MARK + 2; svp <= SP; svp += 2) {
808 char *key = SvPV(*varp, klen);
812 if (klen == 5 && memEQ(key, "input", 5)) {
813 input = SvTRUE(*valp);
818 if (klen == 6 && memEQ(key, "output", 6)) {
819 input = !SvTRUE(*valp);
824 if (klen == 7 && memEQ(key, "details", 7)) {
825 details = SvTRUE(*valp);
832 "get_layers: unknown argument '%s'",
844 if (SvROK(sv) && isGV(SvRV(sv)))
847 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
850 if (gv && (io = GvIO(gv))) {
852 AV* av = PerlIO_get_layers(aTHX_ input ?
853 IoIFP(io) : IoOFP(io));
855 I32 last = av_len(av);
858 for (i = last; i >= 0; i -= 3) {
862 bool namok, argok, flgok;
864 namsvp = av_fetch(av, i - 2, FALSE);
865 argsvp = av_fetch(av, i - 1, FALSE);
866 flgsvp = av_fetch(av, i, FALSE);
868 namok = namsvp && *namsvp && SvPOK(*namsvp);
869 argok = argsvp && *argsvp && SvPOK(*argsvp);
870 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
874 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
876 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
878 XPUSHi(SvIVX(*flgsvp));
880 XPUSHs(&PL_sv_undef);
885 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
888 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
890 XPUSHs(&PL_sv_undef);
893 IV flags = SvIVX(*flgsvp);
895 if (flags & PERLIO_F_UTF8) {
896 XPUSHs(newSVpvn("utf8", 4));
913 XS(XS_Internals_hash_seed)
915 /* Using dXSARGS would also have dITEM and dSP,
916 * which define 2 unused local variables. */
918 XSRETURN_UV(PERL_HASH_SEED);
921 XS(XS_Internals_HvREHASH) /* Subject to change */
925 HV *hv = (HV *) SvRV(ST(0));
926 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
933 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");