[perl #38955] exists(): error message on wrong argument type is incorrect (5.8.7...

[perl5.git] / universal.c

diff --git a/universal.c b/universal.c
index a6b3f6e..d03596c 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -45,6 +45,8 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stas
     const char *hvname;
     I32 items;
 
+    PERL_ARGS_ASSERT_ISA_LOOKUP;
+
     /* A stash/class can go by many names (ie. User == main::User), so 
        we compare the stash itself just in case */
     if (name_stash && ((const HV *)stash == name_stash))
@@ -91,11 +93,13 @@ normal Perl method.
 */
 
 bool
-Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
+Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 {
     dVAR;
     HV *stash;
 
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+
     SvGETMAGIC(sv);
 
     if (SvROK(sv)) {
@@ -131,13 +135,15 @@ The SV can be a Perl object or the name of a Perl class.
 #include "XSUB.h"
 
 bool
-Perl_sv_does(pTHX_ SV *sv, const char *name)
+Perl_sv_does(pTHX_ SV *sv, const char *const name)
 {
     const char *classname;
     bool does_it;
     SV *methodname;
-
     dSP;
+
+    PERL_ARGS_ASSERT_SV_DOES;
+
     ENTER;
     SAVETMPS;
 
@@ -214,6 +220,7 @@ XS(XS_re_is_regexp);
 XS(XS_re_regname);
 XS(XS_re_regnames);
 XS(XS_re_regnames_count);
+XS(XS_re_regexp_pattern);
 XS(XS_Tie_Hash_NamedCapture_FETCH);
 XS(XS_Tie_Hash_NamedCapture_STORE);
 XS(XS_Tie_Hash_NamedCapture_DELETE);
@@ -277,6 +284,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXSproto("re::regname", XS_re_regname, file, ";$$");
     newXSproto("re::regnames", XS_re_regnames, file, ";$");
     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
+    newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
     newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
     newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
     newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
@@ -967,16 +975,22 @@ XS(XS_PerlIO_get_layers)
                  const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 
                  if (details) {
+                     /* Indents of 5? Yuck.  */
+                     /* We know that PerlIO_get_layers creates a new SV for
+                        the name and flags, so we can just take a reference
+                        and "steal" it when we free the AV below.  */
                       XPUSHs(namok
-                             ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
+                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
                              : &PL_sv_undef);
                       XPUSHs(argok
-                             ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
+                             ? newSVpvn_flags(SvPVX_const(*argsvp),
+                                              SvCUR(*argsvp),
+                                              (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
+                                              | SVs_TEMP)
+                             : &PL_sv_undef);
+                      XPUSHs(namok
+                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
                              : &PL_sv_undef);
-                      if (flgok)
-                           mXPUSHi(SvIVX(*flgsvp));
-                      else
-                           XPUSHs(&PL_sv_undef);
                       nitem += 3;
                  }
                  else {
@@ -985,8 +999,7 @@ XS(XS_PerlIO_get_layers)
                                                 SVfARG(*namsvp),
                                                 SVfARG(*argsvp))));
                       else if (namok)
-                           XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
-                                                SVfARG(*namsvp))));
+                          XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
                       else
                            XPUSHs(&PL_sv_undef);
                       nitem++;
@@ -1187,6 +1200,97 @@ XS(XS_re_regnames)
     return;
 }
 
+XS(XS_re_regexp_pattern)
+{
+    dVAR;
+    dXSARGS;
+    REGEXP *re;
+    PERL_UNUSED_ARG(cv);
+
+    if (items != 1)
+       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
+
+    SP -= items;
+
+    /*
+       Checks if a reference is a regex or not. If the parameter is
+       not a ref, or is not the result of a qr// then returns false
+       in scalar context and an empty list in list context.
+       Otherwise in list context it returns the pattern and the
+       modifiers, in scalar context it returns the pattern just as it
+       would if the qr// was stringified normally, regardless as
+       to the class of the variable and any strigification overloads
+       on the object.
+    */
+
+    if ((re = SvRX(ST(0)))) /* assign deliberate */
+    {
+        /* Housten, we have a regex! */
+        SV *pattern;
+        STRLEN left = 0;
+        char reflags[6];
+
+        if ( GIMME_V == G_ARRAY ) {
+            /*
+               we are in list context so stringify
+               the modifiers that apply. We ignore "negative
+               modifiers" in this scenario.
+            */
+
+            const char *fptr = INT_PAT_MODS;
+            char ch;
+            U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
+                                    >> RXf_PMf_STD_PMMOD_SHIFT);
+
+            while((ch = *fptr++)) {
+                if(match_flags & 1) {
+                    reflags[left++] = ch;
+                }
+                match_flags >>= 1;
+            }
+
+            pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
+                                    (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
+
+            /* return the pattern and the modifiers */
+            XPUSHs(pattern);
+            XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
+            XSRETURN(2);
+        } else {
+            /* Scalar, so use the string that Perl would return */
+            /* return the pattern in (?msix:..) format */
+#if PERL_VERSION >= 11
+            pattern = sv_2mortal(newSVsv((SV*)re));
+#else
+            pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
+                                    (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
+#endif
+            XPUSHs(pattern);
+            XSRETURN(1);
+        }
+    } else {
+        /* It ain't a regexp folks */
+        if ( GIMME_V == G_ARRAY ) {
+            /* return the empty list */
+            XSRETURN_UNDEF;
+        } else {
+            /* Because of the (?:..) wrapping involved in a
+               stringified pattern it is impossible to get a
+               result for a real regexp that would evaluate to
+               false. Therefore we can return PL_sv_no to signify
+               that the object is not a regex, this means that one
+               can say
+
+                 if (regex($might_be_a_regex) eq '(?:foo)') { }
+
+               and not worry about undefined values.
+            */
+            XSRETURN_NO;
+        }
+    }
+    /* NOT-REACHED */
+}
+
 XS(XS_Tie_Hash_NamedCapture_FETCH)
 {
     dVAR;