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