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 (SvROK(sv) && SvOBJECT(SvRV(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",
 298                                                      "eee_yow");
 299
 300 =cut
 301 */
 302
 303 void
 304 Perl_croak_xs_usage(const CV *const cv, const char *const params)
 305 {
 306     /* Avoid CvGV as it requires aTHX.  */
 307     const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
 308
 309     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 310
 311     if (gv) got_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         dTHX;
 326         if ((gv = CvGV(cv))) goto got_gv;
 327
 328         /* Pants. I don't think that it should be possible to get here. */
 329         /* diag_listed_as: SKIPME */
 330         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 331     }
 332 }
 333
 334 XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
 335 XS(XS_UNIVERSAL_isa)
 336 {
 337     dXSARGS;
 338
 339     if (items != 2)
 340         croak_xs_usage(cv, "reference, kind");
 341     else {
 342         SV * const sv = ST(0);
 343
 344         SvGETMAGIC(sv);
 345
 346         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 347             XSRETURN_UNDEF;
 348
 349         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 350         XSRETURN(1);
 351     }
 352 }
 353
 354 XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
 355 XS(XS_UNIVERSAL_can)
 356 {
 357     dXSARGS;
 358     SV   *sv;
 359     SV   *rv;
 360     HV   *pkg = NULL;
 361     GV   *iogv;
 362
 363     if (items != 2)
 364         croak_xs_usage(cv, "object-ref, method");
 365
 366     sv = ST(0);
 367
 368     SvGETMAGIC(sv);
 369
 370     /* Reject undef and empty string.  Note that the string form takes
 371        precedence here over the numeric form, as (!1)->foo treats the
 372        invocant as the empty string, though it is a dualvar. */
 373     if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
 374         XSRETURN_UNDEF;
 375
 376     rv = &PL_sv_undef;
 377
 378     if (SvROK(sv)) {
 379         sv = MUTABLE_SV(SvRV(sv));
 380         if (SvOBJECT(sv))
 381             pkg = SvSTASH(sv);
 382         else if (isGV_with_GP(sv) && GvIO(sv))
 383             pkg = SvSTASH(GvIO(sv));
 384     }
 385     else if (isGV_with_GP(sv) && GvIO(sv))
 386         pkg = SvSTASH(GvIO(sv));
 387     else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
 388         pkg = SvSTASH(GvIO(iogv));
 389     else {
 390         pkg = gv_stashsv(sv, 0);
 391         if (!pkg)
 392             pkg = gv_stashpvs("UNIVERSAL", 0);
 393     }
 394
 395     if (pkg) {
 396         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
 397         if (gv && isGV(gv))
 398             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 399     }
 400
 401     ST(0) = rv;
 402     XSRETURN(1);
 403 }
 404
 405 XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
 406 XS(XS_UNIVERSAL_DOES)
 407 {
 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      dXSARGS;
 426      if (items != 1)
 427          croak_xs_usage(cv, "sv");
 428      else {
 429         SV * const sv = ST(0);
 430         SvGETMAGIC(sv);
 431             if (SvUTF8(sv))
 432                 XSRETURN_YES;
 433             else
 434                 XSRETURN_NO;
 435      }
 436      XSRETURN_EMPTY;
 437 }
 438
 439 XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
 440 XS(XS_utf8_valid)
 441 {
 442      dXSARGS;
 443      if (items != 1)
 444          croak_xs_usage(cv, "sv");
 445     else {
 446         SV * const sv = ST(0);
 447         STRLEN len;
 448         const char * const s = SvPV_const(sv,len);
 449         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 450             XSRETURN_YES;
 451         else
 452             XSRETURN_NO;
 453     }
 454      XSRETURN_EMPTY;
 455 }
 456
 457 XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
 458 XS(XS_utf8_encode)
 459 {
 460     dXSARGS;
 461     if (items != 1)
 462         croak_xs_usage(cv, "sv");
 463     sv_utf8_encode(ST(0));
 464     SvSETMAGIC(ST(0));
 465     XSRETURN_EMPTY;
 466 }
 467
 468 XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
 469 XS(XS_utf8_decode)
 470 {
 471     dXSARGS;
 472     if (items != 1)
 473         croak_xs_usage(cv, "sv");
 474     else {
 475         SV * const sv = ST(0);
 476         bool RETVAL;
 477         SvPV_force_nolen(sv);
 478         RETVAL = sv_utf8_decode(sv);
 479         SvSETMAGIC(sv);
 480         ST(0) = boolSV(RETVAL);
 481     }
 482     XSRETURN(1);
 483 }
 484
 485 XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
 486 XS(XS_utf8_upgrade)
 487 {
 488     dXSARGS;
 489     if (items != 1)
 490         croak_xs_usage(cv, "sv");
 491     else {
 492         SV * const sv = ST(0);
 493         STRLEN  RETVAL;
 494         dXSTARG;
 495
 496         RETVAL = sv_utf8_upgrade(sv);
 497         XSprePUSH; PUSHi((IV)RETVAL);
 498     }
 499     XSRETURN(1);
 500 }
 501
 502 XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
 503 XS(XS_utf8_downgrade)
 504 {
 505     dXSARGS;
 506     if (items < 1 || items > 2)
 507         croak_xs_usage(cv, "sv, failok=0");
 508     else {
 509         SV * const sv = ST(0);
 510         const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
 511         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 512
 513         ST(0) = boolSV(RETVAL);
 514     }
 515     XSRETURN(1);
 516 }
 517
 518 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
 519 XS(XS_utf8_native_to_unicode)
 520 {
 521  dXSARGS;
 522  const UV uv = SvUV(ST(0));
 523
 524  if (items > 1)
 525      croak_xs_usage(cv, "sv");
 526
 527  ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
 528  XSRETURN(1);
 529 }
 530
 531 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
 532 XS(XS_utf8_unicode_to_native)
 533 {
 534  dXSARGS;
 535  const UV uv = SvUV(ST(0));
 536
 537  if (items > 1)
 538      croak_xs_usage(cv, "sv");
 539
 540  ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
 541  XSRETURN(1);
 542 }
 543
 544 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
 545 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 546 {
 547     dXSARGS;
 548     SV * const svz = ST(0);
 549     SV * sv;
 550     PERL_UNUSED_ARG(cv);
 551
 552     /* [perl #77776] - called as &foo() not foo() */
 553     if (!SvROK(svz))
 554         croak_xs_usage(cv, "SCALAR[, ON]");
 555
 556     sv = SvRV(svz);
 557
 558     if (items == 1) {
 559          if (SvREADONLY(sv))
 560              XSRETURN_YES;
 561          else
 562              XSRETURN_NO;
 563     }
 564     else if (items == 2) {
 565         if (SvTRUE(ST(1))) {
 566             SvFLAGS(sv) |= SVf_READONLY;
 567             XSRETURN_YES;
 568         }
 569         else {
 570             /* I hope you really know what you are doing. */
 571             SvFLAGS(sv) &=~ SVf_READONLY;
 572             XSRETURN_NO;
 573         }
 574     }
 575     XSRETURN_UNDEF; /* Can't happen. */
 576 }
 577
 578 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
 579 XS(XS_constant__make_const)     /* This is dangerous stuff. */
 580 {
 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     SvREADONLY_on(sv);
 593     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 594         /* for constant.pm; nobody else should be calling this
 595            on arrays anyway. */
 596         SV **svp;
 597         for (svp = AvARRAY(sv) + AvFILLp(sv)
 598            ; svp >= AvARRAY(sv)
 599            ; --svp)
 600             if (*svp) SvPADTMP_on(*svp);
 601     }
 602     XSRETURN(0);
 603 }
 604
 605 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
 606 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 607 {
 608     dXSARGS;
 609     SV * const svz = ST(0);
 610     SV * sv;
 611     U32 refcnt;
 612     PERL_UNUSED_ARG(cv);
 613
 614     /* [perl #77776] - called as &foo() not foo() */
 615     if ((items != 1 && items != 2) || !SvROK(svz))
 616         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 617
 618     sv = SvRV(svz);
 619
 620          /* I hope you really know what you are doing. */
 621     /* idea is for SvREFCNT(sv) to be accessed only once */
 622     refcnt = items == 2 ?
 623                 /* we free one ref on exit */
 624                 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
 625                 : SvREFCNT(sv);
 626     XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
 627
 628 }
 629
 630 XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
 631 XS(XS_Internals_hv_clear_placehold)
 632 {
 633     dXSARGS;
 634
 635     if (items != 1 || !SvROK(ST(0)))
 636         croak_xs_usage(cv, "hv");
 637     else {
 638         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 639         hv_clear_placeholders(hv);
 640         XSRETURN(0);
 641     }
 642 }
 643
 644 XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
 645 XS(XS_PerlIO_get_layers)
 646 {
 647     dXSARGS;
 648     if (items < 1 || items % 2 == 0)
 649         croak_xs_usage(cv, "filehandle[,args]");
 650 #if defined(USE_PERLIO)
 651     {
 652         SV *    sv;
 653         GV *    gv;
 654         IO *    io;
 655         bool    input = TRUE;
 656         bool    details = FALSE;
 657
 658         if (items > 1) {
 659              SV * const *svp;
 660              for (svp = MARK + 2; svp <= SP; svp += 2) {
 661                   SV * const * const varp = svp;
 662                   SV * const * const valp = svp + 1;
 663                   STRLEN klen;
 664                   const char * const key = SvPV_const(*varp, klen);
 665
 666                   switch (*key) {
 667                   case 'i':
 668                        if (klen == 5 && memEQ(key, "input", 5)) {
 669                             input = SvTRUE(*valp);
 670                             break;
 671                        }
 672                        goto fail;
 673                   case 'o':
 674                        if (klen == 6 && memEQ(key, "output", 6)) {
 675                             input = !SvTRUE(*valp);
 676                             break;
 677                        }
 678                        goto fail;
 679                   case 'd':
 680                        if (klen == 7 && memEQ(key, "details", 7)) {
 681                             details = SvTRUE(*valp);
 682                             break;
 683                        }
 684                        goto fail;
 685                   default:
 686                   fail:
 687                        Perl_croak(aTHX_
 688                                   "get_layers: unknown argument '%s'",
 689                                   key);
 690                   }
 691              }
 692
 693              SP -= (items - 1);
 694         }
 695
 696         sv = POPs;
 697         gv = MAYBE_DEREF_GV(sv);
 698
 699         if (!gv && !SvROK(sv))
 700             gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
 701
 702         if (gv && (io = GvIO(gv))) {
 703              AV* const av = PerlIO_get_layers(aTHX_ input ?
 704                                         IoIFP(io) : IoOFP(io));
 705              SSize_t i;
 706              const SSize_t last = av_tindex(av);
 707              SSize_t nitem = 0;
 708
 709              for (i = last; i >= 0; i -= 3) {
 710                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 711                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 712                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 713
 714                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 715                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 716                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 717
 718                   EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
 719                   if (details) {
 720                       /* Indents of 5? Yuck.  */
 721                       /* We know that PerlIO_get_layers creates a new SV for
 722                          the name and flags, so we can just take a reference
 723                          and "steal" it when we free the AV below.  */
 724                        PUSHs(namok
 725                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 726                               : &PL_sv_undef);
 727                        PUSHs(argok
 728                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 729                                                SvCUR(*argsvp),
 730                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 731                                                | SVs_TEMP)
 732                               : &PL_sv_undef);
 733                        PUSHs(flgok
 734                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 735                               : &PL_sv_undef);
 736                        nitem += 3;
 737                   }
 738                   else {
 739                        if (namok && argok)
 740                             PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 741                                                  SVfARG(*namsvp),
 742                                                  SVfARG(*argsvp))));
 743                        else if (namok)
 744                             PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 745                        else
 746                             PUSHs(&PL_sv_undef);
 747                        nitem++;
 748                        if (flgok) {
 749                             const IV flags = SvIVX(*flgsvp);
 750
 751                             if (flags & PERLIO_F_UTF8) {
 752                                  PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 753                                  nitem++;
 754                             }
 755                        }
 756                   }
 757              }
 758
 759              SvREFCNT_dec(av);
 760
 761              XSRETURN(nitem);
 762         }
 763     }
 764 #endif
 765
 766     XSRETURN(0);
 767 }
 768
 769 XS(XS_hash_util_bucket_ratio); /* prototype to pass -Wmissing-prototypes */
 770 XS(XS_hash_util_bucket_ratio)
 771 {
 772     dXSARGS;
 773     SV *rhv;
 774     PERL_UNUSED_VAR(cv);
 775
 776     if (items != 1)
 777         croak_xs_usage(cv, "hv");
 778
 779     rhv= ST(0);
 780     if (SvROK(rhv)) {
 781         rhv= SvRV(rhv);
 782         if ( SvTYPE(rhv)==SVt_PVHV ) {
 783             SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv);
 784             ST(0)= ret;
 785             XSRETURN(1);
 786         }
 787     }
 788     XSRETURN_UNDEF;
 789 }
 790
 791 XS(XS_hash_util_num_buckets); /* prototype to pass -Wmissing-prototypes */
 792 XS(XS_hash_util_num_buckets)
 793 {
 794     dXSARGS;
 795     SV *rhv;
 796     PERL_UNUSED_VAR(cv);
 797
 798     if (items != 1)
 799         croak_xs_usage(cv, "hv");
 800
 801     rhv= ST(0);
 802     if (SvROK(rhv)) {
 803         rhv= SvRV(rhv);
 804         if ( SvTYPE(rhv)==SVt_PVHV ) {
 805             XSRETURN_UV(HvMAX((HV*)rhv)+1);
 806         }
 807     }
 808     XSRETURN_UNDEF;
 809 }
 810
 811 XS(XS_hash_util_used_buckets); /* prototype to pass -Wmissing-prototypes */
 812 XS(XS_hash_util_used_buckets)
 813 {
 814     dXSARGS;
 815     SV *rhv;
 816     PERL_UNUSED_VAR(cv);
 817
 818     if (items != 1)
 819         croak_xs_usage(cv, "hv");
 820
 821     rhv= ST(0);
 822     if (SvROK(rhv)) {
 823         rhv= SvRV(rhv);
 824         if ( SvTYPE(rhv)==SVt_PVHV ) {
 825             XSRETURN_UV(HvFILL((HV*)rhv));
 826         }
 827     }
 828     XSRETURN_UNDEF;
 829 }
 830
 831 XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
 832 XS(XS_re_is_regexp)
 833 {
 834     dXSARGS;
 835     PERL_UNUSED_VAR(cv);
 836
 837     if (items != 1)
 838         croak_xs_usage(cv, "sv");
 839
 840     if (SvRXOK(ST(0))) {
 841         XSRETURN_YES;
 842     } else {
 843         XSRETURN_NO;
 844     }
 845 }
 846
 847 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
 848 XS(XS_re_regnames_count)
 849 {
 850     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 851     SV * ret;
 852     dXSARGS;
 853
 854     if (items != 0)
 855         croak_xs_usage(cv, "");
 856
 857     SP -= items;
 858     PUTBACK;
 859
 860     if (!rx)
 861         XSRETURN_UNDEF;
 862
 863     ret = CALLREG_NAMED_BUFF_COUNT(rx);
 864
 865     SPAGAIN;
 866     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 867     XSRETURN(1);
 868 }
 869
 870 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
 871 XS(XS_re_regname)
 872 {
 873     dXSARGS;
 874     REGEXP * rx;
 875     U32 flags;
 876     SV * ret;
 877
 878     if (items < 1 || items > 2)
 879         croak_xs_usage(cv, "name[, all ]");
 880
 881     SP -= items;
 882     PUTBACK;
 883
 884     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 885
 886     if (!rx)
 887         XSRETURN_UNDEF;
 888
 889     if (items == 2 && SvTRUE(ST(1))) {
 890         flags = RXapif_ALL;
 891     } else {
 892         flags = RXapif_ONE;
 893     }
 894     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 895
 896     SPAGAIN;
 897     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 898     XSRETURN(1);
 899 }
 900
 901
 902 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
 903 XS(XS_re_regnames)
 904 {
 905     dXSARGS;
 906     REGEXP * rx;
 907     U32 flags;
 908     SV *ret;
 909     AV *av;
 910     SSize_t length;
 911     SSize_t i;
 912     SV **entry;
 913
 914     if (items > 1)
 915         croak_xs_usage(cv, "[all]");
 916
 917     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 918
 919     if (!rx)
 920         XSRETURN_UNDEF;
 921
 922     if (items == 1 && SvTRUE(ST(0))) {
 923         flags = RXapif_ALL;
 924     } else {
 925         flags = RXapif_ONE;
 926     }
 927
 928     SP -= items;
 929     PUTBACK;
 930
 931     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
 932
 933     SPAGAIN;
 934
 935     if (!ret)
 936         XSRETURN_UNDEF;
 937
 938     av = MUTABLE_AV(SvRV(ret));
 939     length = av_tindex(av);
 940
 941     EXTEND(SP, length+1); /* better extend stack just once */
 942     for (i = 0; i <= length; i++) {
 943         entry = av_fetch(av, i, FALSE);
 944
 945         if (!entry)
 946             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 947
 948         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
 949     }
 950
 951     SvREFCNT_dec(ret);
 952
 953     PUTBACK;
 954     return;
 955 }
 956
 957 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
 958 XS(XS_re_regexp_pattern)
 959 {
 960     dXSARGS;
 961     REGEXP *re;
 962     U8 const gimme = GIMME_V;
 963
 964     EXTEND(SP, 2);
 965     SP -= items;
 966     if (items != 1)
 967         croak_xs_usage(cv, "sv");
 968
 969     /*
 970        Checks if a reference is a regex or not. If the parameter is
 971        not a ref, or is not the result of a qr// then returns false
 972        in scalar context and an empty list in list context.
 973        Otherwise in list context it returns the pattern and the
 974        modifiers, in scalar context it returns the pattern just as it
 975        would if the qr// was stringified normally, regardless as
 976        to the class of the variable and any stringification overloads
 977        on the object.
 978     */
 979
 980     if ((re = SvRX(ST(0)))) /* assign deliberate */
 981     {
 982         /* Houston, we have a regex! */
 983         SV *pattern;
 984
 985         if ( gimme == G_ARRAY ) {
 986             STRLEN left = 0;
 987             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
 988             const char *fptr;
 989             char ch;
 990             U16 match_flags;
 991
 992             /*
 993                we are in list context so stringify
 994                the modifiers that apply. We ignore "negative
 995                modifiers" in this scenario, and the default character set
 996             */
 997
 998             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
 999                 STRLEN len;
1000                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1001                                                                 &len);
1002                 Copy(name, reflags + left, len, char);
1003                 left += len;
1004             }
1005             fptr = INT_PAT_MODS;
1006             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1007                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1008
1009             while((ch = *fptr++)) {
1010                 if(match_flags & 1) {
1011                     reflags[left++] = ch;
1012                 }
1013                 match_flags >>= 1;
1014             }
1015
1016             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1017                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1018
1019             /* return the pattern and the modifiers */
1020             PUSHs(pattern);
1021             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1022             XSRETURN(2);
1023         } else {
1024             /* Scalar, so use the string that Perl would return */
1025             /* return the pattern in (?msixn:..) format */
1026 #if PERL_VERSION >= 11
1027             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1028 #else
1029             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1030                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1031 #endif
1032             PUSHs(pattern);
1033             XSRETURN(1);
1034         }
1035     } else {
1036         /* It ain't a regexp folks */
1037         if ( gimme == G_ARRAY ) {
1038             /* return the empty list */
1039             XSRETURN_EMPTY;
1040         } else {
1041             /* Because of the (?:..) wrapping involved in a
1042                stringified pattern it is impossible to get a
1043                result for a real regexp that would evaluate to
1044                false. Therefore we can return PL_sv_no to signify
1045                that the object is not a regex, this means that one
1046                can say
1047
1048                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1049
1050                and not worry about undefined values.
1051             */
1052             XSRETURN_NO;
1053         }
1054     }
1055     NOT_REACHED; /* NOTREACHED */
1056 }
1057
1058 #include "vutil.h"
1059 #include "vxs.inc"
1060
1061 struct xsub_details {
1062     const char *name;
1063     XSUBADDR_t xsub;
1064     const char *proto;
1065 };
1066
1067 static const struct xsub_details details[] = {
1068     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1069     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1070     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1071 #define VXS_XSUB_DETAILS
1072 #include "vxs.inc"
1073 #undef VXS_XSUB_DETAILS
1074     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1075     {"utf8::valid", XS_utf8_valid, NULL},
1076     {"utf8::encode", XS_utf8_encode, NULL},
1077     {"utf8::decode", XS_utf8_decode, NULL},
1078     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1079     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1080     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1081     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1082     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1083     {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1084     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1085     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1086     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1087     {"Hash::Util::bucket_ratio", XS_hash_util_bucket_ratio, "\\%"},
1088     {"Hash::Util::num_buckets", XS_hash_util_num_buckets, "\\%"},
1089     {"Hash::Util::used_buckets", XS_hash_util_used_buckets, "\\%"},
1090     {"re::is_regexp", XS_re_is_regexp, "$"},
1091     {"re::regname", XS_re_regname, ";$$"},
1092     {"re::regnames", XS_re_regnames, ";$"},
1093     {"re::regnames_count", XS_re_regnames_count, ""},
1094     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1095 };
1096
1097 STATIC OP*
1098 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1099                                            GV* namegv,
1100                                            SV* protosv)
1101 {
1102     /* Optimizes out an identity function, i.e., one that just returns its
1103      * argument.  The passed in function is assumed to be an identity function,
1104      * with no checking.  This is designed to be called for utf8_to_native()
1105      * and native_to_utf8() on ASCII platforms, as they just return their
1106      * arguments, but it could work on any such function.
1107      *
1108      * The code is mostly just cargo-culted from Memoize::Lift */
1109
1110     OP *pushop, *argop;
1111     OP *parent;
1112     SV* prototype = newSVpvs("$");
1113
1114     PERL_UNUSED_ARG(protosv);
1115
1116     assert(entersubop->op_type == OP_ENTERSUB);
1117
1118     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1119     parent = entersubop;
1120
1121     SvREFCNT_dec(prototype);
1122
1123     pushop = cUNOPx(entersubop)->op_first;
1124     if (! OpHAS_SIBLING(pushop)) {
1125         parent = pushop;
1126         pushop = cUNOPx(pushop)->op_first;
1127     }
1128     argop = OpSIBLING(pushop);
1129
1130     /* Carry on without doing the optimization if it is not something we're
1131      * expecting, so continues to work */
1132     if (   ! argop
1133         || ! OpHAS_SIBLING(argop)
1134         ||   OpHAS_SIBLING(OpSIBLING(argop))
1135     ) {
1136         return entersubop;
1137     }
1138
1139     /* cut argop from the subtree */
1140     (void)op_sibling_splice(parent, pushop, 1, NULL);
1141
1142     op_free(entersubop);
1143     return argop;
1144 }
1145
1146 void
1147 Perl_boot_core_UNIVERSAL(pTHX)
1148 {
1149     static const char file[] = __FILE__;
1150     const struct xsub_details *xsub = details;
1151     const struct xsub_details *end = C_ARRAY_END(details);
1152
1153     do {
1154         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1155     } while (++xsub < end);
1156
1157 #ifndef EBCDIC
1158     { /* On ASCII platforms these functions just return their argument, so can
1159          be optimized away */
1160
1161         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1162         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1163
1164         cv_set_call_checker(to_native_cv,
1165                             optimize_out_native_convert_function,
1166                             (SV*) to_native_cv);
1167         cv_set_call_checker(to_unicode_cv,
1168                             optimize_out_native_convert_function,
1169                             (SV*) to_unicode_cv);
1170     }
1171 #endif
1172
1173     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1174     {
1175         CV * const cv =
1176             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1177         char ** cvfile = &CvFILE(cv);
1178         char * oldfile = *cvfile;
1179         CvDYNFILE_off(cv);
1180         *cvfile = (char *)file;
1181         Safefree(oldfile);
1182     }
1183 }
1184
1185 /*
1186  * ex: set ts=8 sts=4 sw=4 et:
1187  */