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