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