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