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         assert(canon_name);
  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); /* prototype to pass -Wmissing-prototypes */
 332 XS(XS_UNIVERSAL_isa)
 333 {
 334     dVAR;
 335     dXSARGS;
 336
 337     if (items != 2)
 338         croak_xs_usage(cv, "reference, kind");
 339     else {
 340         SV * const sv = ST(0);
 341
 342         SvGETMAGIC(sv);
 343
 344         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 345             XSRETURN_UNDEF;
 346
 347         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 348         XSRETURN(1);
 349     }
 350 }
 351
 352 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
 353 XS(XS_UNIVERSAL_can)
 354 {
 355     dVAR;
 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_stashpv("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     dVAR;
 408     dXSARGS;
 409     PERL_UNUSED_ARG(cv);
 410
 411     if (items != 2)
 412         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 413     else {
 414         SV * const sv = ST(0);
 415         if (sv_does_sv( sv, ST(1), 0 ))
 416             XSRETURN_YES;
 417
 418         XSRETURN_NO;
 419     }
 420 }
 421
 422 XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
 423 XS(XS_utf8_is_utf8)
 424 {
 425      dVAR;
 426      dXSARGS;
 427      if (items != 1)
 428          croak_xs_usage(cv, "sv");
 429      else {
 430         SV * const sv = ST(0);
 431         SvGETMAGIC(sv);
 432             if (SvUTF8(sv))
 433                 XSRETURN_YES;
 434             else
 435                 XSRETURN_NO;
 436      }
 437      XSRETURN_EMPTY;
 438 }
 439
 440 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
 441 XS(XS_utf8_valid)
 442 {
 443      dVAR;
 444      dXSARGS;
 445      if (items != 1)
 446          croak_xs_usage(cv, "sv");
 447     else {
 448         SV * const sv = ST(0);
 449         STRLEN len;
 450         const char * const s = SvPV_const(sv,len);
 451         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 452             XSRETURN_YES;
 453         else
 454             XSRETURN_NO;
 455     }
 456      XSRETURN_EMPTY;
 457 }
 458
 459 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
 460 XS(XS_utf8_encode)
 461 {
 462     dVAR;
 463     dXSARGS;
 464     if (items != 1)
 465         croak_xs_usage(cv, "sv");
 466     sv_utf8_encode(ST(0));
 467     SvSETMAGIC(ST(0));
 468     XSRETURN_EMPTY;
 469 }
 470
 471 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
 472 XS(XS_utf8_decode)
 473 {
 474     dVAR;
 475     dXSARGS;
 476     if (items != 1)
 477         croak_xs_usage(cv, "sv");
 478     else {
 479         SV * const sv = ST(0);
 480         bool RETVAL;
 481         SvPV_force_nolen(sv);
 482         RETVAL = sv_utf8_decode(sv);
 483         SvSETMAGIC(sv);
 484         ST(0) = boolSV(RETVAL);
 485     }
 486     XSRETURN(1);
 487 }
 488
 489 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
 490 XS(XS_utf8_upgrade)
 491 {
 492     dVAR;
 493     dXSARGS;
 494     if (items != 1)
 495         croak_xs_usage(cv, "sv");
 496     else {
 497         SV * const sv = ST(0);
 498         STRLEN  RETVAL;
 499         dXSTARG;
 500
 501         RETVAL = sv_utf8_upgrade(sv);
 502         XSprePUSH; PUSHi((IV)RETVAL);
 503     }
 504     XSRETURN(1);
 505 }
 506
 507 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
 508 XS(XS_utf8_downgrade)
 509 {
 510     dVAR;
 511     dXSARGS;
 512     if (items < 1 || items > 2)
 513         croak_xs_usage(cv, "sv, failok=0");
 514     else {
 515         SV * const sv = ST(0);
 516         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 517         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 518
 519         ST(0) = boolSV(RETVAL);
 520     }
 521     XSRETURN(1);
 522 }
 523
 524 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
 525 XS(XS_utf8_native_to_unicode)
 526 {
 527  dVAR;
 528  dXSARGS;
 529  const UV uv = SvUV(ST(0));
 530
 531  if (items > 1)
 532      croak_xs_usage(cv, "sv");
 533
 534  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 535  XSRETURN(1);
 536 }
 537
 538 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
 539 XS(XS_utf8_unicode_to_native)
 540 {
 541  dVAR;
 542  dXSARGS;
 543  const UV uv = SvUV(ST(0));
 544
 545  if (items > 1)
 546      croak_xs_usage(cv, "sv");
 547
 548  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 549  XSRETURN(1);
 550 }
 551
 552 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
 553 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 554 {
 555     dVAR;
 556     dXSARGS;
 557     SV * const svz = ST(0);
 558     SV * sv;
 559     PERL_UNUSED_ARG(cv);
 560
 561     /* [perl #77776] - called as &foo() not foo() */
 562     if (!SvROK(svz))
 563         croak_xs_usage(cv, "SCALAR[, ON]");
 564
 565     sv = SvRV(svz);
 566
 567     if (items == 1) {
 568          if (SvREADONLY(sv))
 569              XSRETURN_YES;
 570          else
 571              XSRETURN_NO;
 572     }
 573     else if (items == 2) {
 574         if (SvTRUE(ST(1))) {
 575 #ifdef PERL_OLD_COPY_ON_WRITE
 576             if (SvIsCOW(sv)) sv_force_normal(sv);
 577 #endif
 578             SvREADONLY_on(sv);
 579             XSRETURN_YES;
 580         }
 581         else {
 582             /* I hope you really know what you are doing. */
 583             SvREADONLY_off(sv);
 584             XSRETURN_NO;
 585         }
 586     }
 587     XSRETURN_UNDEF; /* Can't happen. */
 588 }
 589
 590 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
 591 XS(XS_constant__make_const)     /* This is dangerous stuff. */
 592 {
 593     dVAR;
 594     dXSARGS;
 595     SV * const svz = ST(0);
 596     SV * sv;
 597     PERL_UNUSED_ARG(cv);
 598
 599     /* [perl #77776] - called as &foo() not foo() */
 600     if (!SvROK(svz) || items != 1)
 601         croak_xs_usage(cv, "SCALAR");
 602
 603     sv = SvRV(svz);
 604
 605 #ifdef PERL_OLD_COPY_ON_WRITE
 606     if (SvIsCOW(sv)) sv_force_normal(sv);
 607 #endif
 608     SvREADONLY_on(sv);
 609     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 610         /* for constant.pm; nobody else should be calling this
 611            on arrays anyway. */
 612         SV **svp;
 613         for (svp = AvARRAY(sv) + AvFILLp(sv)
 614            ; svp >= AvARRAY(sv)
 615            ; --svp)
 616             if (*svp) SvPADTMP_on(*svp);
 617     }
 618     XSRETURN(0);
 619 }
 620
 621 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
 622 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 623 {
 624     dVAR;
 625     dXSARGS;
 626     SV * const svz = ST(0);
 627     SV * sv;
 628     U32 refcnt;
 629     PERL_UNUSED_ARG(cv);
 630
 631     /* [perl #77776] - called as &foo() not foo() */
 632     if ((items != 1 && items != 2) || !SvROK(svz))
 633         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 634
 635     sv = SvRV(svz);
 636
 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)
 642                 : SvREFCNT(sv);
 643     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 644
 645 }
 646
 647 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
 648 XS(XS_Internals_hv_clear_placehold)
 649 {
 650     dVAR;
 651     dXSARGS;
 652
 653     if (items != 1 || !SvROK(ST(0)))
 654         croak_xs_usage(cv, "hv");
 655     else {
 656         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 657         hv_clear_placeholders(hv);
 658         XSRETURN(0);
 659     }
 660 }
 661
 662 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
 663 XS(XS_PerlIO_get_layers)
 664 {
 665     dVAR;
 666     dXSARGS;
 667     if (items < 1 || items % 2 == 0)
 668         croak_xs_usage(cv, "filehandle[,args]");
 669 #if defined(USE_PERLIO)
 670     {
 671         SV *    sv;
 672         GV *    gv;
 673         IO *    io;
 674         bool    input = TRUE;
 675         bool    details = FALSE;
 676
 677         if (items > 1) {
 678              SV * const *svp;
 679              for (svp = MARK + 2; svp <= SP; svp += 2) {
 680                   SV * const * const varp = svp;
 681                   SV * const * const valp = svp + 1;
 682                   STRLEN klen;
 683                   const char * const key = SvPV_const(*varp, klen);
 684
 685                   switch (*key) {
 686                   case 'i':
 687                        if (klen == 5 && memEQ(key, "input", 5)) {
 688                             input = SvTRUE(*valp);
 689                             break;
 690                        }
 691                        goto fail;
 692                   case 'o':
 693                        if (klen == 6 && memEQ(key, "output", 6)) {
 694                             input = !SvTRUE(*valp);
 695                             break;
 696                        }
 697                        goto fail;
 698                   case 'd':
 699                        if (klen == 7 && memEQ(key, "details", 7)) {
 700                             details = SvTRUE(*valp);
 701                             break;
 702                        }
 703                        goto fail;
 704                   default:
 705                   fail:
 706                        Perl_croak(aTHX_
 707                                   "get_layers: unknown argument '%s'",
 708                                   key);
 709                   }
 710              }
 711
 712              SP -= (items - 1);
 713         }
 714
 715         sv = POPs;
 716         gv = MAYBE_DEREF_GV(sv);
 717
 718         if (!gv && !SvROK(sv))
 719             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
 720
 721         if (gv && (io = GvIO(gv))) {
 722              AV* const av = PerlIO_get_layers(aTHX_ input ?
 723                                         IoIFP(io) : IoOFP(io));
 724              SSize_t i;
 725              const SSize_t last = av_tindex(av);
 726              SSize_t nitem = 0;
 727
 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);
 732
 733                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 734                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 735                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 736
 737                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
 738                   if (details) {
 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.  */
 743                        PUSHs(namok
 744                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 745                               : &PL_sv_undef);
 746                        PUSHs(argok
 747                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 748                                                SvCUR(*argsvp),
 749                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 750                                                | SVs_TEMP)
 751                               : &PL_sv_undef);
 752                        PUSHs(flgok
 753                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 754                               : &PL_sv_undef);
 755                        nitem += 3;
 756                   }
 757                   else {
 758                        if (namok && argok)
 759                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 760                                                  SVfARG(*namsvp),
 761                                                  SVfARG(*argsvp))));
 762                        else if (namok)
 763                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 764                        else
 765                             PUSHs(&PL_sv_undef);
 766                        nitem++;
 767                        if (flgok) {
 768                             const IV flags = SvIVX(*flgsvp);
 769
 770                             if (flags & PERLIO_F_UTF8) {
 771                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 772                                  nitem++;
 773                             }
 774                        }
 775                   }
 776              }
 777
 778              SvREFCNT_dec(av);
 779
 780              XSRETURN(nitem);
 781         }
 782     }
 783 #endif
 784
 785     XSRETURN(0);
 786 }
 787
 788
 789 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
 790 XS(XS_re_is_regexp)
 791 {
 792     dVAR;
 793     dXSARGS;
 794     PERL_UNUSED_VAR(cv);
 795
 796     if (items != 1)
 797         croak_xs_usage(cv, "sv");
 798
 799     if (SvRXOK(ST(0))) {
 800         XSRETURN_YES;
 801     } else {
 802         XSRETURN_NO;
 803     }
 804 }
 805
 806 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
 807 XS(XS_re_regnames_count)
 808 {
 809     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 810     SV * ret;
 811     dVAR;
 812     dXSARGS;
 813
 814     if (items != 0)
 815         croak_xs_usage(cv, "");
 816
 817     SP -= items;
 818     PUTBACK;
 819
 820     if (!rx)
 821         XSRETURN_UNDEF;
 822
 823     ret = CALLREG_NAMED_BUFF_COUNT(rx);
 824
 825     SPAGAIN;
 826     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 827     XSRETURN(1);
 828 }
 829
 830 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
 831 XS(XS_re_regname)
 832 {
 833     dVAR;
 834     dXSARGS;
 835     REGEXP * rx;
 836     U32 flags;
 837     SV * ret;
 838
 839     if (items < 1 || items > 2)
 840         croak_xs_usage(cv, "name[, all ]");
 841
 842     SP -= items;
 843     PUTBACK;
 844
 845     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 846
 847     if (!rx)
 848         XSRETURN_UNDEF;
 849
 850     if (items == 2 && SvTRUE(ST(1))) {
 851         flags = RXapif_ALL;
 852     } else {
 853         flags = RXapif_ONE;
 854     }
 855     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 856
 857     SPAGAIN;
 858     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 859     XSRETURN(1);
 860 }
 861
 862
 863 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
 864 XS(XS_re_regnames)
 865 {
 866     dVAR;
 867     dXSARGS;
 868     REGEXP * rx;
 869     U32 flags;
 870     SV *ret;
 871     AV *av;
 872     SSize_t length;
 873     SSize_t i;
 874     SV **entry;
 875
 876     if (items > 1)
 877         croak_xs_usage(cv, "[all]");
 878
 879     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 880
 881     if (!rx)
 882         XSRETURN_UNDEF;
 883
 884     if (items == 1 && SvTRUE(ST(0))) {
 885         flags = RXapif_ALL;
 886     } else {
 887         flags = RXapif_ONE;
 888     }
 889
 890     SP -= items;
 891     PUTBACK;
 892
 893     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
 894
 895     SPAGAIN;
 896
 897     if (!ret)
 898         XSRETURN_UNDEF;
 899
 900     av = MUTABLE_AV(SvRV(ret));
 901     length = av_tindex(av);
 902
 903     EXTEND(SP, length+1); /* better extend stack just once */
 904     for (i = 0; i <= length; i++) {
 905         entry = av_fetch(av, i, FALSE);
 906
 907         if (!entry)
 908             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 909
 910         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
 911     }
 912
 913     SvREFCNT_dec(ret);
 914
 915     PUTBACK;
 916     return;
 917 }
 918
 919 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
 920 XS(XS_re_regexp_pattern)
 921 {
 922     dVAR;
 923     dXSARGS;
 924     REGEXP *re;
 925
 926     EXTEND(SP, 2);
 927     SP -= items;
 928     if (items != 1)
 929         croak_xs_usage(cv, "sv");
 930
 931     /*
 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
 939        on the object.
 940     */
 941
 942     if ((re = SvRX(ST(0)))) /* assign deliberate */
 943     {
 944         /* Houston, we have a regex! */
 945         SV *pattern;
 946
 947         if ( GIMME_V == G_ARRAY ) {
 948             STRLEN left = 0;
 949             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
 950             const char *fptr;
 951             char ch;
 952             U16 match_flags;
 953
 954             /*
 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
 958             */
 959
 960             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
 961                 STRLEN len;
 962                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
 963                                                                 &len);
 964                 Copy(name, reflags + left, len, char);
 965                 left += len;
 966             }
 967             fptr = INT_PAT_MODS;
 968             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
 969                                     >> RXf_PMf_STD_PMMOD_SHIFT);
 970
 971             while((ch = *fptr++)) {
 972                 if(match_flags & 1) {
 973                     reflags[left++] = ch;
 974                 }
 975                 match_flags >>= 1;
 976             }
 977
 978             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
 979                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 980
 981             /* return the pattern and the modifiers */
 982             PUSHs(pattern);
 983             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
 984             XSRETURN(2);
 985         } else {
 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)));
 990 #else
 991             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
 992                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 993 #endif
 994             PUSHs(pattern);
 995             XSRETURN(1);
 996         }
 997     } else {
 998         /* It ain't a regexp folks */
 999         if ( GIMME_V == G_ARRAY ) {
1000             /* return the empty list */
1001             XSRETURN_UNDEF;
1002         } else {
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
1008                can say
1009
1010                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1011
1012                and not worry about undefined values.
1013             */
1014             XSRETURN_NO;
1015         }
1016     }
1017     /* NOT-REACHED */
1018 }
1019
1020 #include "vutil.h"
1021 #include "vxs.inc"
1022
1023 struct xsub_details {
1024     const char *name;
1025     XSUBADDR_t xsub;
1026     const char *proto;
1027 };
1028
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
1034 #include "vxs.inc"
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, "$"},
1054 };
1055
1056 void
1057 Perl_boot_core_UNIVERSAL(pTHX)
1058 {
1059     dVAR;
1060     static const char file[] = __FILE__;
1061     const struct xsub_details *xsub = details;
1062     const struct xsub_details *end = C_ARRAY_END(details);
1063
1064     do {
1065         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1066     } while (++xsub < end);
1067
1068     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1069     {
1070         CV * const cv =
1071             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1072         Safefree(CvFILE(cv));
1073         CvFILE(cv) = (char *)file;
1074         CvDYNFILE_off(cv);
1075     }
1076 }
1077
1078 /*
1079  * Local variables:
1080  * c-indentation-style: bsd
1081  * c-basic-offset: 4
1082  * indent-tabs-mode: nil
1083  * End:
1084  *
1085  * ex: set ts=8 sts=4 sw=4 et:
1086  */