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);
178 XS(XS_utf8_downgrade);
179 XS(XS_utf8_unicode_to_native);
180 XS(XS_utf8_native_to_unicode);
181 XS(XS_Internals_SvREADONLY);
182 XS(XS_Internals_SvREFCNT);
183 XS(XS_Internals_hv_clear_placehold);
184 XS(XS_PerlIO_get_layers);
187 Perl_boot_core_UNIVERSAL(pTHX)
189 char *file = __FILE__;
191 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
192 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
193 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
195 /* register the overloading (type 'A') magic */
196 PL_amagic_generation++;
197 /* Make it findable via fetchmethod */
198 newXS("version::()", XS_version_noop, file);
199 newXS("version::new", XS_version_new, file);
200 newXS("version::(\"\"", XS_version_stringify, file);
201 newXS("version::stringify", XS_version_stringify, file);
202 newXS("version::(0+", XS_version_numify, file);
203 newXS("version::numify", XS_version_numify, file);
204 newXS("version::(cmp", XS_version_vcmp, file);
205 newXS("version::(<=>", XS_version_vcmp, file);
206 newXS("version::vcmp", XS_version_vcmp, file);
207 newXS("version::(bool", XS_version_boolean, file);
208 newXS("version::boolean", XS_version_boolean, file);
209 newXS("version::(nomethod", XS_version_noop, file);
210 newXS("version::noop", XS_version_noop, file);
212 newXS("utf8::valid", XS_utf8_valid, file);
213 newXS("utf8::encode", XS_utf8_encode, file);
214 newXS("utf8::decode", XS_utf8_decode, file);
215 newXS("utf8::upgrade", XS_utf8_upgrade, file);
216 newXS("utf8::downgrade", XS_utf8_downgrade, file);
217 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
218 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
219 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
220 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
221 newXSproto("Internals::hv_clear_placeholders",
222 XS_Internals_hv_clear_placehold, file, "\\%");
223 newXSproto("PerlIO::get_layers",
224 XS_PerlIO_get_layers, file, "*;@");
236 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
243 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
244 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
247 name = (char *)SvPV(ST(1),n_a);
249 ST(0) = boolSV(sv_derived_from(sv, name));
263 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
270 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
271 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
274 name = (char *)SvPV(ST(1),n_a);
283 pkg = gv_stashsv(sv, FALSE);
287 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
289 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
296 XS(XS_UNIVERSAL_VERSION)
306 sv = (SV*)SvRV(ST(0));
308 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
312 pkg = gv_stashsv(ST(0), FALSE);
315 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
317 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
318 SV *nsv = sv_newmortal();
324 sv = (SV*)&PL_sv_undef;
335 "%s does not define $%s::VERSION--version check failed",
336 HvNAME(pkg), HvNAME(pkg));
338 char *str = SvPVx(ST(0), len);
341 "%s defines neither package nor VERSION--version check failed", str);
344 if ( !sv_derived_from(sv, "version"))
345 sv = new_version(sv);
347 if ( !sv_derived_from(req, "version"))
348 req = new_version(req);
350 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
352 "%s version %"SVf" required--this is only version %"SVf,
353 HvNAME(pkg), req, sv);
365 Perl_croak(aTHX_ "Usage: version::new(class, version)");
368 /* char * class = (char *)SvPV_nolen(ST(0)); */
372 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
373 version = Perl_newSVpvf(aTHX_ "v%s",vs);
376 PUSHs(new_version(version));
382 XS(XS_version_stringify)
386 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
391 if (sv_derived_from(ST(0), "version")) {
392 SV *tmp = SvRV(ST(0));
396 Perl_croak(aTHX_ "lobj is not of type version");
399 PUSHs(vstringify(lobj));
407 XS(XS_version_numify)
411 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
416 if (sv_derived_from(ST(0), "version")) {
417 SV *tmp = SvRV(ST(0));
421 Perl_croak(aTHX_ "lobj is not of type version");
424 PUSHs(vnumify(lobj));
436 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
441 if (sv_derived_from(ST(0), "version")) {
442 SV *tmp = SvRV(ST(0));
446 Perl_croak(aTHX_ "lobj is not of type version");
452 IV swap = (IV)SvIV(ST(2));
454 if ( ! sv_derived_from(robj, "version") )
456 robj = new_version(robj);
462 rs = newSViv(vcmp(rvs,lobj));
466 rs = newSViv(vcmp(lobj,rvs));
477 XS(XS_version_boolean)
481 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
486 if (sv_derived_from(ST(0), "version")) {
487 SV *tmp = SvRV(ST(0));
491 Perl_croak(aTHX_ "lobj is not of type version");
495 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
508 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
512 if (sv_derived_from(ST(0), "version")) {
513 SV *tmp = SvRV(ST(0));
517 Perl_croak(aTHX_ "lobj is not of type version");
520 Perl_croak(aTHX_ "operation not supported with version object");
531 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
536 char *s = SvPV(sv,len);
537 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
550 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
563 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
568 RETVAL = sv_utf8_decode(sv);
569 ST(0) = boolSV(RETVAL);
579 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
585 RETVAL = sv_utf8_upgrade(sv);
586 XSprePUSH; PUSHi((IV)RETVAL);
591 XS(XS_utf8_downgrade)
594 if (items < 1 || items > 2)
595 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
604 failok = (int)SvIV(ST(1));
607 RETVAL = sv_utf8_downgrade(sv, failok);
608 ST(0) = boolSV(RETVAL);
614 XS(XS_utf8_native_to_unicode)
620 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
622 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
626 XS(XS_utf8_unicode_to_native)
632 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
634 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
638 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
641 SV *sv = SvRV(ST(0));
648 else if (items == 2) {
654 /* I hope you really know what you are doing. */
659 XSRETURN_UNDEF; /* Can't happen. */
662 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
665 SV *sv = SvRV(ST(0));
667 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
668 else if (items == 2) {
669 /* I hope you really know what you are doing. */
670 SvREFCNT(sv) = SvIV(ST(1));
671 XSRETURN_IV(SvREFCNT(sv));
673 XSRETURN_UNDEF; /* Can't happen. */
676 /* Maybe this should return the number of placeholders found in scalar context,
677 and a list of them in list context. */
678 XS(XS_Internals_hv_clear_placehold)
681 HV *hv = (HV *) SvRV(ST(0));
683 /* I don't care how many parameters were passed in, but I want to avoid
684 the unused variable warning. */
686 items = (I32)HvPLACEHOLDERS(hv);
690 I32 riter = HvRITER(hv);
691 HE *eiter = HvEITER(hv);
693 /* This may look suboptimal with the items *after* the iternext, but
694 it's quite deliberate. We only get here with items==0 if we've
695 just deleted the last placeholder in the hash. If we've just done
696 that then it means that the hash is in lazy delete mode, and the
697 HE is now only referenced in our iterator. If we just quit the loop
698 and discarded our iterator then the HE leaks. So we do the && the
699 other way to ensure iternext is called just one more time, which
700 has the side effect of triggering the lazy delete. */
701 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
703 SV *val = hv_iterval(hv, entry);
705 if (val == &PL_sv_undef) {
707 /* It seems that I have to go back in the front of the hash
708 API to delete a hash, even though I have a HE structure
709 pointing to the very entry I want to delete, and could hold
710 onto the previous HE that points to it. And it's easier to
711 go in with SVs as I can then specify the precomputed hash,
712 and don't have fun and games with utf8 keys. */
713 SV *key = hv_iterkeysv(entry);
715 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
726 XS(XS_PerlIO_get_layers)
729 if (items < 1 || items % 2 == 0)
730 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
737 bool details = FALSE;
740 SV **popuntil = MARK + 1;
743 for (svp = MARK + 2; svp <= SP; svp += 2) {
747 char *key = SvPV(*varp, klen);
751 if (klen == 5 && memEQ(key, "input", 5)) {
752 input = SvTRUE(*valp);
757 if (klen == 6 && memEQ(key, "output", 6)) {
758 input = !SvTRUE(*valp);
763 if (klen == 7 && memEQ(key, "details", 7)) {
764 details = SvTRUE(*valp);
771 "get_layers: unknown argument '%s'",
783 if (SvROK(sv) && isGV(SvRV(sv)))
786 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
789 if (gv && (io = GvIO(gv))) {
791 AV* av = PerlIO_get_layers(aTHX_ input ?
792 IoIFP(io) : IoOFP(io));
794 I32 last = av_len(av);
797 for (i = last; i >= 0; i -= 3) {
801 bool namok, argok, flgok;
803 namsvp = av_fetch(av, i - 2, FALSE);
804 argsvp = av_fetch(av, i - 1, FALSE);
805 flgsvp = av_fetch(av, i, FALSE);
807 namok = namsvp && *namsvp && SvPOK(*namsvp);
808 argok = argsvp && *argsvp && SvPOK(*argsvp);
809 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
813 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
815 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
817 XPUSHi(SvIVX(*flgsvp));
819 XPUSHs(&PL_sv_undef);
824 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
827 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
829 XPUSHs(&PL_sv_undef);
832 IV flags = SvIVX(*flgsvp);
834 if (flags & PERLIO_F_UTF8) {
835 XPUSHs(newSVpvn("utf8", 4));