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(methodname) = 0;
 229     SvCUR(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( 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 sv = ST(0);
 513         const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
 514         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 515
 516         ST(0) = boolSV(RETVAL);
 517     }
 518     XSRETURN(1);
 519 }
 520
 521 XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
 522 XS(XS_utf8_native_to_unicode)
 523 {
 524  dXSARGS;
 525  const UV uv = SvUV(ST(0));
 526
 527  if (items > 1)
 528      croak_xs_usage(cv, "sv");
 529
 530  ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
 531  XSRETURN(1);
 532 }
 533
 534 XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
 535 XS(XS_utf8_unicode_to_native)
 536 {
 537  dXSARGS;
 538  const UV uv = SvUV(ST(0));
 539
 540  if (items > 1)
 541      croak_xs_usage(cv, "sv");
 542
 543  ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
 544  XSRETURN(1);
 545 }
 546
 547 XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
 548 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 549 {
 550     dXSARGS;
 551     SV * const svz = ST(0);
 552     SV * sv;
 553
 554     /* [perl #77776] - called as &foo() not foo() */
 555     if (!SvROK(svz))
 556         croak_xs_usage(cv, "SCALAR[, ON]");
 557
 558     sv = SvRV(svz);
 559
 560     if (items == 1) {
 561          if (SvREADONLY(sv))
 562              XSRETURN_YES;
 563          else
 564              XSRETURN_NO;
 565     }
 566     else if (items == 2) {
 567         if (SvTRUE(ST(1))) {
 568             SvFLAGS(sv) |= SVf_READONLY;
 569             XSRETURN_YES;
 570         }
 571         else {
 572             /* I hope you really know what you are doing. */
 573             SvFLAGS(sv) &=~ SVf_READONLY;
 574             XSRETURN_NO;
 575         }
 576     }
 577     XSRETURN_UNDEF; /* Can't happen. */
 578 }
 579
 580 XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
 581 XS(XS_constant__make_const)     /* This is dangerous stuff. */
 582 {
 583     dXSARGS;
 584     SV * const svz = ST(0);
 585     SV * sv;
 586
 587     /* [perl #77776] - called as &foo() not foo() */
 588     if (!SvROK(svz) || items != 1)
 589         croak_xs_usage(cv, "SCALAR");
 590
 591     sv = SvRV(svz);
 592
 593     SvREADONLY_on(sv);
 594     if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
 595         /* for constant.pm; nobody else should be calling this
 596            on arrays anyway. */
 597         SV **svp;
 598         for (svp = AvARRAY(sv) + AvFILLp(sv)
 599            ; svp >= AvARRAY(sv)
 600            ; --svp)
 601             if (*svp) SvPADTMP_on(*svp);
 602     }
 603     XSRETURN(0);
 604 }
 605
 606 XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
 607 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 608 {
 609     dXSARGS;
 610     SV * const svz = ST(0);
 611     SV * sv;
 612     U32 refcnt;
 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 (memEQs(key, klen, "input")) {
 669                             input = SvTRUE(*valp);
 670                             break;
 671                        }
 672                        goto fail;
 673                   case 'o':
 674                        if (memEQs(key, klen, "output")) {
 675                             input = !SvTRUE(*valp);
 676                             break;
 677                        }
 678                        goto fail;
 679                   case 'd':
 680                        if (memEQs(key, klen, "details")) {
 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_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
 770 XS(XS_re_is_regexp)
 771 {
 772     dXSARGS;
 773
 774     if (items != 1)
 775         croak_xs_usage(cv, "sv");
 776
 777     if (SvRXOK(ST(0))) {
 778         XSRETURN_YES;
 779     } else {
 780         XSRETURN_NO;
 781     }
 782 }
 783
 784 XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
 785 XS(XS_re_regnames_count)
 786 {
 787     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 788     SV * ret;
 789     dXSARGS;
 790
 791     if (items != 0)
 792         croak_xs_usage(cv, "");
 793
 794     if (!rx)
 795         XSRETURN_UNDEF;
 796
 797     ret = CALLREG_NAMED_BUFF_COUNT(rx);
 798
 799     SPAGAIN;
 800     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 801     XSRETURN(1);
 802 }
 803
 804 XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
 805 XS(XS_re_regname)
 806 {
 807     dXSARGS;
 808     REGEXP * rx;
 809     U32 flags;
 810     SV * ret;
 811
 812     if (items < 1 || items > 2)
 813         croak_xs_usage(cv, "name[, all ]");
 814
 815     SP -= items;
 816     PUTBACK;
 817
 818     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 819
 820     if (!rx)
 821         XSRETURN_UNDEF;
 822
 823     if (items == 2 && SvTRUE(ST(1))) {
 824         flags = RXapif_ALL;
 825     } else {
 826         flags = RXapif_ONE;
 827     }
 828     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 829
 830     SPAGAIN;
 831     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
 832     XSRETURN(1);
 833 }
 834
 835
 836 XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
 837 XS(XS_re_regnames)
 838 {
 839     dXSARGS;
 840     REGEXP * rx;
 841     U32 flags;
 842     SV *ret;
 843     AV *av;
 844     SSize_t length;
 845     SSize_t i;
 846     SV **entry;
 847
 848     if (items > 1)
 849         croak_xs_usage(cv, "[all]");
 850
 851     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 852
 853     if (!rx)
 854         XSRETURN_UNDEF;
 855
 856     if (items == 1 && SvTRUE(ST(0))) {
 857         flags = RXapif_ALL;
 858     } else {
 859         flags = RXapif_ONE;
 860     }
 861
 862     SP -= items;
 863     PUTBACK;
 864
 865     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
 866
 867     SPAGAIN;
 868
 869     if (!ret)
 870         XSRETURN_UNDEF;
 871
 872     av = MUTABLE_AV(SvRV(ret));
 873     length = av_tindex(av);
 874
 875     EXTEND(SP, length+1); /* better extend stack just once */
 876     for (i = 0; i <= length; i++) {
 877         entry = av_fetch(av, i, FALSE);
 878
 879         if (!entry)
 880             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 881
 882         mPUSHs(SvREFCNT_inc_simple_NN(*entry));
 883     }
 884
 885     SvREFCNT_dec(ret);
 886
 887     PUTBACK;
 888     return;
 889 }
 890
 891 XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
 892 XS(XS_re_regexp_pattern)
 893 {
 894     dXSARGS;
 895     REGEXP *re;
 896     U8 const gimme = GIMME_V;
 897
 898     EXTEND(SP, 2);
 899     SP -= items;
 900     if (items != 1)
 901         croak_xs_usage(cv, "sv");
 902
 903     /*
 904        Checks if a reference is a regex or not. If the parameter is
 905        not a ref, or is not the result of a qr// then returns false
 906        in scalar context and an empty list in list context.
 907        Otherwise in list context it returns the pattern and the
 908        modifiers, in scalar context it returns the pattern just as it
 909        would if the qr// was stringified normally, regardless as
 910        to the class of the variable and any stringification overloads
 911        on the object.
 912     */
 913
 914     if ((re = SvRX(ST(0)))) /* assign deliberate */
 915     {
 916         /* Houston, we have a regex! */
 917         SV *pattern;
 918
 919         if ( gimme == G_ARRAY ) {
 920             STRLEN left = 0;
 921             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
 922             const char *fptr;
 923             char ch;
 924             U16 match_flags;
 925
 926             /*
 927                we are in list context so stringify
 928                the modifiers that apply. We ignore "negative
 929                modifiers" in this scenario, and the default character set
 930             */
 931
 932             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
 933                 STRLEN len;
 934                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
 935                                                                 &len);
 936                 Copy(name, reflags + left, len, char);
 937                 left += len;
 938             }
 939             fptr = INT_PAT_MODS;
 940             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
 941                                     >> RXf_PMf_STD_PMMOD_SHIFT);
 942
 943             while((ch = *fptr++)) {
 944                 if(match_flags & 1) {
 945                     reflags[left++] = ch;
 946                 }
 947                 match_flags >>= 1;
 948             }
 949
 950             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
 951                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 952
 953             /* return the pattern and the modifiers */
 954             PUSHs(pattern);
 955             PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
 956             XSRETURN(2);
 957         } else {
 958             /* Scalar, so use the string that Perl would return */
 959             /* return the pattern in (?msixn:..) format */
 960             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
 961             PUSHs(pattern);
 962             XSRETURN(1);
 963         }
 964     } else {
 965         /* It ain't a regexp folks */
 966         if ( gimme == G_ARRAY ) {
 967             /* return the empty list */
 968             XSRETURN_EMPTY;
 969         } else {
 970             /* Because of the (?:..) wrapping involved in a
 971                stringified pattern it is impossible to get a
 972                result for a real regexp that would evaluate to
 973                false. Therefore we can return PL_sv_no to signify
 974                that the object is not a regex, this means that one
 975                can say
 976
 977                  if (regex($might_be_a_regex) eq '(?:foo)') { }
 978
 979                and not worry about undefined values.
 980             */
 981             XSRETURN_NO;
 982         }
 983     }
 984     NOT_REACHED; /* NOTREACHED */
 985 }
 986
 987 #include "vutil.h"
 988 #include "vxs.inc"
 989
 990 struct xsub_details {
 991     const char *name;
 992     XSUBADDR_t xsub;
 993     const char *proto;
 994 };
 995
 996 static const struct xsub_details details[] = {
 997     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
 998     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
 999     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1000 #define VXS_XSUB_DETAILS
1001 #include "vxs.inc"
1002 #undef VXS_XSUB_DETAILS
1003     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1004     {"utf8::valid", XS_utf8_valid, NULL},
1005     {"utf8::encode", XS_utf8_encode, NULL},
1006     {"utf8::decode", XS_utf8_decode, NULL},
1007     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1008     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1009     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1010     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1011     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1012     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1013     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1014     {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
1015     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1016     {"re::is_regexp", XS_re_is_regexp, "$"},
1017     {"re::regname", XS_re_regname, ";$$"},
1018     {"re::regnames", XS_re_regnames, ";$"},
1019     {"re::regnames_count", XS_re_regnames_count, ""},
1020     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1021 };
1022
1023 STATIC OP*
1024 optimize_out_native_convert_function(pTHX_ OP* entersubop,
1025                                            GV* namegv,
1026                                            SV* protosv)
1027 {
1028     /* Optimizes out an identity function, i.e., one that just returns its
1029      * argument.  The passed in function is assumed to be an identity function,
1030      * with no checking.  This is designed to be called for utf8_to_native()
1031      * and native_to_utf8() on ASCII platforms, as they just return their
1032      * arguments, but it could work on any such function.
1033      *
1034      * The code is mostly just cargo-culted from Memoize::Lift */
1035
1036     OP *pushop, *argop;
1037     OP *parent;
1038     SV* prototype = newSVpvs("$");
1039
1040     PERL_UNUSED_ARG(protosv);
1041
1042     assert(entersubop->op_type == OP_ENTERSUB);
1043
1044     entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
1045     parent = entersubop;
1046
1047     SvREFCNT_dec(prototype);
1048
1049     pushop = cUNOPx(entersubop)->op_first;
1050     if (! OpHAS_SIBLING(pushop)) {
1051         parent = pushop;
1052         pushop = cUNOPx(pushop)->op_first;
1053     }
1054     argop = OpSIBLING(pushop);
1055
1056     /* Carry on without doing the optimization if it is not something we're
1057      * expecting, so continues to work */
1058     if (   ! argop
1059         || ! OpHAS_SIBLING(argop)
1060         ||   OpHAS_SIBLING(OpSIBLING(argop))
1061     ) {
1062         return entersubop;
1063     }
1064
1065     /* cut argop from the subtree */
1066     (void)op_sibling_splice(parent, pushop, 1, NULL);
1067
1068     op_free(entersubop);
1069     return argop;
1070 }
1071
1072 void
1073 Perl_boot_core_UNIVERSAL(pTHX)
1074 {
1075     static const char file[] = __FILE__;
1076     const struct xsub_details *xsub = details;
1077     const struct xsub_details *end = C_ARRAY_END(details);
1078
1079     do {
1080         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1081     } while (++xsub < end);
1082
1083 #ifndef EBCDIC
1084     { /* On ASCII platforms these functions just return their argument, so can
1085          be optimized away */
1086
1087         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1088         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1089
1090         cv_set_call_checker(to_native_cv,
1091                             optimize_out_native_convert_function,
1092                             (SV*) to_native_cv);
1093         cv_set_call_checker(to_unicode_cv,
1094                             optimize_out_native_convert_function,
1095                             (SV*) to_unicode_cv);
1096     }
1097 #endif
1098
1099     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1100     {
1101         CV * const cv =
1102             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1103         char ** cvfile = &CvFILE(cv);
1104         char * oldfile = *cvfile;
1105         CvDYNFILE_off(cv);
1106         *cvfile = (char *)file;
1107         Safefree(oldfile);
1108     }
1109 }
1110
1111 /*
1112  * ex: set ts=8 sts=4 sw=4 et:
1113  */