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)
  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     SV *ret;
 315     const char *undef;
 316     PERL_UNUSED_ARG(cv);
 317
 318     if (SvROK(ST(0))) {
 319         sv = MUTABLE_SV(SvRV(ST(0)));
 320         if (!SvOBJECT(sv))
 321             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 322         pkg = SvSTASH(sv);
 323     }
 324     else {
 325         pkg = gv_stashsv(ST(0), 0);
 326     }
 327
 328     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 329
 330     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 331         ret = sv_newmortal();
 332         sv_setsv(ret, sv);
 333         undef = NULL;
 334     }
 335     else {
 336         sv = ret = &PL_sv_undef;
 337         undef = "(undef)";
 338     }
 339
 340     if (items > 1) {
 341         SV *req = ST(1);
 342
 343         if (undef) {
 344             if (pkg) {
 345                 const char * const name = HvNAME_get(pkg);
 346                 Perl_croak(aTHX_
 347                            "%s does not define $%s::VERSION--version check failed",
 348                            name, name);
 349             } else {
 350                 Perl_croak(aTHX_
 351                              "%s defines neither package nor VERSION--version check failed",
 352                              SvPVx_nolen_const(ST(0)) );
 353              }
 354         }
 355
 356         if ( !sv_derived_from(sv, "version"))
 357             upg_version(sv, FALSE);
 358
 359         if ( !sv_derived_from(req, "version")) {
 360             /* req may very well be R/O, so create a new object */
 361             req = sv_2mortal( new_version(req) );
 362         }
 363
 364         if ( vcmp( req, sv ) > 0 ) {
 365             if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
 366                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 367                        "this is only version %"SVf"", HvNAME_get(pkg),
 368                        SVfARG(sv_2mortal(vnormal(req))),
 369                        SVfARG(sv_2mortal(vnormal(sv))));
 370             } else {
 371                 Perl_croak(aTHX_ "%s version %"SVf" required--"
 372                        "this is only version %"SVf"", HvNAME_get(pkg),
 373                        SVfARG(sv_2mortal(vstringify(req))),
 374                        SVfARG(sv_2mortal(vstringify(sv))));
 375             }
 376         }
 377
 378     }
 379
 380     ST(0) = ret;
 381
 382     XSRETURN(1);
 383 }
 384
 385 XS(XS_version_new)
 386 {
 387     dVAR;
 388     dXSARGS;
 389     if (items > 3)
 390         croak_xs_usage(cv, "class, version");
 391     SP -= items;
 392     {
 393         SV *vs = ST(1);
 394         SV *rv;
 395         const char * const classname =
 396             sv_isobject(ST(0)) /* get the class if called as an object method */
 397                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 398                 : (char *)SvPV_nolen(ST(0));
 399
 400         if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 401             /* create empty object */
 402             vs = sv_newmortal();
 403             sv_setpvs(vs, "0");
 404         }
 405         else if ( items == 3 ) {
 406             vs = sv_newmortal();
 407             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 408         }
 409
 410         rv = new_version(vs);
 411         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 412             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 413
 414         mPUSHs(rv);
 415         PUTBACK;
 416         return;
 417     }
 418 }
 419
 420 XS(XS_version_stringify)
 421 {
 422      dVAR;
 423      dXSARGS;
 424      if (items < 1)
 425          croak_xs_usage(cv, "lobj, ...");
 426      SP -= items;
 427      {
 428           SV *  lobj = ST(0);
 429
 430           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 431                lobj = SvRV(lobj);
 432           }
 433           else
 434                Perl_croak(aTHX_ "lobj is not of type version");
 435
 436           mPUSHs(vstringify(lobj));
 437
 438           PUTBACK;
 439           return;
 440      }
 441 }
 442
 443 XS(XS_version_numify)
 444 {
 445      dVAR;
 446      dXSARGS;
 447      if (items < 1)
 448          croak_xs_usage(cv, "lobj, ...");
 449      SP -= items;
 450      {
 451           SV *  lobj = ST(0);
 452
 453           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 454                lobj = SvRV(lobj);
 455           }
 456           else
 457                Perl_croak(aTHX_ "lobj is not of type version");
 458
 459           mPUSHs(vnumify(lobj));
 460
 461           PUTBACK;
 462           return;
 463      }
 464 }
 465
 466 XS(XS_version_normal)
 467 {
 468      dVAR;
 469      dXSARGS;
 470      if (items < 1)
 471          croak_xs_usage(cv, "lobj, ...");
 472      SP -= items;
 473      {
 474           SV *  lobj = ST(0);
 475
 476           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 477                lobj = SvRV(lobj);
 478           }
 479           else
 480                Perl_croak(aTHX_ "lobj is not of type version");
 481
 482           mPUSHs(vnormal(lobj));
 483
 484           PUTBACK;
 485           return;
 486      }
 487 }
 488
 489 XS(XS_version_vcmp)
 490 {
 491      dVAR;
 492      dXSARGS;
 493      if (items < 1)
 494          croak_xs_usage(cv, "lobj, ...");
 495      SP -= items;
 496      {
 497           SV *  lobj = ST(0);
 498
 499           if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
 500                lobj = SvRV(lobj);
 501           }
 502           else
 503                Perl_croak(aTHX_ "lobj is not of type version");
 504
 505           {
 506                SV       *rs;
 507                SV       *rvs;
 508                SV * robj = ST(1);
 509                const IV  swap = (IV)SvIV(ST(2));
 510
 511                if ( ! sv_derived_from(robj, "version") )
 512                {
 513                     robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
 514                     sv_2mortal(robj);
 515                }
 516                rvs = SvRV(robj);
 517
 518                if ( swap )
 519                {
 520                     rs = newSViv(vcmp(rvs,lobj));
 521                }
 522                else
 523                {
 524                     rs = newSViv(vcmp(lobj,rvs));
 525                }
 526
 527                mPUSHs(rs);
 528           }
 529
 530           PUTBACK;
 531           return;
 532      }
 533 }
 534
 535 XS(XS_version_boolean)
 536 {
 537     dVAR;
 538     dXSARGS;
 539     if (items < 1)
 540         croak_xs_usage(cv, "lobj, ...");
 541     SP -= items;
 542     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 543         SV * const lobj = SvRV(ST(0));
 544         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
 545         mPUSHs(rs);
 546         PUTBACK;
 547         return;
 548     }
 549     else
 550         Perl_croak(aTHX_ "lobj is not of type version");
 551 }
 552
 553 XS(XS_version_noop)
 554 {
 555     dVAR;
 556     dXSARGS;
 557     if (items < 1)
 558         croak_xs_usage(cv, "lobj, ...");
 559     if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
 560         Perl_croak(aTHX_ "operation not supported with version object");
 561     else
 562         Perl_croak(aTHX_ "lobj is not of type version");
 563 #ifndef HASATTRIBUTE_NORETURN
 564     XSRETURN_EMPTY;
 565 #endif
 566 }
 567
 568 XS(XS_version_is_alpha)
 569 {
 570     dVAR;
 571     dXSARGS;
 572     if (items != 1)
 573         croak_xs_usage(cv, "lobj");
 574     SP -= items;
 575     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 576         SV * const lobj = ST(0);
 577         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
 578             XSRETURN_YES;
 579         else
 580             XSRETURN_NO;
 581         PUTBACK;
 582         return;
 583     }
 584     else
 585         Perl_croak(aTHX_ "lobj is not of type version");
 586 }
 587
 588 XS(XS_version_qv)
 589 {
 590     dVAR;
 591     dXSARGS;
 592     PERL_UNUSED_ARG(cv);
 593     SP -= items;
 594     {
 595         SV * ver = ST(0);
 596         SV * rv;
 597         const char * classname = "";
 598         if ( items == 2 && SvOK(ST(1)) ) {
 599             /* getting called as object or class method */
 600             ver = ST(1);
 601             classname =
 602                 sv_isobject(ST(0)) /* class called as an object method */
 603                     ? HvNAME_get(SvSTASH(SvRV(ST(0))))
 604                     : (char *)SvPV_nolen(ST(0));
 605         }
 606         if ( !SvVOK(ver) ) { /* not already a v-string */
 607             rv = sv_newmortal();
 608             sv_setsv(rv,ver); /* make a duplicate */
 609             upg_version(rv, TRUE);
 610         } else {
 611             rv = sv_2mortal(new_version(ver));
 612         }
 613         if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
 614             sv_bless(rv, gv_stashpv(classname, GV_ADD));
 615         }
 616         PUSHs(rv);
 617     }
 618     PUTBACK;
 619     return;
 620 }
 621
 622 XS(XS_version_is_qv)
 623 {
 624     dVAR;
 625     dXSARGS;
 626     if (items != 1)
 627         croak_xs_usage(cv, "lobj");
 628     SP -= items;
 629     if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
 630         SV * const lobj = ST(0);
 631         if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
 632             XSRETURN_YES;
 633         else
 634             XSRETURN_NO;
 635         PUTBACK;
 636         return;
 637     }
 638     else
 639         Perl_croak(aTHX_ "lobj is not of type version");
 640 }
 641
 642 XS(XS_utf8_is_utf8)
 643 {
 644      dVAR;
 645      dXSARGS;
 646      if (items != 1)
 647          croak_xs_usage(cv, "sv");
 648      else {
 649         SV * const sv = ST(0);
 650         SvGETMAGIC(sv);
 651             if (SvUTF8(sv))
 652                 XSRETURN_YES;
 653             else
 654                 XSRETURN_NO;
 655      }
 656      XSRETURN_EMPTY;
 657 }
 658
 659 XS(XS_utf8_valid)
 660 {
 661      dVAR;
 662      dXSARGS;
 663      if (items != 1)
 664          croak_xs_usage(cv, "sv");
 665     else {
 666         SV * const sv = ST(0);
 667         STRLEN len;
 668         const char * const s = SvPV_const(sv,len);
 669         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 670             XSRETURN_YES;
 671         else
 672             XSRETURN_NO;
 673     }
 674      XSRETURN_EMPTY;
 675 }
 676
 677 XS(XS_utf8_encode)
 678 {
 679     dVAR;
 680     dXSARGS;
 681     if (items != 1)
 682         croak_xs_usage(cv, "sv");
 683     sv_utf8_encode(ST(0));
 684     XSRETURN_EMPTY;
 685 }
 686
 687 XS(XS_utf8_decode)
 688 {
 689     dVAR;
 690     dXSARGS;
 691     if (items != 1)
 692         croak_xs_usage(cv, "sv");
 693     else {
 694         SV * const sv = ST(0);
 695         bool RETVAL;
 696         if (SvIsCOW(sv)) sv_force_normal(sv);
 697         RETVAL = sv_utf8_decode(sv);
 698         ST(0) = boolSV(RETVAL);
 699     }
 700     XSRETURN(1);
 701 }
 702
 703 XS(XS_utf8_upgrade)
 704 {
 705     dVAR;
 706     dXSARGS;
 707     if (items != 1)
 708         croak_xs_usage(cv, "sv");
 709     else {
 710         SV * const sv = ST(0);
 711         STRLEN  RETVAL;
 712         dXSTARG;
 713
 714         RETVAL = sv_utf8_upgrade(sv);
 715         XSprePUSH; PUSHi((IV)RETVAL);
 716     }
 717     XSRETURN(1);
 718 }
 719
 720 XS(XS_utf8_downgrade)
 721 {
 722     dVAR;
 723     dXSARGS;
 724     if (items < 1 || items > 2)
 725         croak_xs_usage(cv, "sv, failok=0");
 726     else {
 727         SV * const sv = ST(0);
 728         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 729         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 730
 731         ST(0) = boolSV(RETVAL);
 732     }
 733     XSRETURN(1);
 734 }
 735
 736 XS(XS_utf8_native_to_unicode)
 737 {
 738  dVAR;
 739  dXSARGS;
 740  const UV uv = SvUV(ST(0));
 741
 742  if (items > 1)
 743      croak_xs_usage(cv, "sv");
 744
 745  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 746  XSRETURN(1);
 747 }
 748
 749 XS(XS_utf8_unicode_to_native)
 750 {
 751  dVAR;
 752  dXSARGS;
 753  const UV uv = SvUV(ST(0));
 754
 755  if (items > 1)
 756      croak_xs_usage(cv, "sv");
 757
 758  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 759  XSRETURN(1);
 760 }
 761
 762 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 763 {
 764     dVAR;
 765     dXSARGS;
 766     SV * const svz = ST(0);
 767     SV * sv;
 768     PERL_UNUSED_ARG(cv);
 769
 770     /* [perl #77776] - called as &foo() not foo() */
 771     if (!SvROK(svz))
 772         croak_xs_usage(cv, "SCALAR[, ON]");
 773
 774     sv = SvRV(svz);
 775
 776     if (items == 1) {
 777          if (SvREADONLY(sv) && !SvIsCOW(sv))
 778              XSRETURN_YES;
 779          else
 780              XSRETURN_NO;
 781     }
 782     else if (items == 2) {
 783         if (SvTRUE(ST(1))) {
 784             if (SvIsCOW(sv)) sv_force_normal(sv);
 785             SvREADONLY_on(sv);
 786             XSRETURN_YES;
 787         }
 788         else {
 789             /* I hope you really know what you are doing. */
 790             if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 791             XSRETURN_NO;
 792         }
 793     }
 794     XSRETURN_UNDEF; /* Can't happen. */
 795 }
 796
 797 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 798 {
 799     dVAR;
 800     dXSARGS;
 801     SV * const svz = ST(0);
 802     SV * sv;
 803     PERL_UNUSED_ARG(cv);
 804
 805     /* [perl #77776] - called as &foo() not foo() */
 806     if (!SvROK(svz))
 807         croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
 808
 809     sv = SvRV(svz);
 810
 811     if (items == 1)
 812          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 813     else if (items == 2) {
 814          /* I hope you really know what you are doing. */
 815          SvREFCNT(sv) = SvIV(ST(1));
 816          XSRETURN_IV(SvREFCNT(sv));
 817     }
 818     XSRETURN_UNDEF; /* Can't happen. */
 819 }
 820
 821 XS(XS_Internals_hv_clear_placehold)
 822 {
 823     dVAR;
 824     dXSARGS;
 825
 826     if (items != 1 || !SvROK(ST(0)))
 827         croak_xs_usage(cv, "hv");
 828     else {
 829         HV * const hv = MUTABLE_HV(SvRV(ST(0)));
 830         hv_clear_placeholders(hv);
 831         XSRETURN(0);
 832     }
 833 }
 834
 835 XS(XS_PerlIO_get_layers)
 836 {
 837     dVAR;
 838     dXSARGS;
 839     if (items < 1 || items % 2 == 0)
 840         croak_xs_usage(cv, "filehandle[,args]");
 841 #ifdef USE_PERLIO
 842     {
 843         SV *    sv;
 844         GV *    gv;
 845         IO *    io;
 846         bool    input = TRUE;
 847         bool    details = FALSE;
 848
 849         if (items > 1) {
 850              SV * const *svp;
 851              for (svp = MARK + 2; svp <= SP; svp += 2) {
 852                   SV * const * const varp = svp;
 853                   SV * const * const valp = svp + 1;
 854                   STRLEN klen;
 855                   const char * const key = SvPV_const(*varp, klen);
 856
 857                   switch (*key) {
 858                   case 'i':
 859                        if (klen == 5 && memEQ(key, "input", 5)) {
 860                             input = SvTRUE(*valp);
 861                             break;
 862                        }
 863                        goto fail;
 864                   case 'o':
 865                        if (klen == 6 && memEQ(key, "output", 6)) {
 866                             input = !SvTRUE(*valp);
 867                             break;
 868                        }
 869                        goto fail;
 870                   case 'd':
 871                        if (klen == 7 && memEQ(key, "details", 7)) {
 872                             details = SvTRUE(*valp);
 873                             break;
 874                        }
 875                        goto fail;
 876                   default:
 877                   fail:
 878                        Perl_croak(aTHX_
 879                                   "get_layers: unknown argument '%s'",
 880                                   key);
 881                   }
 882              }
 883
 884              SP -= (items - 1);
 885         }
 886
 887         sv = POPs;
 888         gv = MUTABLE_GV(sv);
 889
 890         if (!isGV(sv)) {
 891              if (SvROK(sv) && isGV(SvRV(sv)))
 892                   gv = MUTABLE_GV(SvRV(sv));
 893              else if (SvPOKp(sv))
 894                   gv = gv_fetchsv(sv, 0, SVt_PVIO);
 895         }
 896
 897         if (gv && (io = GvIO(gv))) {
 898              AV* const av = PerlIO_get_layers(aTHX_ input ?
 899                                         IoIFP(io) : IoOFP(io));
 900              I32 i;
 901              const I32 last = av_len(av);
 902              I32 nitem = 0;
 903
 904              for (i = last; i >= 0; i -= 3) {
 905                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 906                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 907                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 908
 909                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 910                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 911                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 912
 913                   if (details) {
 914                       /* Indents of 5? Yuck.  */
 915                       /* We know that PerlIO_get_layers creates a new SV for
 916                          the name and flags, so we can just take a reference
 917                          and "steal" it when we free the AV below.  */
 918                        XPUSHs(namok
 919                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
 920                               : &PL_sv_undef);
 921                        XPUSHs(argok
 922                               ? newSVpvn_flags(SvPVX_const(*argsvp),
 923                                                SvCUR(*argsvp),
 924                                                (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
 925                                                | SVs_TEMP)
 926                               : &PL_sv_undef);
 927                        XPUSHs(flgok
 928                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
 929                               : &PL_sv_undef);
 930                        nitem += 3;
 931                   }
 932                   else {
 933                        if (namok && argok)
 934                             XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 935                                                  SVfARG(*namsvp),
 936                                                  SVfARG(*argsvp))));
 937                        else if (namok)
 938                            XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
 939                        else
 940                             XPUSHs(&PL_sv_undef);
 941                        nitem++;
 942                        if (flgok) {
 943                             const IV flags = SvIVX(*flgsvp);
 944
 945                             if (flags & PERLIO_F_UTF8) {
 946                                  XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
 947                                  nitem++;
 948                             }
 949                        }
 950                   }
 951              }
 952
 953              SvREFCNT_dec(av);
 954
 955              XSRETURN(nitem);
 956         }
 957     }
 958 #endif
 959
 960     XSRETURN(0);
 961 }
 962
 963 XS(XS_Internals_hash_seed)
 964 {
 965     dVAR;
 966     /* Using dXSARGS would also have dITEM and dSP,
 967      * which define 2 unused local variables.  */
 968     dAXMARK;
 969     PERL_UNUSED_ARG(cv);
 970     PERL_UNUSED_VAR(mark);
 971     XSRETURN_UV(PERL_HASH_SEED);
 972 }
 973
 974 XS(XS_Internals_rehash_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(PL_rehash_seed);
 983 }
 984
 985 XS(XS_Internals_HvREHASH)       /* Subject to change  */
 986 {
 987     dVAR;
 988     dXSARGS;
 989     PERL_UNUSED_ARG(cv);
 990     if (SvROK(ST(0))) {
 991         const HV * const hv = (const HV *) SvRV(ST(0));
 992         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
 993             if (HvREHASH(hv))
 994                 XSRETURN_YES;
 995             else
 996                 XSRETURN_NO;
 997         }
 998     }
 999     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1000 }
