3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 * 2005, 2006, 2007, 2008 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 history
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
19 /* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
22 * It is also used to store XS functions that need to be present in
23 * miniperl for a lack of a better place to put them. It might be
24 * clever to move them to separate XS files which would then be pulled
25 * in by some to-be-written build process.
29 #define PERL_IN_UNIVERSAL_C
32 #if defined(USE_PERLIO)
33 #include "perliol.h" /* For the PERLIO_F_XXX */
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
45 const struct mro_meta *const meta = HvMROMETA(stash);
49 PERL_ARGS_ASSERT_ISA_LOOKUP;
52 (void)mro_get_linear_isa(stash);
56 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
57 HV_FETCH_ISEXISTS, NULL, 0)) {
58 /* Direct name lookup worked. */
62 /* A stash/class can go by many names (ie. User == main::User), so
63 we use the HvENAME in the stash itself, which is canonical, falling
64 back to HvNAME if necessary. */
65 our_stash = gv_stashpvn(name, len, flags);
68 HEK *canon_name = HvENAME_HEK(our_stash);
69 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
71 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
72 HEK_FLAGS(canon_name),
73 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
82 =head1 SV Manipulation Functions
84 =for apidoc sv_derived_from_pvn
86 Returns a boolean indicating whether the SV is derived from the specified class
87 I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
90 Currently, the only significant value for C<flags> is SVf_UTF8.
94 =for apidoc sv_derived_from_sv
96 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
97 of an SV instead of a string/length pair.
104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
108 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
109 namepv = SvPV(namesv, namelen);
112 return sv_derived_from_pvn(sv, namepv, namelen, flags);
116 =for apidoc sv_derived_from
118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
126 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
127 return sv_derived_from_pvn(sv, name, strlen(name), 0);
131 =for apidoc sv_derived_from_pv
133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
134 instead of a string/length pair.
141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
143 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
144 return sv_derived_from_pvn(sv, name, strlen(name), flags);
148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
153 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
160 type = sv_reftype(sv,0);
161 if (type && strEQ(type,name))
168 stash = gv_stashsv(sv, 0);
171 if (stash && isa_lookup(stash, name, len, flags))
174 stash = gv_stashpvs("UNIVERSAL", 0);
175 return stash && isa_lookup(stash, name, len, flags);
179 =for apidoc sv_does_sv
181 Returns a boolean indicating whether the SV performs a specific, named role.
182 The SV can be a Perl object or the name of a Perl class.
190 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
197 PERL_ARGS_ASSERT_SV_DOES_SV;
198 PERL_UNUSED_ARG(flags);
205 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
210 if (sv_isobject(sv)) {
211 classname = sv_ref(NULL,SvRV(sv),TRUE);
216 if (sv_eq(classname, namesv)) {
227 methodname = newSVpvs_flags("isa", SVs_TEMP);
228 /* ugly hack: use the SvSCREAM flag so S_method_common
229 * can figure out we're calling DOES() and not isa(),
230 * and report eventual errors correctly. --rgs */
231 SvSCREAM_on(methodname);
232 call_sv(methodname, G_SCALAR | G_METHOD);
235 does_it = SvTRUE( TOPs );
245 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
251 Perl_sv_does(pTHX_ SV *sv, const char *const name)
253 PERL_ARGS_ASSERT_SV_DOES;
254 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
258 =for apidoc sv_does_pv
260 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
267 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
269 PERL_ARGS_ASSERT_SV_DOES_PV;
270 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
274 =for apidoc sv_does_pvn
276 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
282 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
284 PERL_ARGS_ASSERT_SV_DOES_PVN;
286 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
290 =for apidoc croak_xs_usage
292 A specialised variant of C<croak()> for emitting the usage message for xsubs
294 croak_xs_usage(cv, "eee_yow");
296 works out the package name and subroutine name from C<cv>, and then calls
297 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
299 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
305 Perl_croak_xs_usage(const CV *const cv, const char *const params)
307 const GV *const gv = CvGV(cv);
309 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
312 const HV *const stash = GvSTASH(gv);
314 if (HvNAME_get(stash))
315 /* diag_listed_as: SKIPME */
316 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
317 HEKfARG(HvNAME_HEK(stash)),
318 HEKfARG(GvNAME_HEK(gv)),
321 /* diag_listed_as: SKIPME */
322 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
323 HEKfARG(GvNAME_HEK(gv)), params);
325 /* Pants. I don't think that it should be possible to get here. */
326 /* diag_listed_as: SKIPME */
327 Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
331 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
338 croak_xs_usage(cv, "reference, kind");
340 SV * const sv = ST(0);
344 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
347 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
352 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
363 croak_xs_usage(cv, "object-ref, method");
369 /* Reject undef and empty string. Note that the string form takes
370 precedence here over the numeric form, as (!1)->foo treats the
371 invocant as the empty string, though it is a dualvar. */
372 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
378 sv = MUTABLE_SV(SvRV(sv));
381 else if (isGV_with_GP(sv) && GvIO(sv))
382 pkg = SvSTASH(GvIO(sv));
384 else if (isGV_with_GP(sv) && GvIO(sv))
385 pkg = SvSTASH(GvIO(sv));
386 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
387 pkg = SvSTASH(GvIO(iogv));
389 pkg = gv_stashsv(sv, 0);
391 pkg = gv_stashpv("UNIVERSAL", 0);
395 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
397 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
404 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
405 XS(XS_UNIVERSAL_DOES)
412 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
414 SV * const sv = ST(0);
415 if (sv_does_sv( sv, ST(1), 0 ))
422 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
428 croak_xs_usage(cv, "sv");
430 SV * const sv = ST(0);
440 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
446 croak_xs_usage(cv, "sv");
448 SV * const sv = ST(0);
450 const char * const s = SvPV_const(sv,len);
451 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
459 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
465 croak_xs_usage(cv, "sv");
466 sv_utf8_encode(ST(0));
471 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
477 croak_xs_usage(cv, "sv");
479 SV * const sv = ST(0);
481 SvPV_force_nolen(sv);
482 RETVAL = sv_utf8_decode(sv);
484 ST(0) = boolSV(RETVAL);
489 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
495 croak_xs_usage(cv, "sv");
497 SV * const sv = ST(0);
501 RETVAL = sv_utf8_upgrade(sv);
502 XSprePUSH; PUSHi((IV)RETVAL);
507 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
508 XS(XS_utf8_downgrade)
512 if (items < 1 || items > 2)
513 croak_xs_usage(cv, "sv, failok=0");
515 SV * const sv = ST(0);
516 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
517 const bool RETVAL = sv_utf8_downgrade(sv, failok);
519 ST(0) = boolSV(RETVAL);
524 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
525 XS(XS_utf8_native_to_unicode)
529 const UV uv = SvUV(ST(0));
532 croak_xs_usage(cv, "sv");
534 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
538 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
539 XS(XS_utf8_unicode_to_native)
543 const UV uv = SvUV(ST(0));
546 croak_xs_usage(cv, "sv");
548 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
552 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
553 XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
557 SV * const svz = ST(0);
561 /* [perl #77776] - called as &foo() not foo() */
563 croak_xs_usage(cv, "SCALAR[, ON]");
573 else if (items == 2) {
575 #ifdef PERL_OLD_COPY_ON_WRITE
576 if (SvIsCOW(sv)) sv_force_normal(sv);
582 /* I hope you really know what you are doing. */
587 XSRETURN_UNDEF; /* Can't happen. */
590 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
591 XS(XS_constant__make_const) /* This is dangerous stuff. */
595 SV * const svz = ST(0);
599 /* [perl #77776] - called as &foo() not foo() */
600 if (!SvROK(svz) || items != 1)
601 croak_xs_usage(cv, "SCALAR");
605 #ifdef PERL_OLD_COPY_ON_WRITE
606 if (SvIsCOW(sv)) sv_force_normal(sv);
609 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
610 /* for constant.pm; nobody else should be calling this
613 for (svp = AvARRAY(sv) + AvFILLp(sv)
616 if (*svp) SvPADTMP_on(*svp);
621 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
622 XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
626 SV * const svz = ST(0);
631 /* [perl #77776] - called as &foo() not foo() */
632 if ((items != 1 && items != 2) || !SvROK(svz))
633 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
637 /* I hope you really know what you are doing. */
638 /* idea is for SvREFCNT(sv) to be accessed only once */
639 refcnt = items == 2 ?
640 /* we free one ref on exit */
641 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
643 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
647 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
648 XS(XS_Internals_hv_clear_placehold)
653 if (items != 1 || !SvROK(ST(0)))
654 croak_xs_usage(cv, "hv");
656 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
657 hv_clear_placeholders(hv);
662 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
663 XS(XS_PerlIO_get_layers)
667 if (items < 1 || items % 2 == 0)
668 croak_xs_usage(cv, "filehandle[,args]");
669 #if defined(USE_PERLIO)
675 bool details = FALSE;
679 for (svp = MARK + 2; svp <= SP; svp += 2) {
680 SV * const * const varp = svp;
681 SV * const * const valp = svp + 1;
683 const char * const key = SvPV_const(*varp, klen);
687 if (klen == 5 && memEQ(key, "input", 5)) {
688 input = SvTRUE(*valp);
693 if (klen == 6 && memEQ(key, "output", 6)) {
694 input = !SvTRUE(*valp);
699 if (klen == 7 && memEQ(key, "details", 7)) {
700 details = SvTRUE(*valp);
707 "get_layers: unknown argument '%s'",
716 gv = MAYBE_DEREF_GV(sv);
718 if (!gv && !SvROK(sv))
719 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
721 if (gv && (io = GvIO(gv))) {
722 AV* const av = PerlIO_get_layers(aTHX_ input ?
723 IoIFP(io) : IoOFP(io));
725 const SSize_t last = av_tindex(av);
728 for (i = last; i >= 0; i -= 3) {
729 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
730 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
731 SV * const * const flgsvp = av_fetch(av, i, FALSE);
733 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
734 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
735 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
737 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
739 /* Indents of 5? Yuck. */
740 /* We know that PerlIO_get_layers creates a new SV for
741 the name and flags, so we can just take a reference
742 and "steal" it when we free the AV below. */
744 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
747 ? newSVpvn_flags(SvPVX_const(*argsvp),
749 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
753 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
759 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
763 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
768 const IV flags = SvIVX(*flgsvp);
770 if (flags & PERLIO_F_UTF8) {
771 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
789 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
797 croak_xs_usage(cv, "sv");
806 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
807 XS(XS_re_regnames_count)
809 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
815 croak_xs_usage(cv, "");
823 ret = CALLREG_NAMED_BUFF_COUNT(rx);
826 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
830 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
839 if (items < 1 || items > 2)
840 croak_xs_usage(cv, "name[, all ]");
845 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
850 if (items == 2 && SvTRUE(ST(1))) {
855 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
858 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
863 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
877 croak_xs_usage(cv, "[all]");
879 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
884 if (items == 1 && SvTRUE(ST(0))) {
893 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
900 av = MUTABLE_AV(SvRV(ret));
901 length = av_tindex(av);
903 EXTEND(SP, length+1); /* better extend stack just once */
904 for (i = 0; i <= length; i++) {
905 entry = av_fetch(av, i, FALSE);
908 Perl_croak(aTHX_ "NULL array element in re::regnames()");
910 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
919 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
920 XS(XS_re_regexp_pattern)
929 croak_xs_usage(cv, "sv");
932 Checks if a reference is a regex or not. If the parameter is
933 not a ref, or is not the result of a qr// then returns false
934 in scalar context and an empty list in list context.
935 Otherwise in list context it returns the pattern and the
936 modifiers, in scalar context it returns the pattern just as it
937 would if the qr// was stringified normally, regardless as
938 to the class of the variable and any stringification overloads
942 if ((re = SvRX(ST(0)))) /* assign deliberate */
944 /* Houston, we have a regex! */
947 if ( GIMME_V == G_ARRAY ) {
949 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
955 we are in list context so stringify
956 the modifiers that apply. We ignore "negative
957 modifiers" in this scenario, and the default character set
960 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
962 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
964 Copy(name, reflags + left, len, char);
968 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
969 >> RXf_PMf_STD_PMMOD_SHIFT);
971 while((ch = *fptr++)) {
972 if(match_flags & 1) {
973 reflags[left++] = ch;
978 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
979 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
981 /* return the pattern and the modifiers */
983 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
986 /* Scalar, so use the string that Perl would return */
987 /* return the pattern in (?msix:..) format */
988 #if PERL_VERSION >= 11
989 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
991 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
992 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
998 /* It ain't a regexp folks */
999 if ( GIMME_V == G_ARRAY ) {
1000 /* return the empty list */
1003 /* Because of the (?:..) wrapping involved in a
1004 stringified pattern it is impossible to get a
1005 result for a real regexp that would evaluate to
1006 false. Therefore we can return PL_sv_no to signify
1007 that the object is not a regex, this means that one
1010 if (regex($might_be_a_regex) eq '(?:foo)') { }
1012 and not worry about undefined values.
1023 struct xsub_details {
1029 static const struct xsub_details details[] = {
1030 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1031 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1032 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1033 #define VXS_XSUB_DETAILS
1035 #undef VXS_XSUB_DETAILS
1036 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1037 {"utf8::valid", XS_utf8_valid, NULL},
1038 {"utf8::encode", XS_utf8_encode, NULL},
1039 {"utf8::decode", XS_utf8_decode, NULL},
1040 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1041 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1042 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1043 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1044 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1045 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1046 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1047 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1048 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1049 {"re::is_regexp", XS_re_is_regexp, "$"},
1050 {"re::regname", XS_re_regname, ";$$"},
1051 {"re::regnames", XS_re_regnames, ";$"},
1052 {"re::regnames_count", XS_re_regnames_count, ""},
1053 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1057 Perl_boot_core_UNIVERSAL(pTHX)
1060 static const char file[] = __FILE__;
1061 const struct xsub_details *xsub = details;
1062 const struct xsub_details *end = C_ARRAY_END(details);
1065 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1066 } while (++xsub < end);
1068 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1071 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1072 Safefree(CvFILE(cv));
1073 CvFILE(cv) = (char *)file;
1080 * c-indentation-style: bsd
1082 * indent-tabs-mode: nil
1085 * ex: set ts=8 sts=4 sw=4 et: