universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (c) 1997-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "The roots of those mountains must be roots indeed; there must be
  12  * great secrets buried there which have not been discovered since the
  13  * beginning." --Gandalf, relating Gollum's story
  14  */
  15
  16 #include "EXTERN.h"
  17 #define PERL_IN_UNIVERSAL_C
  18 #include "perl.h"
  19
  20 /*
  21  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  22  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  23  */
  24
  25 STATIC SV *
  26 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
  27              int len, int level)
  28 {
  29     AV* av;
  30     GV* gv;
  31     GV** gvp;
  32     HV* hv = Nullhv;
  33     SV* subgen = Nullsv;
  34
  35     /* A stash/class can go by many names (ie. User == main::User), so
  36        we compare the stash itself just in case */
  37     if (name_stash && (stash == name_stash))
  38         return &PL_sv_yes;
  39
  40     if (strEQ(HvNAME(stash), name))
  41         return &PL_sv_yes;
  42
  43     if (level > 100)
  44         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  45                    HvNAME(stash));
  46
  47     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  48
  49     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  50         && (hv = GvHV(gv)))
  51     {
  52         if (SvIV(subgen) == (IV)PL_sub_generation) {
  53             SV* sv;
  54             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
  55             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
  56                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  57                                   name, HvNAME(stash)) );
  58                 return sv;
  59             }
  60         }
  61         else {
  62             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  63                               HvNAME(stash)) );
  64             hv_clear(hv);
  65             sv_setiv(subgen, PL_sub_generation);
  66         }
  67     }
  68
  69     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  70
  71     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  72         if (!hv || !subgen) {
  73             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  74
  75             gv = *gvp;
  76
  77             if (SvTYPE(gv) != SVt_PVGV)
  78                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  79
  80             if (!hv)
  81                 hv = GvHVn(gv);
  82             if (!subgen) {
  83                 subgen = newSViv(PL_sub_generation);
  84                 GvSV(gv) = subgen;
  85             }
  86         }
  87         if (hv) {
  88             SV** svp = AvARRAY(av);
  89             /* NOTE: No support for tied ISA */
  90             I32 items = AvFILLp(av) + 1;
  91             while (items--) {
  92                 SV* sv = *svp++;
  93                 HV* basestash = gv_stashsv(sv, FALSE);
  94                 if (!basestash) {
  95                     if (ckWARN(WARN_MISC))
  96                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
  97                              "Can't locate package %"SVf" for @%s::ISA",
  98                             sv, HvNAME(stash));
  99                     continue;
 100                 }
 101                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
 102                                              len, level + 1)) {
 103                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 104                     return &PL_sv_yes;
 105                 }
 106             }
 107             (void)hv_store(hv,name,len,&PL_sv_no,0);
 108         }
 109     }
 110
 111     return boolSV(strEQ(name, "UNIVERSAL"));
 112 }
 113
 114 /*
 115 =head1 SV Manipulation Functions
 116
 117 =for apidoc sv_derived_from
 118
 119 Returns a boolean indicating whether the SV is derived from the specified
 120 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
 121 for class names as well as for objects.
 122
 123 =cut
 124 */
 125
 126 bool
 127 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 128 {
 129     char *type;
 130     HV *stash;
 131     HV *name_stash;
 132
 133     stash = Nullhv;
 134     type = Nullch;
 135
 136     if (SvGMAGICAL(sv))
 137         mg_get(sv) ;
 138
 139     if (SvROK(sv)) {
 140         sv = SvRV(sv);
 141         type = sv_reftype(sv,0);
 142         if (SvOBJECT(sv))
 143             stash = SvSTASH(sv);
 144     }
 145     else {
 146         stash = gv_stashsv(sv, FALSE);
 147     }
 148
 149     name_stash = gv_stashpv(name, FALSE);
 150
 151     return (type && strEQ(type,name)) ||
 152             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
 153              == &PL_sv_yes)
 154         ? TRUE
 155         : FALSE ;
 156 }
 157
 158 #include "XSUB.h"
 159
 160 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 161 void XS_UNIVERSAL_can(pTHX_ CV *cv);
 162 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 163 XS(XS_version_new);
 164 XS(XS_version_stringify);
 165 XS(XS_version_numify);
 166 XS(XS_version_vcmp);
 167 XS(XS_version_boolean);
 168 XS(XS_version_noop);
 169 XS(XS_utf8_valid);
 170 XS(XS_utf8_encode);
 171 XS(XS_utf8_decode);
 172 XS(XS_utf8_upgrade);
 173 XS(XS_utf8_downgrade);
 174 XS(XS_utf8_unicode_to_native);
 175 XS(XS_utf8_native_to_unicode);
 176 XS(XS_Internals_SvREADONLY);
 177 XS(XS_Internals_SvREFCNT);
 178 XS(XS_Internals_hv_clear_placehold);
 179
 180 void
 181 Perl_boot_core_UNIVERSAL(pTHX)
 182 {
 183     char *file = __FILE__;
 184
 185     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 186     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 187     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 188     {
 189         /* register the overloading (type 'A') magic */
 190         PL_amagic_generation++;
 191         /* Make it findable via fetchmethod */
 192         newXS("version::()", XS_version_noop, file);
 193         newXS("version::new", XS_version_new, file);
 194         newXS("version::(\"\"", XS_version_stringify, file);
 195         newXS("version::stringify", XS_version_stringify, file);
 196         newXS("version::(0+", XS_version_numify, file);
 197         newXS("version::numify", XS_version_numify, file);
 198         newXS("version::(cmp", XS_version_vcmp, file);
 199         newXS("version::(<=>", XS_version_vcmp, file);
 200         newXS("version::vcmp", XS_version_vcmp, file);
 201         newXS("version::(bool", XS_version_boolean, file);
 202         newXS("version::boolean", XS_version_boolean, file);
 203         newXS("version::(nomethod", XS_version_noop, file);
 204         newXS("version::noop", XS_version_noop, file);
 205     }
 206     newXS("utf8::valid", XS_utf8_valid, file);
 207     newXS("utf8::encode", XS_utf8_encode, file);
 208     newXS("utf8::decode", XS_utf8_decode, file);
 209     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 210     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 211     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 212     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 213     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 214     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 215     newXSproto("Internals::hv_clear_placeholders",
 216                XS_Internals_hv_clear_placehold, file, "\\%");
 217 }
 218
 219
 220 XS(XS_UNIVERSAL_isa)
 221 {
 222     dXSARGS;
 223     SV *sv;
 224     char *name;
 225     STRLEN n_a;
 226
 227     if (items != 2)
 228         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 229
 230     sv = ST(0);
 231
 232     if (SvGMAGICAL(sv))
 233         mg_get(sv);
 234
 235     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 236                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 237         XSRETURN_UNDEF;
 238
 239     name = (char *)SvPV(ST(1),n_a);
 240
 241     ST(0) = boolSV(sv_derived_from(sv, name));
 242     XSRETURN(1);
 243 }
 244
 245 XS(XS_UNIVERSAL_can)
 246 {
 247     dXSARGS;
 248     SV   *sv;
 249     char *name;
 250     SV   *rv;
 251     HV   *pkg = NULL;
 252     STRLEN n_a;
 253
 254     if (items != 2)
 255         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 256
 257     sv = ST(0);
 258
 259     if (SvGMAGICAL(sv))
 260         mg_get(sv);
 261
 262     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 263                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 264         XSRETURN_UNDEF;
 265
 266     name = (char *)SvPV(ST(1),n_a);
 267     rv = &PL_sv_undef;
 268
 269     if (SvROK(sv)) {
 270         sv = (SV*)SvRV(sv);
 271         if (SvOBJECT(sv))
 272             pkg = SvSTASH(sv);
 273     }
 274     else {
 275         pkg = gv_stashsv(sv, FALSE);
 276     }
 277
 278     if (pkg) {
 279         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 280         if (gv && isGV(gv))
 281             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 282     }
 283
 284     ST(0) = rv;
 285     XSRETURN(1);
 286 }
 287
 288 XS(XS_UNIVERSAL_VERSION)
 289 {
 290     dXSARGS;
 291     HV *pkg;
 292     GV **gvp;
 293     GV *gv;
 294     SV *sv;
 295     char *undef;
 296
 297     if (SvROK(ST(0))) {
 298         sv = (SV*)SvRV(ST(0));
 299         if (!SvOBJECT(sv))
 300             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 301         pkg = SvSTASH(sv);
 302     }
 303     else {
 304         pkg = gv_stashsv(ST(0), FALSE);
 305     }
 306
 307     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 308
 309     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 310         SV *nsv = sv_newmortal();
 311         sv_setsv(nsv, sv);
 312         sv = nsv;
 313         undef = Nullch;
 314     }
 315     else {
 316         sv = (SV*)&PL_sv_undef;
 317         undef = "(undef)";
 318     }
 319
 320     if (items > 1) {
 321         STRLEN len;
 322         SV *req = ST(1);
 323
 324         if (undef) {
 325              if (pkg)
 326                   Perl_croak(aTHX_
 327                              "%s does not define $%s::VERSION--version check failed",
 328                              HvNAME(pkg), HvNAME(pkg));
 329              else {
 330                   char *str = SvPVx(ST(0), len);
 331
 332                   Perl_croak(aTHX_
 333                              "%s defines neither package nor VERSION--version check failed", str);
 334              }
 335         }
 336         if ( !sv_derived_from(sv, "version"))
 337             sv = new_version(sv);
 338
 339         if ( !sv_derived_from(req, "version"))
 340             req = new_version(req);
 341
 342         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
 343             Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
 344                 HvNAME(pkg), req, sv);
 345     }
 346
 347     ST(0) = sv;
 348
 349     XSRETURN(1);
 350 }
 351
 352 XS(XS_version_new)
 353 {
 354     dXSARGS;
 355     if (items > 3)
 356         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 357     SP -= items;
 358     {
 359 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
 360         SV *version = ST(1);
 361         if (items == 3 )
 362         {
 363             char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
 364             version = newSVpvf("v%s",vs);
 365         }
 366
 367         PUSHs(new_version(version));
 368         PUTBACK;
 369         return;
 370     }
 371 }
 372
 373 XS(XS_version_stringify)
 374 {
 375     dXSARGS;
 376     if (items < 1)
 377         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 378     SP -= items;
 379     {
 380         SV *    lobj;
 381
 382         if (sv_derived_from(ST(0), "version")) {
 383                 SV *tmp = SvRV(ST(0));
 384                 lobj = tmp;
 385         }
 386         else
 387                 Perl_croak(aTHX_ "lobj is not of type version");
 388
 389 {
 390     PUSHs(vstringify(lobj));
 391 }
 392
 393         PUTBACK;
 394         return;
 395     }
 396 }
 397
 398 XS(XS_version_numify)
 399 {
 400     dXSARGS;
 401     if (items < 1)
 402         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 403     SP -= items;
 404     {
 405         SV *    lobj;
 406
 407         if (sv_derived_from(ST(0), "version")) {
 408                 SV *tmp = SvRV(ST(0));
 409                 lobj = tmp;
 410         }
 411         else
 412                 Perl_croak(aTHX_ "lobj is not of type version");
 413
 414 {
 415     PUSHs(vnumify(lobj));
 416 }
 417
 418         PUTBACK;
 419         return;
 420     }
 421 }
 422
 423 XS(XS_version_vcmp)
 424 {
 425     dXSARGS;
 426     if (items < 1)
 427         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 428     SP -= items;
 429     {
 430         SV *    lobj;
 431
 432         if (sv_derived_from(ST(0), "version")) {
 433                 SV *tmp = SvRV(ST(0));
 434                 lobj = tmp;
 435         }
 436         else
 437                 Perl_croak(aTHX_ "lobj is not of type version");
 438
 439 {
 440     SV  *rs;
 441     SV  *rvs;
 442     SV * robj = ST(1);
 443     IV   swap = (IV)SvIV(ST(2));
 444
 445     if ( ! sv_derived_from(robj, "version") )
 446     {
 447         robj = new_version(robj);
 448     }
 449     rvs = SvRV(robj);
 450
 451     if ( swap )
 452     {
 453         rs = newSViv(vcmp(rvs,lobj));
 454     }
 455     else
 456     {
 457         rs = newSViv(vcmp(lobj,rvs));
 458     }
 459
 460     PUSHs(rs);
 461 }
 462
 463         PUTBACK;
 464         return;
 465     }
 466 }
 467
 468 XS(XS_version_boolean)
 469 {
 470     dXSARGS;
 471     if (items < 1)
 472         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 473     SP -= items;
 474     {
 475         SV *    lobj;
 476
 477         if (sv_derived_from(ST(0), "version")) {
 478                 SV *tmp = SvRV(ST(0));
 479                 lobj = tmp;
 480         }
 481         else
 482                 Perl_croak(aTHX_ "lobj is not of type version");
 483
 484 {
 485     SV  *rs;
 486     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
 487     PUSHs(rs);
 488 }
 489
 490         PUTBACK;
 491         return;
 492     }
 493 }
 494
 495 XS(XS_version_noop)
 496 {
 497     dXSARGS;
 498     if (items < 1)
 499         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 500     {
 501         SV *    lobj;
 502
 503         if (sv_derived_from(ST(0), "version")) {
 504                 SV *tmp = SvRV(ST(0));
 505                 lobj = tmp;
 506         }
 507         else
 508                 Perl_croak(aTHX_ "lobj is not of type version");
 509
 510 {
 511     Perl_croak(aTHX_ "operation not supported with version object");
 512 }
 513
 514     }
 515     XSRETURN_EMPTY;
 516 }
 517
 518 XS(XS_utf8_valid)
 519 {
 520     dXSARGS;
 521     if (items != 1)
 522         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 523     {
 524         SV *    sv = ST(0);
 525  {
 526   STRLEN len;
 527   char *s = SvPV(sv,len);
 528   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 529    XSRETURN_YES;
 530   else
 531    XSRETURN_NO;
 532  }
 533     }
 534     XSRETURN_EMPTY;
 535 }
 536
 537 XS(XS_utf8_encode)
 538 {
 539     dXSARGS;
 540     if (items != 1)
 541         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 542     {
 543         SV *    sv = ST(0);
 544
 545         sv_utf8_encode(sv);
 546     }
 547     XSRETURN_EMPTY;
 548 }
 549
 550 XS(XS_utf8_decode)
 551 {
 552     dXSARGS;
 553     if (items != 1)
 554         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 555     {
 556         SV *    sv = ST(0);
 557         bool    RETVAL;
 558
 559         RETVAL = sv_utf8_decode(sv);
 560         ST(0) = boolSV(RETVAL);
 561         sv_2mortal(ST(0));
 562     }
 563     XSRETURN(1);
 564 }
 565
 566 XS(XS_utf8_upgrade)
 567 {
 568     dXSARGS;
 569     if (items != 1)
 570         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 571     {
 572         SV *    sv = ST(0);
 573         STRLEN  RETVAL;
 574         dXSTARG;
 575
 576         RETVAL = sv_utf8_upgrade(sv);
 577         XSprePUSH; PUSHi((IV)RETVAL);
 578     }
 579     XSRETURN(1);
 580 }
 581
 582 XS(XS_utf8_downgrade)
 583 {
 584     dXSARGS;
 585     if (items < 1 || items > 2)
 586         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 587     {
 588         SV *    sv = ST(0);
 589         bool    failok;
 590         bool    RETVAL;
 591
 592         if (items < 2)
 593             failok = 0;
 594         else {
 595             failok = (int)SvIV(ST(1));
 596         }
 597
 598         RETVAL = sv_utf8_downgrade(sv, failok);
 599         ST(0) = boolSV(RETVAL);
 600         sv_2mortal(ST(0));
 601     }
 602     XSRETURN(1);
 603 }
 604
 605 XS(XS_utf8_native_to_unicode)
 606 {
 607  dXSARGS;
 608  UV uv = SvUV(ST(0));
 609
 610  if (items > 1)
 611      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 612
 613  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 614  XSRETURN(1);
 615 }
 616
 617 XS(XS_utf8_unicode_to_native)
 618 {
 619  dXSARGS;
 620  UV uv = SvUV(ST(0));
 621
 622  if (items > 1)
 623      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 624
 625  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 626  XSRETURN(1);
 627 }
 628
 629 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 630 {
 631     dXSARGS;
 632     SV *sv = SvRV(ST(0));
 633     if (items == 1) {
 634          if (SvREADONLY(sv))
 635              XSRETURN_YES;
 636          else
 637              XSRETURN_NO;
 638     }
 639     else if (items == 2) {
 640         if (SvTRUE(ST(1))) {
 641             SvREADONLY_on(sv);
 642             XSRETURN_YES;
 643         }
 644         else {
 645             /* I hope you really know what you are doing. */
 646             SvREADONLY_off(sv);
 647             XSRETURN_NO;
 648         }
 649     }
 650     XSRETURN_UNDEF; /* Can't happen. */
 651 }
 652
 653 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 654 {
 655     dXSARGS;
 656     SV *sv = SvRV(ST(0));
 657     if (items == 1)
 658          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 659     else if (items == 2) {
 660          /* I hope you really know what you are doing. */
 661          SvREFCNT(sv) = SvIV(ST(1));
 662          XSRETURN_IV(SvREFCNT(sv));
 663     }
 664     XSRETURN_UNDEF; /* Can't happen. */
 665 }
 666
 667 /* Maybe this should return the number of placeholders found in scalar context,
 668    and a list of them in list context.  */
 669 XS(XS_Internals_hv_clear_placehold)
 670 {
 671     dXSARGS;
 672     HV *hv = (HV *) SvRV(ST(0));
 673
 674     /* I don't care how many parameters were passed in, but I want to avoid
 675        the unused variable warning. */
 676
 677     items = (I32)HvPLACEHOLDERS(hv);
 678
 679     if (items) {
 680         HE *entry;
 681         I32 riter = HvRITER(hv);
 682         HE *eiter = HvEITER(hv);
 683         hv_iterinit(hv);
 684         /* This may look suboptimal with the items *after* the iternext, but
 685            it's quite deliberate. We only get here with items==0 if we've
 686            just deleted the last placeholder in the hash. If we've just done
 687            that then it means that the hash is in lazy delete mode, and the
 688            HE is now only referenced in our iterator. If we just quit the loop
 689            and discarded our iterator then the HE leaks. So we do the && the
 690            other way to ensure iternext is called just one more time, which
 691            has the side effect of triggering the lazy delete.  */
 692         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 693             && items) {
 694             SV *val = hv_iterval(hv, entry);
 695
 696             if (val == &PL_sv_undef) {
 697
 698                 /* It seems that I have to go back in the front of the hash
 699                    API to delete a hash, even though I have a HE structure
 700                    pointing to the very entry I want to delete, and could hold
 701                    onto the previous HE that points to it. And it's easier to
 702                    go in with SVs as I can then specify the precomputed hash,
 703                    and don't have fun and games with utf8 keys.  */
 704                 SV *key = hv_iterkeysv(entry);
 705
 706                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 707                 items--;
 708             }
 709         }
 710         HvRITER(hv) = riter;
 711         HvEITER(hv) = eiter;
 712     }
 713
 714     XSRETURN(0);
 715 }