1001
1002 XS(XS_re_is_regexp)
1003 {
1004     dVAR;
1005     dXSARGS;
1006     PERL_UNUSED_VAR(cv);
1007
1008     if (items != 1)
1009         croak_xs_usage(cv, "sv");
1010
1011     if (SvRXOK(ST(0))) {
1012         XSRETURN_YES;
1013     } else {
1014         XSRETURN_NO;
1015     }
1016 }
1017
1018 XS(XS_re_regnames_count)
1019 {
1020     REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1021     SV * ret;
1022     dVAR;
1023     dXSARGS;
1024
1025     if (items != 0)
1026         croak_xs_usage(cv, "");
1027
1028     SP -= items;
1029     PUTBACK;
1030
1031     if (!rx)
1032         XSRETURN_UNDEF;
1033
1034     ret = CALLREG_NAMED_BUFF_COUNT(rx);
1035
1036     SPAGAIN;
1037     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1038     XSRETURN(1);
1039 }
1040
1041 XS(XS_re_regname)
1042 {
1043     dVAR;
1044     dXSARGS;
1045     REGEXP * rx;
1046     U32 flags;
1047     SV * ret;
1048
1049     if (items < 1 || items > 2)
1050         croak_xs_usage(cv, "name[, all ]");
1051
1052     SP -= items;
1053     PUTBACK;
1054
1055     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1056
1057     if (!rx)
1058         XSRETURN_UNDEF;
1059
1060     if (items == 2 && SvTRUE(ST(1))) {
1061         flags = RXapif_ALL;
1062     } else {
1063         flags = RXapif_ONE;
1064     }
1065     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
1066
1067     SPAGAIN;
1068     PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1069     XSRETURN(1);
1070 }
1071
1072
1073 XS(XS_re_regnames)
1074 {
1075     dVAR;
1076     dXSARGS;
1077     REGEXP * rx;
1078     U32 flags;
1079     SV *ret;
1080     AV *av;
1081     I32 length;
1082     I32 i;
1083     SV **entry;
1084
1085     if (items > 1)
1086         croak_xs_usage(cv, "[all]");
1087
1088     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1089
1090     if (!rx)
1091         XSRETURN_UNDEF;
1092
1093     if (items == 1 && SvTRUE(ST(0))) {
1094         flags = RXapif_ALL;
1095     } else {
1096         flags = RXapif_ONE;
1097     }
1098
1099     SP -= items;
1100     PUTBACK;
1101
1102     ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
1103
1104     SPAGAIN;
1105
1106     if (!ret)
1107         XSRETURN_UNDEF;
1108
1109     av = MUTABLE_AV(SvRV(ret));
1110     length = av_len(av);
1111
1112     for (i = 0; i <= length; i++) {
1113         entry = av_fetch(av, i, FALSE);
1114
1115         if (!entry)
1116             Perl_croak(aTHX_ "NULL array element in re::regnames()");
1117
1118         mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
1119     }
1120
1121     SvREFCNT_dec(ret);
1122
1123     PUTBACK;
1124     return;
1125 }
1126
1127 XS(XS_re_regexp_pattern)
1128 {
1129     dVAR;
1130     dXSARGS;
1131     REGEXP *re;
1132
1133     if (items != 1)
1134         croak_xs_usage(cv, "sv");
1135
1136     SP -= items;
1137
1138     /*
1139        Checks if a reference is a regex or not. If the parameter is
1140        not a ref, or is not the result of a qr// then returns false
1141        in scalar context and an empty list in list context.
1142        Otherwise in list context it returns the pattern and the
1143        modifiers, in scalar context it returns the pattern just as it
1144        would if the qr// was stringified normally, regardless as
1145        to the class of the variable and any stringification overloads
1146        on the object.
1147     */
1148
1149     if ((re = SvRX(ST(0)))) /* assign deliberate */
1150     {
1151         /* Houston, we have a regex! */
1152         SV *pattern;
1153
1154         if ( GIMME_V == G_ARRAY ) {
1155             STRLEN left = 0;
1156             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1157             const char *fptr;
1158             char ch;
1159             U16 match_flags;
1160
1161             /*
1162                we are in list context so stringify
1163                the modifiers that apply. We ignore "negative
1164                modifiers" in this scenario, and the default character set
1165             */
1166
1167             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1168                 STRLEN len;
1169                 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1170                                                                 &len);
1171                 Copy(name, reflags + left, len, char);
1172                 left += len;
1173             }
1174             fptr = INT_PAT_MODS;
1175             match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1176                                     >> RXf_PMf_STD_PMMOD_SHIFT);
1177
1178             while((ch = *fptr++)) {
1179                 if(match_flags & 1) {
1180                     reflags[left++] = ch;
1181                 }
1182                 match_flags >>= 1;
1183             }
1184
1185             pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1186                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1187
1188             /* return the pattern and the modifiers */
1189             XPUSHs(pattern);
1190             XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
1191             XSRETURN(2);
1192         } else {
1193             /* Scalar, so use the string that Perl would return */
1194             /* return the pattern in (?msix:..) format */
1195 #if PERL_VERSION >= 11
1196             pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
1197 #else
1198             pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1199                                      (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
1200 #endif
1201             XPUSHs(pattern);
1202             XSRETURN(1);
1203         }
1204     } else {
1205         /* It ain't a regexp folks */
1206         if ( GIMME_V == G_ARRAY ) {
1207             /* return the empty list */
1208             XSRETURN_UNDEF;
1209         } else {
1210             /* Because of the (?:..) wrapping involved in a
1211                stringified pattern it is impossible to get a
1212                result for a real regexp that would evaluate to
1213                false. Therefore we can return PL_sv_no to signify
1214                that the object is not a regex, this means that one
1215                can say
1216
1217                  if (regex($might_be_a_regex) eq '(?:foo)') { }
1218
1219                and not worry about undefined values.
1220             */
1221             XSRETURN_NO;
1222         }
1223     }
1224     /* NOT-REACHED */
1225 }
1226
1227 struct xsub_details {
1228     const char *name;
1229     XSUBADDR_t xsub;
1230     const char *proto;
1231 };
1232
1233 struct xsub_details details[] = {
1234     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1235     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1236     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1237     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1238     {"version::()", XS_version_noop, NULL},
1239     {"version::new", XS_version_new, NULL},
1240     {"version::parse", XS_version_new, NULL},
1241     {"version::(\"\"", XS_version_stringify, NULL},
1242     {"version::stringify", XS_version_stringify, NULL},
1243     {"version::(0+", XS_version_numify, NULL},
1244     {"version::numify", XS_version_numify, NULL},
1245     {"version::normal", XS_version_normal, NULL},
1246     {"version::(cmp", XS_version_vcmp, NULL},
1247     {"version::(<=>", XS_version_vcmp, NULL},
1248     {"version::vcmp", XS_version_vcmp, NULL},
1249     {"version::(bool", XS_version_boolean, NULL},
1250     {"version::boolean", XS_version_boolean, NULL},
1251     {"version::(nomethod", XS_version_noop, NULL},
1252     {"version::noop", XS_version_noop, NULL},
1253     {"version::is_alpha", XS_version_is_alpha, NULL},
1254     {"version::qv", XS_version_qv, NULL},
1255     {"version::declare", XS_version_qv, NULL},
1256     {"version::is_qv", XS_version_is_qv, NULL},
1257     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1258     {"utf8::valid", XS_utf8_valid, NULL},
1259     {"utf8::encode", XS_utf8_encode, NULL},
1260     {"utf8::decode", XS_utf8_decode, NULL},
1261     {"utf8::upgrade", XS_utf8_upgrade, NULL},
1262     {"utf8::downgrade", XS_utf8_downgrade, NULL},
1263     {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1264     {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1265     {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1266     {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1267     {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1268     {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1269     {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1270     {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1271     {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1272     {"re::is_regexp", XS_re_is_regexp, "$"},
1273     {"re::regname", XS_re_regname, ";$$"},
1274     {"re::regnames", XS_re_regnames, ";$"},
1275     {"re::regnames_count", XS_re_regnames_count, ""},
1276     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1277 };
1278
1279 void
1280 Perl_boot_core_UNIVERSAL(pTHX)
1281 {
1282     dVAR;
1283     static const char file[] = __FILE__;
1284     struct xsub_details *xsub = details;
1285     const struct xsub_details *end
1286         = details + sizeof(details) / sizeof(details[0]);
1287
1288     do {
1289         newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1290     } while (++xsub < end);
1291
1292     /* register the overloading (type 'A') magic */
1293     PL_amagic_generation++;
1294
1295     /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
1296     CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1297         = (char *)file;
1298 }
1299
1300 /*
1301  * Local variables:
1302  * c-indentation-style: bsd
1303  * c-basic-offset: 4
1304  * indent-tabs-mode: t
1305  * End:
1306  *
1307  * ex: set ts=8 sts=4 sw=4 noet:
1308  */