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 newXSproto("PerlIO::get_layers",
223 XS_PerlIO_get_layers, file, "*;@");
235 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
242 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
243 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
246 name = (char *)SvPV(ST(1),n_a);
248 ST(0) = boolSV(sv_derived_from(sv, name));
262 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
269 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
270 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
273 name = (char *)SvPV(ST(1),n_a);
282 pkg = gv_stashsv(sv, FALSE);
286 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
288 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
295 XS(XS_UNIVERSAL_VERSION)
305 sv = (SV*)SvRV(ST(0));
307 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
311 pkg = gv_stashsv(ST(0), FALSE);
314 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
316 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
317 SV *nsv = sv_newmortal();
323 sv = (SV*)&PL_sv_undef;
334 "%s does not define $%s::VERSION--version check failed",
335 HvNAME(pkg), HvNAME(pkg));
337 char *str = SvPVx(ST(0), len);
340 "%s defines neither package nor VERSION--version check failed", str);
343 if ( !sv_derived_from(sv, "version"))
344 sv = new_version(sv);
346 if ( !sv_derived_from(req, "version"))
347 req = new_version(req);
349 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
351 "%s version %"SVf" required--this is only version %"SVf,
352 HvNAME(pkg), req, sv);
364 Perl_croak(aTHX_ "Usage: version::new(class, version)");
367 /* char * class = (char *)SvPV_nolen(ST(0)); */
371 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
372 version = Perl_newSVpvf(aTHX_ "v%s",vs);
375 PUSHs(new_version(version));
381 XS(XS_version_stringify)
385 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
390 if (sv_derived_from(ST(0), "version")) {
391 SV *tmp = SvRV(ST(0));
395 Perl_croak(aTHX_ "lobj is not of type version");
398 PUSHs(vstringify(lobj));
406 XS(XS_version_numify)
410 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
415 if (sv_derived_from(ST(0), "version")) {
416 SV *tmp = SvRV(ST(0));
420 Perl_croak(aTHX_ "lobj is not of type version");
423 PUSHs(vnumify(lobj));
435 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
440 if (sv_derived_from(ST(0), "version")) {
441 SV *tmp = SvRV(ST(0));
445 Perl_croak(aTHX_ "lobj is not of type version");
451 IV swap = (IV)SvIV(ST(2));
453 if ( ! sv_derived_from(robj, "version") )
455 robj = new_version(robj);
461 rs = newSViv(vcmp(rvs,lobj));
465 rs = newSViv(vcmp(lobj,rvs));
476 XS(XS_version_boolean)
480 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
485 if (sv_derived_from(ST(0), "version")) {
486 SV *tmp = SvRV(ST(0));
490 Perl_croak(aTHX_ "lobj is not of type version");
494 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
507 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
511 if (sv_derived_from(ST(0), "version")) {
512 SV *tmp = SvRV(ST(0));
516 Perl_croak(aTHX_ "lobj is not of type version");
519 Perl_croak(aTHX_ "operation not supported with version object");
530 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
535 char *s = SvPV(sv,len);
536 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
549 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
562 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
567 RETVAL = sv_utf8_decode(sv);
568 ST(0) = boolSV(RETVAL);
578 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
584 RETVAL = sv_utf8_upgrade(sv);
585 XSprePUSH; PUSHi((IV)RETVAL);
590 XS(XS_utf8_downgrade)
593 if (items < 1 || items > 2)
594 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
603 failok = (int)SvIV(ST(1));
606 RETVAL = sv_utf8_downgrade(sv, failok);
607 ST(0) = boolSV(RETVAL);
613 XS(XS_utf8_native_to_unicode)
619 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
621 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
625 XS(XS_utf8_unicode_to_native)
631 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
633 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
637 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
640 SV *sv = SvRV(ST(0));
647 else if (items == 2) {
653 /* I hope you really know what you are doing. */
658 XSRETURN_UNDEF; /* Can't happen. */
661 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
664 SV *sv = SvRV(ST(0));
666 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
667 else if (items == 2) {
668 /* I hope you really know what you are doing. */
669 SvREFCNT(sv) = SvIV(ST(1));
670 XSRETURN_IV(SvREFCNT(sv));
672 XSRETURN_UNDEF; /* Can't happen. */
675 /* Maybe this should return the number of placeholders found in scalar context,
676 and a list of them in list context. */
677 XS(XS_Internals_hv_clear_placehold)
680 HV *hv = (HV *) SvRV(ST(0));
682 /* I don't care how many parameters were passed in, but I want to avoid
683 the unused variable warning. */
685 items = (I32)HvPLACEHOLDERS(hv);
689 I32 riter = HvRITER(hv);
690 HE *eiter = HvEITER(hv);
692 /* This may look suboptimal with the items *after* the iternext, but
693 it's quite deliberate. We only get here with items==0 if we've
694 just deleted the last placeholder in the hash. If we've just done
695 that then it means that the hash is in lazy delete mode, and the
696 HE is now only referenced in our iterator. If we just quit the loop
697 and discarded our iterator then the HE leaks. So we do the && the
698 other way to ensure iternext is called just one more time, which
699 has the side effect of triggering the lazy delete. */
700 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
702 SV *val = hv_iterval(hv, entry);
704 if (val == &PL_sv_undef) {
706 /* It seems that I have to go back in the front of the hash
707 API to delete a hash, even though I have a HE structure
708 pointing to the very entry I want to delete, and could hold
709 onto the previous HE that points to it. And it's easier to
710 go in with SVs as I can then specify the precomputed hash,
711 and don't have fun and games with utf8 keys. */
712 SV *key = hv_iterkeysv(entry);
714 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
725 XS(XS_PerlIO_get_layers)
728 if (items < 1 || items % 2 == 0)
729 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
736 bool details = FALSE;
739 SV **popuntil = MARK + 1;
742 for (svp = MARK + 2; svp <= SP; svp += 2) {
746 char *key = SvPV(*varp, klen);
750 if (klen == 5 && memEQ(key, "input", 5)) {
751 input = SvTRUE(*valp);
756 if (klen == 6 && memEQ(key, "output", 6)) {
757 input = !SvTRUE(*valp);
762 if (klen == 7 && memEQ(key, "details", 7)) {
763 details = SvTRUE(*valp);
770 "get_layers: unknown argument '%s'",
782 if (SvROK(sv) && isGV(SvRV(sv)))
785 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
788 if (gv && (io = GvIO(gv))) {
790 AV* av = PerlIO_get_layers(aTHX_ input ?
791 IoIFP(io) : IoOFP(io));
793 I32 last = av_len(av);
796 for (i = last; i >= 0; i -= 3) {
800 bool namok, argok, flgok;
802 namsvp = av_fetch(av, i - 2, FALSE);
803 argsvp = av_fetch(av, i - 1, FALSE);
804 flgsvp = av_fetch(av, i, FALSE);
806 namok = namsvp && *namsvp && SvPOK(*namsvp);
807 argok = argsvp && *argsvp && SvPOK(*argsvp);
808 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
812 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
814 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
816 XPUSHi(SvIVX(*flgsvp));
818 XPUSHs(&PL_sv_undef);
823 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
826 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
828 XPUSHs(&PL_sv_undef);
831 IV flags = SvIVX(*flgsvp);
833 if (flags & PERLIO_F_UTF8) {
834 XPUSHs(newSVpvn("utf8", 4));