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 != 2)
 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
 362 {
 363     PUSHs(new_version(version));
 364 }
 365
 366         PUTBACK;
 367         return;
 368     }
 369 }
 370
 371 XS(XS_version_stringify)
 372 {
 373     dXSARGS;
 374     if (items < 1)
 375         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 376     SP -= items;
 377     {
 378         SV *    lobj;
 379
 380         if (sv_derived_from(ST(0), "version")) {
 381                 SV *tmp = SvRV(ST(0));
 382                 lobj = tmp;
 383         }
 384         else
 385                 Perl_croak(aTHX_ "lobj is not of type version");
 386
 387 {
 388     PUSHs(vstringify(lobj));
 389 }
 390
 391         PUTBACK;
 392         return;
 393     }
 394 }
 395
 396 XS(XS_version_numify)
 397 {
 398     dXSARGS;
 399     if (items < 1)
 400         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 401     SP -= items;
 402     {
 403         SV *    lobj;
 404
 405         if (sv_derived_from(ST(0), "version")) {
 406                 SV *tmp = SvRV(ST(0));
 407                 lobj = tmp;
 408         }
 409         else
 410                 Perl_croak(aTHX_ "lobj is not of type version");
 411
 412 {
 413     PUSHs(vnumify(lobj));
 414 }
 415
 416         PUTBACK;
 417         return;
 418     }
 419 }
 420
 421 XS(XS_version_vcmp)
 422 {
 423     dXSARGS;
 424     if (items < 1)
 425         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 426     SP -= items;
 427     {
 428         SV *    lobj;
 429
 430         if (sv_derived_from(ST(0), "version")) {
 431                 SV *tmp = SvRV(ST(0));
 432                 lobj = tmp;
 433         }
 434         else
 435                 Perl_croak(aTHX_ "lobj is not of type version");
 436
 437 {
 438     SV  *rs;
 439     SV  *rvs;
 440     SV * robj = ST(1);
 441     IV   swap = (IV)SvIV(ST(2));
 442
 443     if ( ! sv_derived_from(robj, "version") )
 444     {
 445         robj = new_version(robj);
 446     }
 447     rvs = SvRV(robj);
 448
 449     if ( swap )
 450     {
 451         rs = newSViv(vcmp(rvs,lobj));
 452     }
 453     else
 454     {
 455         rs = newSViv(vcmp(lobj,rvs));
 456     }
 457
 458     PUSHs(rs);
 459 }
 460
 461         PUTBACK;
 462         return;
 463     }
 464 }
 465
 466 XS(XS_version_boolean)
 467 {
 468     dXSARGS;
 469     if (items < 1)
 470         Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 471     SP -= items;
 472     {
 473         SV *    lobj;
 474
 475         if (sv_derived_from(ST(0), "version")) {
 476                 SV *tmp = SvRV(ST(0));
 477                 lobj = tmp;
 478         }
 479         else
 480                 Perl_croak(aTHX_ "lobj is not of type version");
 481
 482 {
 483     SV  *rs;
 484     rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
 485     PUSHs(rs);
 486 }
 487
 488         PUTBACK;
 489         return;
 490     }
 491 }
 492
 493 XS(XS_version_noop)
 494 {
 495     dXSARGS;
 496     if (items < 1)
 497         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 498     {
 499         SV *    lobj;
 500
 501         if (sv_derived_from(ST(0), "version")) {
 502                 SV *tmp = SvRV(ST(0));
 503                 lobj = tmp;
 504         }
 505         else
 506                 Perl_croak(aTHX_ "lobj is not of type version");
 507
 508 {
 509     Perl_croak(aTHX_ "operation not supported with version object");
 510 }
 511
 512     }
 513     XSRETURN_EMPTY;
 514 }
 515
 516 XS(XS_utf8_valid)
 517 {
 518     dXSARGS;
 519     if (items != 1)
 520         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 521     {
 522         SV *    sv = ST(0);
 523  {
 524   STRLEN len;
 525   char *s = SvPV(sv,len);
 526   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 527    XSRETURN_YES;
 528   else
 529    XSRETURN_NO;
 530  }
 531     }
 532     XSRETURN_EMPTY;
 533 }
 534
 535 XS(XS_utf8_encode)
 536 {
 537     dXSARGS;
 538     if (items != 1)
 539         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 540     {
 541         SV *    sv = ST(0);
 542
 543         sv_utf8_encode(sv);
 544     }
 545     XSRETURN_EMPTY;
 546 }
 547
 548 XS(XS_utf8_decode)
 549 {
 550     dXSARGS;
 551     if (items != 1)
 552         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 553     {
 554         SV *    sv = ST(0);
 555         bool    RETVAL;
 556
 557         RETVAL = sv_utf8_decode(sv);
 558         ST(0) = boolSV(RETVAL);
 559         sv_2mortal(ST(0));
 560     }
 561     XSRETURN(1);
 562 }
 563
 564 XS(XS_utf8_upgrade)
 565 {
 566     dXSARGS;
 567     if (items != 1)
 568         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 569     {
 570         SV *    sv = ST(0);
 571         STRLEN  RETVAL;
 572         dXSTARG;
 573
 574         RETVAL = sv_utf8_upgrade(sv);
 575         XSprePUSH; PUSHi((IV)RETVAL);
 576     }
 577     XSRETURN(1);
 578 }
 579
 580 XS(XS_utf8_downgrade)
 581 {
 582     dXSARGS;
 583     if (items < 1 || items > 2)
 584         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 585     {
 586         SV *    sv = ST(0);
 587         bool    failok;
 588         bool    RETVAL;
 589
 590         if (items < 2)
 591             failok = 0;
 592         else {
 593             failok = (int)SvIV(ST(1));
 594         }
 595
 596         RETVAL = sv_utf8_downgrade(sv, failok);
 597         ST(0) = boolSV(RETVAL);
 598         sv_2mortal(ST(0));
 599     }
 600     XSRETURN(1);
 601 }
 602
 603 XS(XS_utf8_native_to_unicode)
 604 {
 605  dXSARGS;
 606  UV uv = SvUV(ST(0));
 607
 608  if (items > 1)
 609      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 610
 611  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 612  XSRETURN(1);
 613 }
 614
 615 XS(XS_utf8_unicode_to_native)
 616 {
 617  dXSARGS;
 618  UV uv = SvUV(ST(0));
 619
 620  if (items > 1)
 621      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 622
 623  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 624  XSRETURN(1);
 625 }
 626
 627 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 628 {
 629     dXSARGS;
 630     SV *sv = SvRV(ST(0));
 631     if (items == 1) {
 632          if (SvREADONLY(sv))
 633              XSRETURN_YES;
 634          else
 635              XSRETURN_NO;
 636     }
 637     else if (items == 2) {
 638         if (SvTRUE(ST(1))) {
 639             SvREADONLY_on(sv);
 640             XSRETURN_YES;
 641         }
 642         else {
 643             /* I hope you really know what you are doing. */
 644             SvREADONLY_off(sv);
 645             XSRETURN_NO;
 646         }
 647     }
 648     XSRETURN_UNDEF; /* Can't happen. */
 649 }
 650
 651 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 652 {
 653     dXSARGS;
 654     SV *sv = SvRV(ST(0));
 655     if (items == 1)
 656          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 657     else if (items == 2) {
 658          /* I hope you really know what you are doing. */
 659          SvREFCNT(sv) = SvIV(ST(1));
 660          XSRETURN_IV(SvREFCNT(sv));
 661     }
 662     XSRETURN_UNDEF; /* Can't happen. */
 663 }
 664
 665 /* Maybe this should return the number of placeholders found in scalar context,
 666    and a list of them in list context.  */
 667 XS(XS_Internals_hv_clear_placehold)
 668 {
 669     dXSARGS;
 670     HV *hv = (HV *) SvRV(ST(0));
 671
 672     /* I don't care how many parameters were passed in, but I want to avoid
 673        the unused variable warning. */
 674
 675     items = (I32)HvPLACEHOLDERS(hv);
 676
 677     if (items) {
 678         HE *entry;
 679         I32 riter = HvRITER(hv);
 680         HE *eiter = HvEITER(hv);
 681         hv_iterinit(hv);
 682         /* This may look suboptimal with the items *after* the iternext, but
 683            it's quite deliberate. We only get here with items==0 if we've
 684            just deleted the last placeholder in the hash. If we've just done
 685            that then it means that the hash is in lazy delete mode, and the
 686            HE is now only referenced in our iterator. If we just quit the loop
 687            and discarded our iterator then the HE leaks. So we do the && the
 688            other way to ensure iternext is called just one more time, which
 689            has the side effect of triggering the lazy delete.  */
 690         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 691             && items) {
 692             SV *val = hv_iterval(hv, entry);
 693
 694             if (val == &PL_sv_undef) {
 695
 696                 /* It seems that I have to go back in the front of the hash
 697                    API to delete a hash, even though I have a HE structure
 698                    pointing to the very entry I want to delete, and could hold
 699                    onto the previous HE that points to it. And it's easier to
 700                    go in with SVs as I can then specify the precomputed hash,
 701                    and don't have fun and games with utf8 keys.  */
 702                 SV *key = hv_iterkeysv(entry);
 703
 704                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 705                 items--;
 706             }
 707         }
 708         HvRITER(hv) = riter;
 709         HvEITER(hv) = eiter;
 710     }
 711
 712     XSRETURN(0);
 713 }