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