universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   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.
   8  *
   9  */
  10
  11 /*
  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
  15  *
  16  *     [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
  17  */
  18
  19 /* This file contains the code that implements the functions in Perl's
  20  * UNIVERSAL package, such as UNIVERSAL->can().
  21  *
  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.
  26  */
  27
  28 #include "EXTERN.h"
  29 #define PERL_IN_UNIVERSAL_C
  30 #include "perl.h"
  31
  32 #if defined(USE_PERLIO)
  33 #include "perliol.h" /* For the PERLIO_F_XXX */
  34 #endif
  35
  36 /*
  37  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  38  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  39  */
  40
  41 STATIC bool
  42 S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
  43 {
  44     dVAR;
  45     const struct mro_meta *const meta = HvMROMETA(stash);
  46     HV *isa = meta->isa;
  47     const HV *our_stash;
  48
  49     PERL_ARGS_ASSERT_ISA_LOOKUP;
  50
  51     if (!isa) {
  52         (void)mro_get_linear_isa(stash);
  53         isa = meta->isa;
  54     }
  55
  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.  */
  59         return TRUE;
  60     }
  61
  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);
  66
  67     if (our_stash) {
  68         HEK *canon_name = HvENAME_HEK(our_stash);
  69         if (!canon_name) canon_name = HvNAME_HEK(our_stash);
  70
  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))) {
  74             return TRUE;
  75         }
  76     }
  77
  78     return FALSE;
  79 }
  80
  81 /*
  82 =head1 SV Manipulation Functions
  83
  84 =for apidoc sv_derived_from_pvn
  85
  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
  88 normal Perl method.
  89
  90 Currently, the only significant value for C<flags> is SVf_UTF8.
  91
  92 =cut
  93
  94 =for apidoc sv_derived_from_sv
  95
  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.
  98
  99 =cut
 100
 101 */
 102
 103 bool
 104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 105 {
 106     char *namepv;
 107     STRLEN namelen;
 108     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
 109     namepv = SvPV(namesv, namelen);
 110     if (SvUTF8(namesv))
 111        flags |= SVf_UTF8;
 112     return sv_derived_from_pvn(sv, namepv, namelen, flags);
 113 }
 114
 115 /*
 116 =for apidoc sv_derived_from
 117
 118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
 119
 120 =cut
 121 */
 122
 123 bool
 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 125 {
 126     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
 127     return sv_derived_from_pvn(sv, name, strlen(name), 0);
 128 }
 129
 130 /*
 131 =for apidoc sv_derived_from_pv
 132
 133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
 134 instead of a string/length pair.
 135
 136 =cut
 137 */
 138
 139
 140 bool
 141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 142 {
 143     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
 144     return sv_derived_from_pvn(sv, name, strlen(name), flags);
 145 }
 146
 147 bool
 148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 149 {
 150     dVAR;
 151     HV *stash;
 152
 153     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
 154
 155     SvGETMAGIC(sv);
 156
 157     if (SvROK(sv)) {
 158         const char *type;
 159         sv = SvRV(sv);
 160         type = sv_reftype(sv,0);
 161         if (type && strEQ(type,name))
 162             return TRUE;
 163         if (!SvOBJECT(sv))
 164             return FALSE;
 165         stash = SvSTASH(sv);
 166     }
 167     else {
 168         stash = gv_stashsv(sv, 0);
 169     }
 170
 171     if (stash && isa_lookup(stash, name, len, flags))
 172         return TRUE;
 173
 174     stash = gv_stashpvs("UNIVERSAL", 0);
 175     return stash && isa_lookup(stash, name, len, flags);
 176 }
 177
 178 /*
 179 =for apidoc sv_does_sv
 180
 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.
 183
 184 =cut
 185 */
 186
 187 #include "XSUB.h"
 188
 189 bool
 190 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 191 {
 192     SV *classname;
 193     bool does_it;
 194     SV *methodname;
 195     dSP;
 196
 197     PERL_ARGS_ASSERT_SV_DOES_SV;
 198     PERL_UNUSED_ARG(flags);
 199
 200     ENTER;
 201     SAVETMPS;
 202
 203     SvGETMAGIC(sv);
 204
 205     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
 206         LEAVE;
 207         return FALSE;
 208     }
 209
 210     if (sv_isobject(sv)) {
 211         classname = sv_ref(NULL,SvRV(sv),TRUE);
 212     } else {
 213         classname = sv;
 214     }
 215
 216     if (sv_eq(classname, namesv)) {
 217         LEAVE;
 218         return TRUE;
 219     }
 220
 221     PUSHMARK(SP);
 222     EXTEND(SP, 2);
 223     PUSHs(sv);
 224     PUSHs(namesv);
 225     PUTBACK;
 226
 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);
 233     SPAGAIN;
 234
 235     does_it = SvTRUE( TOPs );
 236     FREETMPS;
 237     LEAVE;
 238
 239     return does_it;
 240 }
 241
 242 /*
 243 =for apidoc sv_does
 244
 245 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
 246
 247 =cut
 248 */
 249
 250 bool
 251 Perl_sv_does(pTHX_ SV *sv, const char *const name)
 252 {
 253     PERL_ARGS_ASSERT_SV_DOES;
 254     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
 255 }
 256
 257 /*
 258 =for apidoc sv_does_pv
 259
 260 Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
 261
 262 =cut
 263 */
 264
 265
 266 bool
 267 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 268 {
 269     PERL_ARGS_ASSERT_SV_DOES_PV;
 270     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
 271 }
 272
 273 /*
 274 =for apidoc sv_does_pvn
 275
 276 Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
 277
 278 =cut
 279 */
 280
 281 bool
 282 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 283 {
 284     PERL_ARGS_ASSERT_SV_DOES_PVN;
 285
 286     return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
 287 }
 288
 289 /*
 290 =for apidoc croak_xs_usage
 291
 292 A specialised variant of C<croak()> for emitting the usage message for xsubs
 293
 294     croak_xs_usage(cv, "eee_yow");
 295
 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:
 298
 299     Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
 300
 301 =cut
 302 */
 303
 304 void
 305 Perl_croak_xs_usage(const CV *const cv, const char *const params)
 306 {
 307     const GV *const gv = CvGV(cv);
 308
 309     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 310
 311     if (gv) {
 312         const HV *const stash = GvSTASH(gv);
 313
 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)),
 319                                 params);
 320         else
 321             /* diag_listed_as: SKIPME */
 322             Perl_croak_nocontext("Usage: %"HEKf"(%s)",
 323                                 HEKfARG(GvNAME_HEK(gv)), params);
 324     } else {
 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);
 328     }
 329 }
 330
 331 XS(XS_UNIVERSAL_isa)
 332 {
 333     dVAR;
 334     dXSARGS;
 335
 336     if (items != 2)
 337         croak_xs_usage(cv, "reference, kind");
 338     else {
 339         SV * const sv = ST(0);
 340
 341         SvGETMAGIC(sv);
 342
 343         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 344             XSRETURN_UNDEF;
 345
 346         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 347         XSRETURN(1);
 348     }
 349 }
 350
 351 XS(XS_UNIVERSAL_can)
 352 {
 353     dVAR;
 354     dXSARGS;
 355     SV   *sv;
 356     SV   *rv;
 357     HV   *pkg = NULL;
 358     GV   *iogv;
 359
 360     if (items != 2)
 361         croak_xs_usage(cv, "object-ref, method");
 362
 363     sv = ST(0);
 364
 365     SvGETMAGIC(sv);
 366
 367     /* Reject undef and empty string.  Note that the string form takes
 368        precedence here over the numeric form, as (!1)->foo treats the
 369        invocant as the empty string, though it is a dualvar. */
 370     if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
 371         XSRETURN_UNDEF;
 372
 373     rv = &PL_sv_undef;
 374
 375     if (SvROK(sv)) {
 376         sv = MUTABLE_SV(SvRV(sv));
 377         if (SvOBJECT(sv))
 378             pkg = SvSTASH(sv);
 379         else if (isGV_with_GP(sv) && GvIO(sv))
 380             pkg = SvSTASH(GvIO(sv));
 381     }
 382     else if (isGV_with_GP(sv) && GvIO(sv))
 383         pkg = SvSTASH(GvIO(sv));
 384     else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
 385         pkg = SvSTASH(GvIO(iogv));
 386     else {
 387         pkg = gv_stashsv(sv, 0);
 388         if (!pkg)
 389             pkg = gv_stashpv("UNIVERSAL", 0);
 390     }
 391
 392     if (pkg) {
 393         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
 394         if (gv && isGV(gv))
 395             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 396     }
 397
 398     ST(0) = rv;
 399     XSRETURN(1);
 400 }
 401
 402 XS(XS_UNIVERSAL_DOES)
 403 {
 404     dVAR;
 405     dXSARGS;
 406     PERL_UNUSED_ARG(cv);
 407
 408     if (items != 2)
 409         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 410     else {
 411         SV * const sv = ST(0);
 412         if (sv_does_sv( sv, ST(1), 0 ))
 413             XSRETURN_YES;
 414
 415         XSRETURN_NO;
 416     }
 417 }
 418
 419 XS(XS_utf8_is_utf8)
 420 {
 421      dVAR;
 422      dXSARGS;
 423      if (items != 1)
 424          croak_xs_usage(cv, "sv");
 425      else {
 426         SV * const sv = ST(0);
 427         SvGETMAGIC(sv);
 428             if (SvUTF8(sv))
 429                 XSRETURN_YES;
 430             else
 431                 XSRETURN_NO;
 432      }
 433      XSRETURN_EMPTY;
 434 }
 435
 436 XS(XS_utf8_valid)
 437 {
 438      dVAR;
 439      dXSARGS;
 440      if (items != 1)
 441          croak_xs_usage(cv, "sv");
 442     else {
 443         SV * const sv = ST(0);
 444         STRLEN len;
 445         const char * const s = SvPV_const(sv,len);
 446         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 447             XSRETURN_YES;
 448         else
 449             XSRETURN_NO;
 450     }
 451      XSRETURN_EMPTY;
 452 }
 453
 454 XS(XS_utf8_encode)
 455 {
 456     dVAR;
 457     dXSARGS;
 458     if (items != 1)
 459         croak_xs_usage(cv, "sv");
 460     sv_utf8_encode(ST(0));
 461     SvSETMAGIC(ST(0));
 462     XSRETURN_EMPTY;
 463 }
 464
 465 XS(XS_utf8_decode)
 466 {
 467     dVAR;
 468     dXSARGS;
 469     if (items != 1)
 470         croak_xs_usage(cv, "sv");
 471     else {
 472         SV * const sv = ST(0);
 473         bool RETVAL;
 474         SvPV_force_nolen(sv);
 475         RETVAL = sv_utf8_decode(sv);
 476         SvSETMAGIC(sv);
 477         ST(0) = boolSV(RETVAL);
 478     }
 479     XSRETURN(1);
 480 }
 481
 482 XS(XS_utf8_upgrade)
 483 {
 484     dVAR;
 485     dXSARGS;
 486     if (items != 1)
 487         croak_xs_usage(cv, "sv");
 488     else {
 489         SV * const sv = ST(0);
 490         STRLEN  RETVAL;
 491         dXSTARG;
 492
 493         RETVAL = sv_utf8_upgrade(sv);
 494         XSprePUSH; PUSHi((IV)RETVAL);
 495     }
 496     XSRETURN(1);
 497 }
 498
 499 XS(XS_utf8_downgrade)
 500 {
 501     dVAR;
 502     dXSARGS;
 503     if (items < 1 || items > 2)
 504         croak_xs_usage(cv, "sv, failok=0");
 505     else {
 506         SV * const sv = ST(0);
 507         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 508         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 509
 510         ST(0) = boolSV(RETVAL);
 511     }
 512     XSRETURN(1);
 513 }
 514
 515 XS(XS_utf8_native_to_unicode)
 516 {
 517  dVAR;
 518  dXSARGS;
 519  const UV uv = SvUV(ST(0));
 520
 521  if (items > 1)
 522      croak_xs_usage(cv, "sv");
 523
 524  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 525  XSRETURN(1);
 526 }
 527
 528 XS(XS_utf8_unicode_to_native)
 529 {
 530  dVAR;
 531  dXSARGS;
 532  const UV uv = SvUV(ST(0));
 533
 534  if (items > 1)
 535      croak_xs_usage(cv, "sv");
 536
 537  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 538  XSRETURN(1);
 539 }
 540
 541 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 542 {
 543     dVAR;
 544     dXSARGS;
 545     SV * const svz = ST(0);
 546     SV * sv;
 547     PERL_UNUSED_ARG(cv);
 548
 549     /* [perl #77776] - called as &foo() not foo() */
 550     if (!SvROK(svz))
 551         croak_xs_usage(cv, "SCALAR[, ON]");
 552
 553     sv = SvRV(svz);
 554
 555     if (items == 1) {
 556          if (SvREADONLY(sv))
 557              XSRETURN_YES;
 558          else
 559              XSRETURN_NO;
 560     }
 561     else if (items == 2) {
 562         if (SvTRUE(ST(1))) {
 563 #ifdef PERL_OLD_COPY_ON_WRITE
 564             if (SvIsCOW(sv)) sv_force_normal(sv);
 565 #endif
 566             SvREADONLY_on(sv);
 567             XSRETURN_YES;
 568         }
 569         else {
 570             /* I hope you really know what you are doing. */
 571             SvREADONLY_off(sv);
 572             XSRETURN_NO;
 573         }
 574     }
 575     XSRETURN_UNDEF; /* Can't happen. */
 576 }
 577
 578 XS(XS_constant__make_const)     /* This is dangerous stuff. */
 579 {
 580     dVAR;
 581     dXSARGS;
 582     SV * const svz = ST(0);
 583     SV * sv;
 584     PERL_UNUSED_ARG(cv);
 585
 586     /* [perl #77776] - called as &foo() not foo() */
 587     if (!SvROK(svz) || items != 1)
 588         croak_xs_usage(cv, "SCALAR");
 589
 590     sv = SvRV(svz);
 591
 592 #ifdef PERL_OLD_COPY_ON_WRITE
 593     if (SvIsCOW(sv)) sv_force_normal(sv);
 594 #endif
 595     SvREADONLY_on(sv);
 596     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 597         /* for constant.pm; nobody else should be calling this
 598            on arrays anyway. */
 599         SV **svp;
 600         for (svp = AvARRAY(sv) + AvFILLp(sv)
 601            ; svp >= AvARRAY(sv)
 602            ; --svp)
 603             if (*svp) SvPADTMP_on(*svp);
 604     }
 605     XSRETURN(0);
 606 }
 607
 608 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 609 {
 610     dVAR;
 611     dXSARGS;
 612     SV * const svz = ST(0);
 613     SV * sv;
 614     U32 refcnt;
 615     PERL_UNUSED_ARG(cv);
 616
 617     /* [perl #77776] - called as &foo() not foo() */
 618     if ((items != 1 && items != 2) || !SvROK(svz))
 619         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 620
 621     sv = SvRV(svz);
 622
 623          /* I hope you really know what you are doing. */
 624     /* idea is for SvREFCNT(sv) to be accessed only once */
 625     refcnt = items == 2 ?
 626                 /* we free one ref on exit */
 627                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
 628                 : SvREFCNT(sv);
 629     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 630
 631 }
 632
 633 XS(XS_Internals_hv_clear_placehold)
 634 {
 635     dVAR;
 636     dXSARGS;
 637
 638     if (items != 1 || !SvROK(ST(0)))
 639         croak_xs_usage(cv, "hv");
 640     else {
 641         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 642         hv_clear_placeholders(hv);
 643         XSRETURN(0);
 644     }
 645 }
 646
 647 XS(XS_PerlIO_get_layers)
 648 {
 649     dVAR;
 650     dXSARGS;
 651     if (items < 1 || items % 2 == 0)
 652         croak_xs_usage(cv, "filehandle[,args]");
 653 #if defined(USE_PERLIO)
 654     {
 655         SV *    sv;
 656         GV *    gv;
 657         IO *    io;
 658         bool    input = TRUE;
 659         bool    details = FALSE;
 660
 661         if (items > 1) {
 662              SV * const *svp;
 663              for (svp = MARK + 2; svp <= SP; svp += 2) {
 664                   SV * const * const varp = svp;
 665                   SV * const * const valp = svp + 1;
 666                   STRLEN klen;
 667                   const char * const key = SvPV_const(*varp, klen);
 668
 669                   switch (*key) {
 670                   case 'i':
 671                        if (klen == 5 && memEQ(key, "input", 5)) {
 672                             input = SvTRUE(*valp);
 673                             break;
 674                        }
 675                        goto fail;
 676                   case 'o':
 677                        if (klen == 6 && memEQ(key, "output", 6)) {
 678                             input = !SvTRUE(*valp);
 679                             break;
 680                        }
 681                        goto fail;
 682                   case 'd':
 683                        if (klen == 7 && memEQ(key, "details", 7)) {
 684                             details = SvTRUE(*valp);
 685                             break;
 686                        }
 687                        goto fail;
 688                   default:
 689                   fail:
 690                        Perl_croak(aTHX_
 691                                   "get_layers: unknown argument '%s'",
 692                                   key);
 693                   }
 694              }
 695
 696              SP -= (items - 1);
 697         }
 698
 699         sv = POPs;
 700         gv = MAYBE_DEREF_GV(sv);
 701
 702         if (!gv && !SvROK(sv))
 703             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
 704
 705         if (gv && (io = GvIO(gv))) {
 706              AV* const av = PerlIO_get_layers(aTHX_ input ?
 707                                         IoIFP(io) : IoOFP(io));
 708              SSize_t i;
 709              const SSize_t last = av_len(av);
 710              SSize_t nitem = 0;
 711
 712              for (i = last; i >= 0; i -= 3) {
 713                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 714                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 715                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 716
 717                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 718                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 719                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 720
 721                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
 722                   if (details) {
 723                       /* Indents of 5? Yuck.  */
 724                       /* We know that PerlIO_get_layers creates a new SV for
 725                          the name and flags, so we can just take a reference
 726                          and "steal" it when we free the AV below.  */
 727                        PUSHs(namok
 728                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 729                               : &PL_sv_undef);
 730                        PUSHs(argok
 731                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 732                                                SvCUR(*argsvp),
 733                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 734                                                | SVs_TEMP)
 735                               : &PL_sv_undef);
 736                        PUSHs(flgok
 737                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 738                               : &PL_sv_undef);
 739                        nitem += 3;
 740                   }
 741                   else {
 742                        if (namok && argok)
 743                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 744                                                  SVfARG(*namsvp),
 745                                                  SVfARG(*argsvp))));
 746                        else if (namok)
 747                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 748                        else
 749                             PUSHs(&PL_sv_undef);
 750                        nitem++;
 751                        if (flgok) {
 752                             const IV flags = SvIVX(*flgsvp);
 753
 754                             if (flags & PERLIO_F_UTF8) {
 755                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 756                                  nitem++;
 757                             }
 758                        }
 759                   }
 760              }
 761
 762              SvREFCNT_dec(av);
 763
 764              XSRETURN(nitem);
 765         }
 766     }
 767 #endif
 768
 769     XSRETURN(0);
 770 }
 771
 772
 773 XS(XS_re_is_regexp)
 774 {
 775     dVAR;
 776     dXSARGS;
 777     PERL_UNUSED_VAR(cv);
 778
 779     if (items != 1)
 780         croak_xs_usage(cv, "sv");
 781
 782     if (SvRXOK(ST(0))) {
 783         XSRETURN_YES;
 784     } else {
 785         XSRETURN_NO;
 786     }
 787 }
 788
 789 XS(XS_re_regnames_count)
 790 {
 791     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 792     SV * ret;
 793     dVAR;
 794     dXSARGS;
 795
 796     if (items != 0)
 797         croak_xs_usage(cv, "");
 798
 799     SP -= items;
 800     PUTBACK;
 801
 802     if (!rx)
 803         XSRETURN_UNDEF;
 804
 805     ret = CALLREG_NAMED_BUFF_COUNT(rx);
 806
 807     SPAGAIN;
 808     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 809     XSRETURN(1);
 810 }
 811
 812 XS(XS_re_regname)
 813 {
 814     dVAR;
 815     dXSARGS;
 816     REGEXP * rx;
 817     U32 flags;
 818     SV * ret;
 819
 820     if (items < 1 || items > 2)
 821         croak_xs_usage(cv, "name[, all ]");
 822
 823     SP -= items;
 824     PUTBACK;
 825
 826     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 827
 828     if (!rx)
 829         XSRETURN_UNDEF;
 830
 831     if (items == 2 && SvTRUE(ST(1))) {
 832         flags = RXapif_ALL;
 833     } else {
 834         flags = RXapif_ONE;
 835     }
 836     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 837
 838     SPAGAIN;
 839     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 840     XSRETURN(1);
 841 }
 842
 843
 844 XS(XS_re_regnames)
 845 {
 846     dVAR;
 847     dXSARGS;
 848     REGEXP * rx;
 849     U32 flags;
 850     SV *ret;
 851     AV *av;
 852     SSize_t length;
 853     SSize_t i;
 854     SV **entry;
 855
 856     if (items > 1)
 857         croak_xs_usage(cv, "[all]");
 858
 859     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 860
 861     if (!rx)
 862         XSRETURN_UNDEF;
 863
 864     if (items == 1 && SvTRUE(ST(0))) {
 865         flags = RXapif_ALL;
 866     } else {
 867         flags = RXapif_ONE;
 868     }
 869
 870     SP -= items;
 871     PUTBACK;
 872
 873     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
 874
 875     SPAGAIN;
 876
 877     if (!ret)
 878         XSRETURN_UNDEF;
 879
 880     av = MUTABLE_AV(SvRV(ret));
 881     length = av_len(av);
 882
 883     EXTEND(SP, length+1); /* better extend stack just once */
 884     for (i = 0; i <= length; i++) {
 885         entry = av_fetch(av, i, FALSE);
 886
 887         if (!entry)
 888             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 889
 890         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
 891     }
 892
 893     SvREFCNT_dec(ret);
 894
 895     PUTBACK;
 896     return;
 897 }
 898
 899 XS(XS_re_regexp_pattern)
 900 {
 901     dVAR;
 902     dXSARGS;
 903     REGEXP *re;
 904
 905     EXTEND(SP, 2);
 906     SP -= items;
 907     if (items != 1)
 908         croak_xs_usage(cv, "sv");
 909
 910     /*
 911        Checks if a reference is a regex or not. If the parameter is
 912        not a ref, or is not the result of a qr// then returns false
 913        in scalar context and an empty list in list context.
 914        Otherwise in list context it returns the pattern and the
 915        modifiers, in scalar context it returns the pattern just as it
 916        would if the qr// was stringified normally, regardless as
 917        to the class of the variable and any stringification overloads
 918        on the object.
 919     */
 920
 921     if ((re = SvRX(ST(0)))) /* assign deliberate */
 922     {
 923         /* Houston, we have a regex! */
 924         SV *pattern;
 925
 926         if ( GIMME_V == G_ARRAY ) {
 927             STRLEN left = 0;
 928             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
 929             const char *fptr;
 930             char ch;
 931             U16 match_flags;
 932
 933             /*
 934                we are in list context so stringify
 935                the modifiers that apply. We ignore "negative
 936                modifiers" in this scenario, and the default character set
 937             */
 938
 939             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
 940                 STRLEN len;
 941                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
 942                                                                 &len);
 943                 Copy(name, reflags + left, len, char);
 944                 left += len;
 945             }
 946             fptr = INT_PAT_MODS;
 947             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
 948                                     >> RXf_PMf_STD_PMMOD_SHIFT);
 949
 950             while((ch = *fptr++)) {
 951                 if(match_flags & 1) {
 952                     reflags[left++] = ch;
 953                 }
 954                 match_flags >>= 1;
 955             }
 956
 957             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
 958                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 959
 960             /* return the pattern and the modifiers */
 961             PUSHs(pattern);
 962             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
 963             XSRETURN(2);
 964         } else {
 965             /* Scalar, so use the string that Perl would return */
 966             /* return the pattern in (?msix:..) format */
 967 #if PERL_VERSION >= 11
 968             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
 969 #else
 970             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
 971                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 972 #endif
 973             PUSHs(pattern);
 974             XSRETURN(1);
 975         }
 976     } else {
 977         /* It ain't a regexp folks */
 978         if ( GIMME_V == G_ARRAY ) {
 979             /* return the empty list */
 980             XSRETURN_UNDEF;
 981         } else {
 982             /* Because of the (?:..) wrapping involved in a
 983                stringified pattern it is impossible to get a
 984                result for a real regexp that would evaluate to
 985                false. Therefore we can return PL_sv_no to signify
 986                that the object is not a regex, this means that one
 987                can say
 988
 989                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 990
 991                and not worry about undefined values.
 992             */
 993             XSRETURN_NO;
 994         }
 995     }
 996     /* NOT-REACHED */
 997 }
 998
 999 #include "vutil.h"
