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