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 %s for @%s::ISA",
  98                             SvPVX(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         XSRETURN_UNDEF;
 237
 238     name = (char *)SvPV(ST(1),n_a);
 239
 240     ST(0) = boolSV(sv_derived_from(sv, name));
 241     XSRETURN(1);
 242 }
 243
 244 XS(XS_UNIVERSAL_can)
 245 {
 246     dXSARGS;
 247     SV   *sv;
 248     char *name;
 249     SV   *rv;
 250     HV   *pkg = NULL;
 251     STRLEN n_a;
 252
 253     if (items != 2)
 254         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 255
 256     sv = ST(0);
 257
 258     if (SvGMAGICAL(sv))
 259         mg_get(sv);
 260
 261     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 262         XSRETURN_UNDEF;
 263
 264     name = (char *)SvPV(ST(1),n_a);
 265     rv = &PL_sv_undef;
 266
 267     if (SvROK(sv)) {
 268         sv = (SV*)SvRV(sv);
 269         if (SvOBJECT(sv))
 270             pkg = SvSTASH(sv);
 271     }
 272     else {
 273         pkg = gv_stashsv(sv, FALSE);
 274     }
 275
 276     if (pkg) {
 277         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 278         if (gv && isGV(gv))
 279             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 280     }
 281
 282     ST(0) = rv;
 283     XSRETURN(1);
 284 }
 285
 286 XS(XS_UNIVERSAL_VERSION)
 287 {
 288     dXSARGS;
 289     HV *pkg;
 290     GV **gvp;
 291     GV *gv;
 292     SV *sv;
 293     char *undef;
 294
 295     if (SvROK(ST(0))) {
 296         sv = (SV*)SvRV(ST(0));
 297         if (!SvOBJECT(sv))
 298             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 299         pkg = SvSTASH(sv);
 300     }
 301     else {
 302         pkg = gv_stashsv(ST(0), FALSE);
 303     }
 304
 305     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 306
 307     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 308         SV *nsv = sv_newmortal();
 309         sv_setsv(nsv, sv);
 310         sv = nsv;
 311         undef = Nullch;
 312     }
 313     else {
 314         sv = (SV*)&PL_sv_undef;
 315         undef = "(undef)";
 316     }
 317
 318     if (items > 1) {
 319         STRLEN len;
 320         SV *req = ST(1);
 321
 322         if (undef) {
 323              if (pkg)
 324                   Perl_croak(aTHX_
 325                              "%s does not define $%s::VERSION--version check failed",
 326                              HvNAME(pkg), HvNAME(pkg));
 327              else {
 328                   char *str = SvPVx(ST(0), len);
 329
 330                   Perl_croak(aTHX_
 331                              "%s defines neither package nor VERSION--version check failed", str);
 332              }
 333         }
 334         if ( !sv_derived_from(sv, "version"))
 335             sv = new_version(sv);
 336
 337         if ( !sv_derived_from(req, "version"))
 338             req = new_version(req);
 339
 340         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
 341             Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
 342                 HvNAME(pkg), req, sv);
 343     }
 344
 345     ST(0) = sv;
 346
 347     XSRETURN(1);
 348 }
 349
 350 XS(XS_version_new)
 351 {
 352     dXSARGS;
 353     if (items != 2)
 354         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 355     SP -= items;
 356     {
 357 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
 358         SV *    version = ST(1);
 359
 360 {
 361     PUSHs(new_version(version));
 362 }
 363
 364         PUTBACK;
 365         return;
 366     }
 367 }
 368
 369 XS(XS_version_stringify)
 370 {
 371     dXSARGS;
 372     if (items < 1)
 373         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 374     SP -= items;
 375     {
 376         SV *    lobj;
 377
 378         if (sv_derived_from(ST(0), "version")) {
 379                 SV *tmp = SvRV(ST(0));
 380                 lobj = tmp;
 381         }
 382         else
 383                 Perl_croak(aTHX_ "lobj is not of type version");
 384
 385 {
 386     PUSHs(vstringify(lobj));
 387 }
 388
 389         PUTBACK;
 390         return;
 391     }
 392 }
 393
 394 XS(XS_version_numify)
 395 {
 396     dXSARGS;
 397     if (items < 1)
 398         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 399     SP -= items;
 400     {
 401         SV *    lobj;
 402
 403         if (sv_derived_from(ST(0), "version")) {
 404                 SV *tmp = SvRV(ST(0));
 405                 lobj = tmp;
 406         }
 407         else
 408                 Perl_croak(aTHX_ "lobj is not of type version");
 409
 410 {
 411     PUSHs(vnumify(lobj));
 412 }
 413
 414         PUTBACK;
 415         return;
 416     }
 417 }
 418
 419 XS(XS_version_vcmp)
 420 {
 421     dXSARGS;
 422     if (items < 1)
 423         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 424     SP -= items;
 425     {
 426         SV *    lobj;
 427
 428         if (sv_derived_from(ST(0), "version")) {
 429                 SV *tmp = SvRV(ST(0));
 430                 lobj = tmp;
 431         }
 432         else
 433                 Perl_croak(aTHX_ "lobj is not of type version");
 434
 435 {
 436     SV  *rs;
 437     SV  *rvs;
 438     SV * robj = ST(1);
 439     IV   swap = (IV)SvIV(ST(2));
 440
 441     if ( ! sv_derived_from(robj, "version") )
 442     {
 443         robj = new_version(robj);
 444     }
 445     rvs = SvRV(robj);
 446
 447     if ( swap )
 448     {
 449         rs = newSViv(vcmp(rvs,lobj));
 450     }
 451     else
 452     {
 453         rs = newSViv(vcmp(lobj,rvs));
 454     }
 455
 456     PUSHs(rs);
 457 }
 458
 459         PUTBACK;
 460         return;
 461     }
 462 }
 463
 464 XS(XS_version_boolean)
 465 {
 466     dXSARGS;
 467     if (items < 1)
 468         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 469     SP -= items;
 470     {
 471         SV *    lobj;
 472
 473         if (sv_derived_from(ST(0), "version")) {
 474                 SV *tmp = SvRV(ST(0));
 475                 lobj = tmp;
 476         }
 477         else
 478                 Perl_croak(aTHX_ "lobj is not of type version");
 479
 480 {
 481     SV  *rs;
 482     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
 483     PUSHs(rs);
 484 }
 485
 486         PUTBACK;
 487         return;
 488     }
 489 }
 490
 491 XS(XS_version_noop)
 492 {
 493     dXSARGS;
 494     if (items < 1)
 495         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 496     {
 497         SV *    lobj;
 498
 499         if (sv_derived_from(ST(0), "version")) {
 500                 SV *tmp = SvRV(ST(0));
 501                 lobj = tmp;
 502         }
 503         else
 504                 Perl_croak(aTHX_ "lobj is not of type version");
 505
 506 {
 507     Perl_croak(aTHX_ "operation not supported with version object");
 508 }
 509
 510     }
 511     XSRETURN_EMPTY;
 512 }
 513
 514 XS(XS_utf8_valid)
 515 {
 516     dXSARGS;
 517     if (items != 1)
 518         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 519     {
 520         SV *    sv = ST(0);
 521  {
 522   STRLEN len;
 523   char *s = SvPV(sv,len);
 524   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 525    XSRETURN_YES;
 526   else
 527    XSRETURN_NO;
 528  }
 529     }
 530     XSRETURN_EMPTY;
 531 }
 532
 533 XS(XS_utf8_encode)
 534 {
 535     dXSARGS;
 536     if (items != 1)
 537         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 538     {
 539         SV *    sv = ST(0);
 540
 541         sv_utf8_encode(sv);
 542     }
 543     XSRETURN_EMPTY;
 544 }
 545
 546 XS(XS_utf8_decode)
 547 {
 548     dXSARGS;
 549     if (items != 1)
 550         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 551     {
 552         SV *    sv = ST(0);
 553         bool    RETVAL;
 554
 555         RETVAL = sv_utf8_decode(sv);
 556         ST(0) = boolSV(RETVAL);
 557         sv_2mortal(ST(0));
 558     }
 559     XSRETURN(1);
 560 }
 561
 562 XS(XS_utf8_upgrade)
 563 {
 564     dXSARGS;
 565     if (items != 1)
 566         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 567     {
 568         SV *    sv = ST(0);
 569         STRLEN  RETVAL;
 570         dXSTARG;
 571
 572         RETVAL = sv_utf8_upgrade(sv);
 573         XSprePUSH; PUSHi((IV)RETVAL);
 574     }
 575     XSRETURN(1);
 576 }
 577
 578 XS(XS_utf8_downgrade)
 579 {
 580     dXSARGS;
 581     if (items < 1 || items > 2)
 582         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 583     {
 584         SV *    sv = ST(0);
 585         bool    failok;
 586         bool    RETVAL;
 587
 588         if (items < 2)
 589             failok = 0;
 590         else {
 591             failok = (int)SvIV(ST(1));
 592         }
 593
 594         RETVAL = sv_utf8_downgrade(sv, failok);
 595         ST(0) = boolSV(RETVAL);
 596         sv_2mortal(ST(0));
 597     }
 598     XSRETURN(1);
 599 }
 600
 601 XS(XS_utf8_native_to_unicode)
 602 {
 603  dXSARGS;
 604  UV uv = SvUV(ST(0));
 605
 606  if (items > 1)
 607      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 608
 609  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 610  XSRETURN(1);
 611 }
 612
 613 XS(XS_utf8_unicode_to_native)
 614 {
 615  dXSARGS;
 616  UV uv = SvUV(ST(0));
 617
 618  if (items > 1)
 619      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 620
 621  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 622  XSRETURN(1);
 623 }
 624
 625 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 626 {
 627     dXSARGS;
 628     SV *sv = SvRV(ST(0));
 629     if (items == 1) {
 630          if (SvREADONLY(sv))
 631              XSRETURN_YES;
 632          else
 633              XSRETURN_NO;
 634     }
 635     else if (items == 2) {
 636         if (SvTRUE(ST(1))) {
 637             SvREADONLY_on(sv);
 638             XSRETURN_YES;
 639         }
 640         else {
 641             /* I hope you really know what you are doing. */
 642             SvREADONLY_off(sv);
 643             XSRETURN_NO;
 644         }
 645     }
 646     XSRETURN_UNDEF; /* Can't happen. */
 647 }
 648
 649 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 650 {
 651     dXSARGS;
 652     SV *sv = SvRV(ST(0));
 653     if (items == 1)
 654          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 655     else if (items == 2) {
 656          /* I hope you really know what you are doing. */
 657          SvREFCNT(sv) = SvIV(ST(1));
 658          XSRETURN_IV(SvREFCNT(sv));
 659     }
 660     XSRETURN_UNDEF; /* Can't happen. */
 661 }
 662
 663 /* Maybe this should return the number of placeholders found in scalar context,
 664    and a list of them in list context.  */
 665 XS(XS_Internals_hv_clear_placehold)
 666 {
 667     dXSARGS;
 668     HV *hv = (HV *) SvRV(ST(0));
 669
 670     /* I don't care how many parameters were passed in, but I want to avoid
 671        the unused variable warning. */
 672
 673     items = (I32)HvPLACEHOLDERS(hv);
 674
 675     if (items) {
 676         HE *entry;
 677         I32 riter = HvRITER(hv);
 678         HE *eiter = HvEITER(hv);
 679         hv_iterinit(hv);
 680         /* This may look suboptimal with the items *after* the iternext, but
 681            it's quite deliberate. We only get here with items==0 if we've
 682            just deleted the last placeholder in the hash. If we've just done
 683            that then it means that the hash is in lazy delete mode, and the
 684            HE is now only referenced in our iterator. If we just quit the loop
 685            and discarded our iterator then the HE leaks. So we do the && the
 686            other way to ensure iternext is called just one more time, which
 687            has the side effect of triggering the lazy delete.  */
 688         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 689             && items) {
 690             SV *val = hv_iterval(hv, entry);
 691
 692             if (val == &PL_sv_undef) {
 693
 694                 /* It seems that I have to go back in the front of the hash
 695                    API to delete a hash, even though I have a HE structure
 696                    pointing to the very entry I want to delete, and could hold
 697                    onto the previous HE that points to it. And it's easier to
 698                    go in with SVs as I can then specify the precomputed hash,
 699                    and don't have fun and games with utf8 keys.  */
 700                 SV *key = hv_iterkeysv(entry);
 701
 702                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 703                 items--;
 704             }
 705         }
 706         HvRITER(hv) = riter;
 707         HvEITER(hv) = eiter;
 708     }
 709
 710     XSRETURN(0);
 711 }