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 #ifdef 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     dVAR;
  45     const struct mro_meta *const meta = HvMROMETA(stash);
  46     HV *isa = meta->isa;
  47     const HV *our_stash;
  48
  49     PERL_ARGS_ASSERT_ISA_LOOKUP;
  50
  51     if (!isa) {
  52         (void)mro_get_linear_isa(stash);
  53         isa = meta->isa;
  54     }
  55
  56     if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
  57                   HV_FETCH_ISEXISTS, NULL, 0)) {
  58         /* Direct name lookup worked.  */
  59         return TRUE;
  60     }
  61
  62     /* A stash/class can go by many names (ie. User == main::User), so
  63        we use the HvENAME in the stash itself, which is canonical, falling
  64        back to HvNAME if necessary.  */
  65     our_stash = gv_stashpvn(name, len, flags);
  66
  67     if (our_stash) {
  68         HEK *canon_name = HvENAME_HEK(our_stash);
  69         if (!canon_name) canon_name = HvNAME_HEK(our_stash);
  70
  71         if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
  72                       HEK_FLAGS(canon_name),
  73                       HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
  74             return TRUE;
  75         }
  76     }
  77
  78     return FALSE;
  79 }
  80
  81 /*
  82 =head1 SV Manipulation Functions
  83
  84 =for apidoc sv_derived_from_pvn
  85
  86 Returns a boolean indicating whether the SV is derived from the specified class
  87 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
  88 normal Perl method.
  89
  90 Currently, the only significant value for C<flags> is SVf_UTF8.
  91
  92 =cut
  93
  94 =for apidoc sv_derived_from_sv
  95
  96 Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
  97 of an SV instead of a string/length pair.
  98
  99 =cut
 100
 101 */
 102
 103 bool
 104 Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 105 {
 106     char *namepv;
 107     STRLEN namelen;
 108     PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
 109     namepv = SvPV(namesv, namelen);
 110     if (SvUTF8(namesv))
 111        flags |= SVf_UTF8;
 112     return sv_derived_from_pvn(sv, namepv, namelen, flags);
 113 }
 114
 115 /*
 116 =for apidoc sv_derived_from
 117
 118 Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
 119
 120 =cut
 121 */
 122
 123 bool
 124 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 125 {
 126     PERL_ARGS_ASSERT_SV_DERIVED_FROM;
 127     return sv_derived_from_pvn(sv, name, strlen(name), 0);
 128 }
 129
 130 /*
 131 =for apidoc sv_derived_from_pv
 132
 133 Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
 134 instead of a string/length pair.
 135
 136 =cut
 137 */
 138
 139
 140 bool
 141 Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 142 {
 143     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
 144     return sv_derived_from_pvn(sv, name, strlen(name), flags);
 145 }
 146
 147 bool
 148 Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 149 {
 150     dVAR;
 151     HV *stash;
 152
 153     PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
 154
 155     SvGETMAGIC(sv);
 156
 157     if (SvROK(sv)) { /* hugdo: */
 158         const char *type;
 159         sv = SvRV(sv);
 160         type = sv_reftype(sv,0);
 161         if (type && strEQ(type,name))
 162             return TRUE;
 163         stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
 164     }
 165     else {
 166         stash = gv_stashsv(sv, 0);
 167     }
 168
 169     return stash ? isa_lookup(stash, name, len, flags) : FALSE;
 170 }
 171
 172 /*
 173 =for apidoc sv_does_sv
 174
 175 Returns a boolean indicating whether the SV performs a specific, named role.
 176 The SV can be a Perl object or the name of a Perl class.
 177
 178 =cut
 179 */
 180
 181 #include "XSUB.h"
 182
 183 bool
 184 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 185 {
 186     SV *classname;
 187     bool does_it;
 188     SV *methodname;
 189     dSP;
 190
 191     PERL_ARGS_ASSERT_SV_DOES_SV;
 192     PERL_UNUSED_ARG(flags);
 193
 194     ENTER;
 195     SAVETMPS;
 196
 197     SvGETMAGIC(sv);
 198
 199     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 200             || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
 201         LEAVE;
 202         return FALSE;
 203     }
 204
 205     if (sv_isobject(sv)) {
 206         classname = sv_ref(NULL,SvRV(sv),TRUE);
 207     } else {
 208         classname = sv;
 209     }
 210
 211     if (sv_eq(classname, namesv)) {
 212         LEAVE;
 213         return TRUE;
 214     }
 215
 216     PUSHMARK(SP);
 217     EXTEND(SP, 2);
 218     PUSHs(sv);
 219     PUSHs(namesv);
 220     PUTBACK;
 221
 222     methodname = newSVpvs_flags("isa", SVs_TEMP);
 223     /* ugly hack: use the SvSCREAM flag so S_method_common
 224      * can figure out we're calling DOES() and not isa(),
 225      * and report eventual errors correctly. --rgs */
 226     SvSCREAM_on(methodname);
 227     call_sv(methodname, G_SCALAR | G_METHOD);
 228     SPAGAIN;
 229
 230     does_it = SvTRUE( TOPs );
 231     FREETMPS;
 232     LEAVE;
 233
 234     return does_it;
 235 }
 236
 237 /*
 238 =for apidoc sv_does
 239
 240 Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
 241
 242 =cut
 243 */
 244
 245 bool
 246 Perl_sv_does(pTHX_ SV *sv, const char *const name)
 247 {
 248     PERL_ARGS_ASSERT_SV_DOES;
 249     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
 250 }
 251
 252 /*
 253 =for apidoc sv_does_pv
 254
 255 Like L</sv_does_pvn>, but takes a nul-terminated string
 256 instead of a string/length pair.
 257
 258 =cut
 259 */
 260
 261
 262 bool
 263 Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
 264 {
 265     PERL_ARGS_ASSERT_SV_DOES_PV;
 266     return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
 267 }
 268
 269 bool
 270 Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
 271 {
 272     PERL_ARGS_ASSERT_SV_DOES_PVN;
 273
 274     return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
 275 }
 276
 277 /*
 278 =for apidoc croak_xs_usage
 279
 280 A specialised variant of C<croak()> for emitting the usage message for xsubs
 281
 282     croak_xs_usage(cv, "eee_yow");
 283
 284 works out the package name and subroutine name from C<cv>, and then calls
 285 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 286
 287     Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
 288
 289 =cut
 290 */
 291
 292 void
 293 Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 294 {
 295     const GV *const gv = CvGV(cv);
 296
 297     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 298
 299     if (gv) {
 300         const char *const gvname = GvNAME(gv);
 301         const HV *const stash = GvSTASH(gv);
 302         const char *const hvname = stash ? HvNAME_get(stash) : NULL;
 303
 304         if (hvname)
 305             Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
 306         else
 307             Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
 308     } else {
 309         /* Pants. I don't think that it should be possible to get here. */
 310         Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 311     }
 312 }
 313
 314 XS(XS_UNIVERSAL_isa)
 315 {
 316     dVAR;
 317     dXSARGS;
 318
 319     if (items != 2)
 320         croak_xs_usage(cv, "reference, kind");
 321     else {
 322         SV * const sv = ST(0);
 323
 324         SvGETMAGIC(sv);
 325
 326         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 327                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 328             XSRETURN_UNDEF;
 329
 330         ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
 331         XSRETURN(1);
 332     }
 333 }
 334
 335 XS(XS_UNIVERSAL_can)
 336 {
 337     dVAR;
 338     dXSARGS;
 339     SV   *sv;
 340     SV   *rv;
 341     HV   *pkg = NULL;
 342
 343     if (items != 2)
 344         croak_xs_usage(cv, "object-ref, method");
 345
 346     sv = ST(0);
 347
 348     SvGETMAGIC(sv);
 349
 350     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 351                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 352         XSRETURN_UNDEF;
 353
 354     rv = &PL_sv_undef;
 355
 356     if (SvROK(sv)) {
 357         sv = MUTABLE_SV(SvRV(sv));
 358         if (SvOBJECT(sv))
 359             pkg = SvSTASH(sv);
 360     }
 361     else {
 362         pkg = gv_stashsv(sv, 0);
 363     }
 364
 365     if (pkg) {
 366         GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
 367         if (gv && isGV(gv))
 368             rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
 369     }
 370
 371     ST(0) = rv;
 372     XSRETURN(1);
 373 }
 374
 375 XS(XS_UNIVERSAL_DOES)
 376 {
 377     dVAR;
 378     dXSARGS;
 379     PERL_UNUSED_ARG(cv);
 380
 381     if (items != 2)
 382         Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
 383     else {
 384         SV * const sv = ST(0);
 385         if (sv_does_sv( sv, ST(1), 0 ))
 386             XSRETURN_YES;
 387
 388         XSRETURN_NO;
 389     }
 390 }
 391
 392 XS(XS_UNIVERSAL_VERSION)
 393 {
 394     dVAR;
 395     dXSARGS;
 396     HV *pkg;
 397     GV **gvp;
 398     GV *gv;
 399     SV *sv;
 400     SV *ret;
 401     const char *undef;
 402     PERL_UNUSED_ARG(cv);
 403
 404     if (SvROK(ST(0))) {
 405         sv = MUTABLE_SV(SvRV(ST(0)));
 406         if (!SvOBJECT(sv))
 407             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 408         pkg = SvSTASH(sv);
 409     }
 410     else {
 411         pkg = gv_stashsv(ST(0), 0);
 412     }
 413
 414     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 415
 416     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 417         ret = sv_newmortal();
 418         sv_setsv(ret, sv);
 419         undef = NULL;
 420     }
 421     else {
 422         sv = ret = &PL_sv_undef;
 423         undef = "(undef)";
 424     }
 425
 426     if (items > 1) {
 427         SV *req = ST(1);
 428
 429         if (undef) {
 430             if (pkg) {
 431                 const char * const name = HvNAME_get(pkg);
 432                 Perl_croak(aTHX_
 433                            "%s does not define $%s::VERSION--version check failed",
 434                            name, name);
 435             } else {
 436                 Perl_croak(aTHX_
 437                              "%s defines neither package nor VERSION--version check failed",
 438                              SvPVx_nolen_const(ST(0)) );
 439              }
 440         }
 441
 442         if ( !sv_derived_from(sv, "version"))
 443             upg_version(sv, FALSE);
 444
 445         if ( !sv_derived_from(req, "version")) {
 446             /* req may very well be R/O, so create a new object */
 447             req = sv_2mortal( new_version(req) );
 448         }
 449
 450         if ( vcmp( req, sv ) > 0 ) {
 451             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 452                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 453                        "this is only version %"SVf"", HvNAME_get(pkg),
 454                        SVfARG(sv_2mortal(vnormal(req))),
 455                        SVfARG(sv_2mortal(vnormal(sv))));
 456             } else {
 457                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 458                        "this is only version %"SVf"", HvNAME_get(pkg),
 459                        SVfARG(sv_2mortal(vstringify(req))),
 460                        SVfARG(sv_2mortal(vstringify(sv))));
 461             }
 462         }
 463
 464     }
 465
 466     ST(0) = ret;
 467
 468     XSRETURN(1);
 469 }
 470
 471 XS(XS_version_new)
 472 {
 473     dVAR;
 474     dXSARGS;
 475     if (items > 3)
 476         croak_xs_usage(cv, "class, version");
 477     SP -= items;
 478     {
 479         SV *vs = ST(1);
 480         SV *rv;
 481         const char * const classname =
 482             sv_isobject(ST(0)) /* get the class if called as an object method */
 483                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 484                 : (char *)SvPV_nolen(ST(0));
 485
 486         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 487             /* create empty object */
 488             vs = sv_newmortal();
 489             sv_setpvs(vs, "0");
 490         }
 491         else if ( items == 3 ) {
 492             vs = sv_newmortal();
 493             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 494         }
 495
 496         rv = new_version(vs);
 497         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 498             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 499
 500         mPUSHs(rv);
 501         PUTBACK;
 502         return;
 503     }
 504 }
 505
 506 XS(XS_version_stringify)
 507 {
 508      dVAR;
 509      dXSARGS;
 510      if (items < 1)
 511          croak_xs_usage(cv, "lobj, ...");
 512      SP -= items;
 513      {
 514           SV *  lobj = ST(0);
 515
 516           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 517                lobj = SvRV(lobj);
 518           }
 519           else
 520                Perl_croak(aTHX_ "lobj is not of type version");
 521
 522           mPUSHs(vstringify(lobj));
 523
 524           PUTBACK;
 525           return;
 526      }
 527 }
 528
 529 XS(XS_version_numify)
 530 {
 531      dVAR;
 532      dXSARGS;
 533      if (items < 1)
 534          croak_xs_usage(cv, "lobj, ...");
 535      SP -= items;
 536      {
 537           SV *  lobj = ST(0);
 538
 539           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 540                lobj = SvRV(lobj);
 541           }
 542           else
 543                Perl_croak(aTHX_ "lobj is not of type version");
 544
 545           mPUSHs(vnumify(lobj));
 546
 547           PUTBACK;
 548           return;
 549      }
 550 }
 551
 552 XS(XS_version_normal)
 553 {
 554      dVAR;
 555      dXSARGS;
 556      if (items < 1)
 557          croak_xs_usage(cv, "lobj, ...");
 558      SP -= items;
 559      {
 560           SV *  lobj = ST(0);
 561
 562           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 563                lobj = SvRV(lobj);
 564           }
 565           else
 566                Perl_croak(aTHX_ "lobj is not of type version");
 567
 568           mPUSHs(vnormal(lobj));
 569
 570           PUTBACK;
 571           return;
 572      }
 573 }
 574
 575 XS(XS_version_vcmp)
 576 {
 577      dVAR;
 578      dXSARGS;
 579      if (items < 1)
 580          croak_xs_usage(cv, "lobj, ...");
 581      SP -= items;
 582      {
 583           SV *  lobj = ST(0);
 584
 585           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 586                lobj = SvRV(lobj);
 587           }
 588           else
 589                Perl_croak(aTHX_ "lobj is not of type version");
 590
 591           {
 592                SV       *rs;
 593                SV       *rvs;
 594                SV * robj = ST(1);
 595                const IV  swap = (IV)SvIV(ST(2));
 596
 597                if ( ! sv_derived_from(robj, "version") )
 598                {
 599                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 600                     sv_2mortal(robj);
 601                }
 602                rvs = SvRV(robj);
 603
 604                if ( swap )
 605                {
 606                     rs = newSViv(vcmp(rvs,lobj));
 607                }
 608                else
 609                {
 610                     rs = newSViv(vcmp(lobj,rvs));
 611                }
 612
 613                mPUSHs(rs);
 614           }
 615
 616           PUTBACK;
 617           return;
 618      }
 619 }
 620
 621 XS(XS_version_boolean)
 622 {
 623     dVAR;
 624     dXSARGS;
 625     if (items < 1)
 626         croak_xs_usage(cv, "lobj, ...");
 627     SP -= items;
 628     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 629         SV * const lobj = SvRV(ST(0));
 630         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 631         mPUSHs(rs);
 632         PUTBACK;
 633         return;
 634     }
 635     else
 636         Perl_croak(aTHX_ "lobj is not of type version");
 637 }
 638
 639 XS(XS_version_noop)
 640 {
 641     dVAR;
 642     dXSARGS;
 643     if (items < 1)
 644         croak_xs_usage(cv, "lobj, ...");
 645     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
 646         Perl_croak(aTHX_ "operation not supported with version object");
 647     else
 648         Perl_croak(aTHX_ "lobj is not of type version");
 649 #ifndef HASATTRIBUTE_NORETURN
 650     XSRETURN_EMPTY;
 651 #endif
 652 }
 653
 654 XS(XS_version_is_alpha)
 655 {
 656     dVAR;
 657     dXSARGS;
 658     if (items != 1)
 659         croak_xs_usage(cv, "lobj");
 660     SP -= items;
 661     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 662         SV * const lobj = ST(0);
 663         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 664             XSRETURN_YES;
 665         else
 666             XSRETURN_NO;
 667         PUTBACK;
 668         return;
 669     }
 670     else
 671         Perl_croak(aTHX_ "lobj is not of type version");
 672 }
 673
 674 XS(XS_version_qv)
 675 {
 676     dVAR;
 677     dXSARGS;
 678     PERL_UNUSED_ARG(cv);
 679     SP -= items;
 680     {
 681         SV * ver = ST(0);
 682         SV * rv;
 683         const char * classname = "";
 684         if ( items == 2 && SvOK(ST(1)) ) {
 685             /* getting called as object or class method */
 686             ver = ST(1);
 687             classname =
 688                 sv_isobject(ST(0)) /* class called as an object method */
 689                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
 690                     : (char *)SvPV_nolen(ST(0));
 691         }
 692         if ( !SvVOK(ver) ) { /* not already a v-string */
 693             rv = sv_newmortal();
 694             sv_setsv(rv,ver); /* make a duplicate */
 695             upg_version(rv, TRUE);
 696         } else {
 697             rv = sv_2mortal(new_version(ver));
 698         }
 699         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
 700             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 701         }
 702         PUSHs(rv);
 703     }
 704     PUTBACK;
 705     return;
 706 }
 707
 708 XS(XS_version_is_qv)
 709 {
 710     dVAR;
 711     dXSARGS;
 712     if (items != 1)
 713         croak_xs_usage(cv, "lobj");
 714     SP -= items;
 715     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 716         SV * const lobj = ST(0);
 717         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 718             XSRETURN_YES;
 719         else
 720             XSRETURN_NO;
 721         PUTBACK;
 722         return;
 723     }
 724     else
 725         Perl_croak(aTHX_ "lobj is not of type version");
 726 }
 727
 728 XS(XS_utf8_is_utf8)
 729 {
 730      dVAR;
 731      dXSARGS;
 732      if (items != 1)
 733          croak_xs_usage(cv, "sv");
 734      else {
 735         SV * const sv = ST(0);
 736         SvGETMAGIC(sv);
 737             if (SvUTF8(sv))
 738                 XSRETURN_YES;
 739             else
 740                 XSRETURN_NO;
 741      }
 742      XSRETURN_EMPTY;
 743 }
 744
 745 XS(XS_utf8_valid)
 746 {
 747      dVAR;
 748      dXSARGS;
 749      if (items != 1)
 750          croak_xs_usage(cv, "sv");
 751     else {
 752         SV * const sv = ST(0);
 753         STRLEN len;
 754         const char * const s = SvPV_const(sv,len);
 755         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 756             XSRETURN_YES;
 757         else
 758             XSRETURN_NO;
 759     }
 760      XSRETURN_EMPTY;
 761 }
 762
 763 XS(XS_utf8_encode)
 764 {
 765     dVAR;
 766     dXSARGS;
 767     if (items != 1)
 768         croak_xs_usage(cv, "sv");
 769     sv_utf8_encode(ST(0));
 770     XSRETURN_EMPTY;
 771 }
 772
 773 XS(XS_utf8_decode)
 774 {
 775     dVAR;
 776     dXSARGS;
 777     if (items != 1)
 778         croak_xs_usage(cv, "sv");
 779     else {
 780         SV * const sv = ST(0);
 781         bool RETVAL;
 782         if (SvIsCOW(sv)) sv_force_normal(sv);
 783         RETVAL = sv_utf8_decode(sv);
 784         ST(0) = boolSV(RETVAL);
 785     }
 786     XSRETURN(1);
 787 }
 788
 789 XS(XS_utf8_upgrade)
 790 {
 791     dVAR;
 792     dXSARGS;
 793     if (items != 1)
 794         croak_xs_usage(cv, "sv");
 795     else {
 796         SV * const sv = ST(0);
 797         STRLEN  RETVAL;
 798         dXSTARG;
 799
 800         RETVAL = sv_utf8_upgrade(sv);
 801         XSprePUSH; PUSHi((IV)RETVAL);
 802     }
 803     XSRETURN(1);
 804 }
 805
 806 XS(XS_utf8_downgrade)
 807 {
 808     dVAR;
 809     dXSARGS;
 810     if (items < 1 || items > 2)
 811         croak_xs_usage(cv, "sv, failok=0");
 812     else {
 813         SV * const sv = ST(0);
 814         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 815         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 816
 817         ST(0) = boolSV(RETVAL);
 818     }
 819     XSRETURN(1);
 820 }
 821
 822 XS(XS_utf8_native_to_unicode)
 823 {
 824  dVAR;
 825  dXSARGS;
 826  const UV uv = SvUV(ST(0));
 827
 828  if (items > 1)
 829      croak_xs_usage(cv, "sv");
 830
 831  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 832  XSRETURN(1);
 833 }
 834
 835 XS(XS_utf8_unicode_to_native)
 836 {
 837  dVAR;
 838  dXSARGS;
 839  const UV uv = SvUV(ST(0));
 840
 841  if (items > 1)
 842      croak_xs_usage(cv, "sv");
 843
 844  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 845  XSRETURN(1);
 846 }
 847
 848 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 849 {
 850     dVAR;
 851     dXSARGS;
 852     SV * const svz = ST(0);
 853     SV * sv;
 854     PERL_UNUSED_ARG(cv);
 855
 856     /* [perl #77776] - called as &foo() not foo() */
 857     if (!SvROK(svz))
 858         croak_xs_usage(cv, "SCALAR[, ON]");
 859
 860     sv = SvRV(svz);
 861
 862     if (items == 1) {
 863          if (SvREADONLY(sv) && !SvIsCOW(sv))
 864              XSRETURN_YES;
 865          else
 866              XSRETURN_NO;
 867     }
 868     else if (items == 2) {
 869         if (SvTRUE(ST(1))) {
 870             if (SvIsCOW(sv)) sv_force_normal(sv);
 871             SvREADONLY_on(sv);
 872             XSRETURN_YES;
 873         }
 874         else {
 875             /* I hope you really know what you are doing. */
 876             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 877             XSRETURN_NO;
 878         }
 879     }
 880     XSRETURN_UNDEF; /* Can't happen. */
 881 }
 882
 883 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 884 {
 885     dVAR;
 886     dXSARGS;
 887     SV * const svz = ST(0);
 888     SV * sv;
 889     PERL_UNUSED_ARG(cv);
 890
 891     /* [perl #77776] - called as &foo() not foo() */
 892     if (!SvROK(svz))
 893         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 894
 895     sv = SvRV(svz);
 896
 897     if (items == 1)
 898          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 899     else if (items == 2) {
 900          /* I hope you really know what you are doing. */
 901          SvREFCNT(sv) = SvIV(ST(1));
 902          XSRETURN_IV(SvREFCNT(sv));
 903     }
 904     XSRETURN_UNDEF; /* Can't happen. */
 905 }
 906
 907 XS(XS_Internals_hv_clear_placehold)
 908 {
 909     dVAR;
 910     dXSARGS;
 911
 912     if (items != 1 || !SvROK(ST(0)))
 913         croak_xs_usage(cv, "hv");
 914     else {
 915         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 916         hv_clear_placeholders(hv);
 917         XSRETURN(0);
 918     }
 919 }
 920
 921 XS(XS_PerlIO_get_layers)
 922 {
 923     dVAR;
 924     dXSARGS;
 925     if (items < 1 || items % 2 == 0)
 926         croak_xs_usage(cv, "filehandle[,args]");
 927 #ifdef USE_PERLIO
 928     {
 929         SV *    sv;
 930         GV *    gv;
 931         IO *    io;
 932         bool    input = TRUE;
 933         bool    details = FALSE;
 934
 935         if (items > 1) {
 936              SV * const *svp;
 937              for (svp = MARK + 2; svp <= SP; svp += 2) {
 938                   SV * const * const varp = svp;
 939                   SV * const * const valp = svp + 1;
 940                   STRLEN klen;
 941                   const char * const key = SvPV_const(*varp, klen);
 942
 943                   switch (*key) {
 944                   case 'i':
 945                        if (klen == 5 && memEQ(key, "input", 5)) {
 946                             input = SvTRUE(*valp);
 947                             break;
 948                        }
 949                        goto fail;
 950                   case 'o':
 951                        if (klen == 6 && memEQ(key, "output", 6)) {
 952                             input = !SvTRUE(*valp);
 953                             break;
 954                        }
 955                        goto fail;
 956                   case 'd':
 957                        if (klen == 7 && memEQ(key, "details", 7)) {
 958                             details = SvTRUE(*valp);
 959                             break;
 960                        }
 961                        goto fail;
 962                   default:
 963                   fail:
 964                        Perl_croak(aTHX_
 965                                   "get_layers: unknown argument '%s'",
 966                                   key);
 967                   }
 968              }
 969
 970              SP -= (items - 1);
 971         }
 972
 973         sv = POPs;
 974         gv = MUTABLE_GV(sv);
 975
 976         if (!isGV(sv)) {
 977              if (SvROK(sv) && isGV(SvRV(sv)))
 978                   gv = MUTABLE_GV(SvRV(sv));
 979              else if (SvPOKp(sv))
 980                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 981         }
 982
 983         if (gv && (io = GvIO(gv))) {
 984              AV* const av = PerlIO_get_layers(aTHX_ input ?
 985                                         IoIFP(io) : IoOFP(io));
 986              I32 i;
 987              const I32 last = av_len(av);
 988              I32 nitem = 0;
 989
 990              for (i = last; i >= 0; i -= 3) {
 991                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 992                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 993                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 994
 995                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 996                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 997                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 998
 999                   if (details) {
1000                       /* Indents of 5? Yuck.  */
1001                       /* We know that PerlIO_get_layers creates a new SV for
1002                          the name and flags, so we can just take a reference
1003                          and "steal" it when we free the AV below.  */
1004                        XPUSHs(namok
1005                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
1006                               : &PL_sv_undef);
1007                        XPUSHs(argok
1008                               ? newSVpvn_flags(SvPVX_const(*argsvp),
1009                                                SvCUR(*argsvp),
1010                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1011                                                | SVs_TEMP)
1012                               : &PL_sv_undef);
1013                        XPUSHs(flgok
1014                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
1015                               : &PL_sv_undef);
1016                        nitem += 3;
1017                   }
1018                   else {
1019                        if (namok && argok)
1020                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
1021                                                  SVfARG(*namsvp),
1022                                                  SVfARG(*argsvp))));
1023                        else if (namok)
1024                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
1025                        else
1026                             XPUSHs(&PL_sv_undef);
1027                        nitem++;
1028                        if (flgok) {
1029                             const IV flags = SvIVX(*flgsvp);
1030
1031                             if (flags & PERLIO_F_UTF8) {
1032                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
1033                                  nitem++;
1034                             }
1035                        }
1036                   }
1037              }
1038
1039              SvREFCNT_dec(av);
1040
1041              XSRETURN(nitem);
1042         }
1043     }
1044 #endif
1045
1046     XSRETURN(0);
1047 }
1048
1049 XS(XS_Internals_hash_seed)
1050 {
1051     dVAR;
1052     /* Using dXSARGS would also have dITEM and dSP,
1053      * which define 2 unused local variables.  */
1054     dAXMARK;
1055     PERL_UNUSED_ARG(cv);
1056     PERL_UNUSED_VAR(mark);
1057     XSRETURN_UV(PERL_HASH_SEED);
1058 }
1059
1060 XS(XS_Internals_rehash_seed)
1061 {
1062     dVAR;
1063     /* Using dXSARGS would also have dITEM and dSP,
1064      * which define 2 unused local variables.  */
1065     dAXMARK;
1066     PERL_UNUSED_ARG(cv);
1067     PERL_UNUSED_VAR(mark);
1068     XSRETURN_UV(PL_rehash_seed);
1069 }
1070
1071 XS(XS_Internals_HvREHASH)       /* Subject to change  */
1072 {
1073     dVAR;
1074     dXSARGS;
1075     PERL_UNUSED_ARG(cv);
1076     if (SvROK(ST(0))) {
1077         const HV * const hv = (const HV *) SvRV(ST(0));
1078         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1079             if (HvREHASH(hv))
1080                 XSRETURN_YES;
1081             else
1082                 XSRETURN_NO;
1083         }
1084     }
1085     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1086 }
1087
1088 XS(XS_re_is_regexp)
1089 {
1090     dVAR;
1091     dXSARGS;
1092     PERL_UNUSED_VAR(cv);
1093
1094     if (items != 1)
1095         croak_xs_usage(cv, "sv");
1096
1097     if (SvRXOK(ST(0))) {
1098         XSRETURN_YES;
1099     } else {
1100         XSRETURN_NO;
1101     }
1102 }
1103
1104 XS(XS_re_regnames_count)
1105 {
1106     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1107     SV * ret;
1108     dVAR;
1109     dXSARGS;
1110
1111     if (items != 0)
1112         croak_xs_usage(cv, "");
1113
1114     SP -= items;
1115     PUTBACK;
1116
1117     if (!rx)
1118         XSRETURN_UNDEF;
1119
1120     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1121
1122     SPAGAIN;
1123     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1124     XSRETURN(1);
1125 }
1126
1127 XS(XS_re_regname)
1128 {
1129     dVAR;
1130     dXSARGS;
1131     REGEXP * rx;
1132     U32 flags;
1133     SV * ret;
1134
1135     if (items < 1 || items > 2)
1136         croak_xs_usage(cv, "name[, all ]");
1137
1138     SP -= items;
1139     PUTBACK;
1140
1141     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1142
1143     if (!rx)
1144         XSRETURN_UNDEF;
1145
1146     if (items == 2 && SvTRUE(ST(1))) {
1147         flags = RXapif_ALL;
1148     } else {
1149         flags = RXapif_ONE;
1150     }
1151     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1152
1153     SPAGAIN;
1154     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1155     XSRETURN(1);
1156 }
1157
1158
1159 XS(XS_re_regnames)
1160 {
1161     dVAR;
1162     dXSARGS;
1163     REGEXP * rx;
1164     U32 flags;
1165     SV *ret;
1166     AV *av;
1167     I32 length;
1168     I32 i;
1169     SV **entry;
1170
1171     if (items > 1)
1172         croak_xs_usage(cv, "[all]");
1173
1174     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1175
1176     if (!rx)
1177         XSRETURN_UNDEF;
1178
1179     if (items == 1 && SvTRUE(ST(0))) {
1180         flags = RXapif_ALL;
1181     } else {
1182         flags = RXapif_ONE;
1183     }
1184
1185     SP -= items;
1186     PUTBACK;
1187
1188     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1189
1190     SPAGAIN;
1191
1192     if (!ret)
1193         XSRETURN_UNDEF;
1194
1195     av = MUTABLE_AV(SvRV(ret));
1196     length = av_len(av);
1197
1198     for (i = 0; i <= length; i++) {
1199         entry = av_fetch(av, i, FALSE);
1200
1201         if (!entry)
1202             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1203
1204         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1205     }
1206
1207     SvREFCNT_dec(ret);
1208
1209     PUTBACK;
1210     return;
1211 }
1212
1213 XS(XS_re_regexp_pattern)
1214 {
1215     dVAR;
1216     dXSARGS;
1217     REGEXP *re;
1218
1219     if (items != 1)
1220         croak_xs_usage(cv, "sv");
1221
1222     SP -= items;
1223
1224     /*
1225        Checks if a reference is a regex or not. If the parameter is
1226        not a ref, or is not the result of a qr// then returns false
1227        in scalar context and an empty list in list context.
1228        Otherwise in list context it returns the pattern and the
1229        modifiers, in scalar context it returns the pattern just as it
1230        would if the qr// was stringified normally, regardless as
1231        to the class of the variable and any stringification overloads
1232        on the object.
1233     */
1234
1235     if ((re = SvRX(ST(0)))) /* assign deliberate */
1236     {
1237         /* Houston, we have a regex! */
1238         SV *pattern;
1239
1240         if ( GIMME_V == G_ARRAY ) {
1241             STRLEN left = 0;
1242             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1243             const char *fptr;
1244             char ch;
1245             U16 match_flags;
1246
1247             /*
1248                we are in list context so stringify
1249                the modifiers that apply. We ignore "negative
1250                modifiers" in this scenario, and the default character set
1251             */
1252
1253             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1254                 STRLEN len;
1255                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1256                                                                 &len);
1257                 Copy(name, reflags + left, len, char);
1258                 left += len;
1259             }
1260             fptr = INT_PAT_MODS;
1261             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1262                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1263
1264             while((ch = *fptr++)) {
1265                 if(match_flags & 1) {
1266                     reflags[left++] = ch;
1267                 }
1268                 match_flags >>= 1;
1269             }
1270
1271             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1272                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1273
1274             /* return the pattern and the modifiers */
1275             XPUSHs(pattern);
1276             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1277             XSRETURN(2);
1278         } else {
1279             /* Scalar, so use the string that Perl would return */
1280             /* return the pattern in (?msix:..) format */
1281 #if PERL_VERSION >= 11
1282             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1283 #else
1284             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1285                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1286 #endif
1287             XPUSHs(pattern);
1288             XSRETURN(1);
1289         }
1290     } else {
1291         /* It ain't a regexp folks */
1292         if ( GIMME_V == G_ARRAY ) {
1293             /* return the empty list */
1294             XSRETURN_UNDEF;
1295         } else {
1296             /* Because of the (?:..) wrapping involved in a
1297                stringified pattern it is impossible to get a
1298                result for a real regexp that would evaluate to
1299                false. Therefore we can return PL_sv_no to signify
1300                that the object is not a regex, this means that one
1301                can say
1302
1303                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1304
1305                and not worry about undefined values.
1306             */
1307             XSRETURN_NO;
1308         }
1309     }
1310     /* NOT-REACHED */
1311 }
1312
1313 struct xsub_details {
1314     const char *name;
1315     XSUBADDR_t xsub;
1316     const char *proto;
1317 };
1318
1319 struct xsub_details details[] = {
1320     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1321     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1322     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1323     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1324     {"version::()", XS_version_noop, NULL},
1325     {"version::new", XS_version_new, NULL},
1326     {"version::parse", XS_version_new, NULL},
1327     {"version::(\"\"", XS_version_stringify, NULL},
1328     {"version::stringify", XS_version_stringify, NULL},
1329     {"version::(0+", XS_version_numify, NULL},
1330     {"version::numify", XS_version_numify, NULL},
1331     {"version::normal", XS_version_normal, NULL},
1332     {"version::(cmp", XS_version_vcmp, NULL},
1333     {"version::(<=>", XS_version_vcmp, NULL},
1334     {"version::vcmp", XS_version_vcmp, NULL},
1335     {"version::(bool", XS_version_boolean, NULL},
1336     {"version::boolean", XS_version_boolean, NULL},
1337     {"version::(nomethod", XS_version_noop, NULL},
1338     {"version::noop", XS_version_noop, NULL},
1339     {"version::is_alpha", XS_version_is_alpha, NULL},
1340     {"version::qv", XS_version_qv, NULL},
1341     {"version::declare", XS_version_qv, NULL},
1342     {"version::is_qv", XS_version_is_qv, NULL},
1343     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1344     {"utf8::valid", XS_utf8_valid, NULL},
1345     {"utf8::encode", XS_utf8_encode, NULL},
1346     {"utf8::decode", XS_utf8_decode, NULL},
1347     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1348     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1349     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1350     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1351     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1352     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1353     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1354     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1355     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1356     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1357     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1358     {"re::is_regexp", XS_re_is_regexp, "$"},
1359     {"re::regname", XS_re_regname, ";$$"},
1360     {"re::regnames", XS_re_regnames, ";$"},
1361     {"re::regnames_count", XS_re_regnames_count, ""},
1362     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1363 };
1364
1365 void
1366 Perl_boot_core_UNIVERSAL(pTHX)
1367 {
1368     dVAR;
1369     static const char file[] = __FILE__;
1370     struct xsub_details *xsub = details;
1371     const struct xsub_details *end
1372         = details + sizeof(details) / sizeof(details[0]);
1373
1374     do {
1375         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1376     } while (++xsub < end);
1377
1378     /* register the overloading (type 'A') magic */
1379     PL_amagic_generation++;
1380
1381     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1382     {
1383         CV * const cv =
1384             newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1385         Safefree(CvFILE(cv));
1386         CvFILE(cv) = (char *)file;
1387         CvDYNFILE_off(cv);
1388     }
1389 }
1390
1391 /*
1392  * Local variables:
1393  * c-indentation-style: bsd
1394  * c-basic-offset: 4
1395  * indent-tabs-mode: t
1396  * End:
1397  *
1398  * ex: set ts=8 sts=4 sw=4 noet:
1399  */