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