universal.c

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