1000 #include "vxs.inc"
1001
1002 struct xsub_details {
1003     const char *name;
1004     XSUBADDR_t xsub;
1005     const char *proto;
1006 };
1007
1008 static const struct xsub_details details[] = {
1009     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1010     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1011     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1012 #define VXS_XSUB_DETAILS
1013 #include "vxs.inc"
1014 #undef VXS_XSUB_DETAILS
1015     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1016     {"utf8::valid", XS_utf8_valid, NULL},
1017     {"utf8::encode", XS_utf8_encode, NULL},
1018     {"utf8::decode", XS_utf8_decode, NULL},
1019     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1020     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1021     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1022     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1023     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1024     {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1025     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1026     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1027     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1028     {"re::is_regexp", XS_re_is_regexp, "$"},
1029     {"re::regname", XS_re_regname, ";$$"},
1030     {"re::regnames", XS_re_regnames, ";$"},
1031     {"re::regnames_count", XS_re_regnames_count, ""},
1032     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1033 };
1034
1035 void
1036 Perl_boot_core_UNIVERSAL(pTHX)
1037 {
1038     dVAR;
1039     static const char file[] = __FILE__;
1040     const struct xsub_details *xsub = details;
1041     const struct xsub_details *end
1042         = details + sizeof(details) / sizeof(details[0]);
1043
1044     do {
1045         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1046     } while (++xsub < end);
1047
1048     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1049     {
1050         CV * const cv =
1051             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1052         Safefree(CvFILE(cv));
1053         CvFILE(cv) = (char *)file;
1054         CvDYNFILE_off(cv);
1055     }
1056 }
1057
1058 /*
1059  * Local variables:
1060  * c-indentation-style: bsd
1061  * c-basic-offset: 4
1062  * indent-tabs-mode: nil
1063  * End:
1064  *
1065  * ex: set ts=8 sts=4 sw=4 et:
1066  */