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_utf8_valid);
 164 XS(XS_utf8_encode);
 165 XS(XS_utf8_decode);
 166 XS(XS_utf8_upgrade);
 167 XS(XS_utf8_downgrade);
 168 XS(XS_utf8_unicode_to_native);
 169 XS(XS_utf8_native_to_unicode);
 170 XS(XS_Internals_SvREADONLY);
 171 XS(XS_Internals_SvREFCNT);
 172 XS(XS_Internals_hv_clear_placehold);
 173
 174 void
 175 Perl_boot_core_UNIVERSAL(pTHX)
 176 {
 177     char *file = __FILE__;
 178
 179     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 180     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 181     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 182     newXS("utf8::valid", XS_utf8_valid, file);
 183     newXS("utf8::encode", XS_utf8_encode, file);
 184     newXS("utf8::decode", XS_utf8_decode, file);
 185     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 186     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 187     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 188     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 189     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 190     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 191     newXSproto("Internals::hv_clear_placeholders",
 192                XS_Internals_hv_clear_placehold, file, "\\%");
 193 }
 194
 195
 196 XS(XS_UNIVERSAL_isa)
 197 {
 198     dXSARGS;
 199     SV *sv;
 200     char *name;
 201     STRLEN n_a;
 202
 203     if (items != 2)
 204         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 205
 206     sv = ST(0);
 207
 208     if (SvGMAGICAL(sv))
 209         mg_get(sv);
 210
 211     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 212         XSRETURN_UNDEF;
 213
 214     name = (char *)SvPV(ST(1),n_a);
 215
 216     ST(0) = boolSV(sv_derived_from(sv, name));
 217     XSRETURN(1);
 218 }
 219
 220 XS(XS_UNIVERSAL_can)
 221 {
 222     dXSARGS;
 223     SV   *sv;
 224     char *name;
 225     SV   *rv;
 226     HV   *pkg = NULL;
 227     STRLEN n_a;
 228
 229     if (items != 2)
 230         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 231
 232     sv = ST(0);
 233
 234     if (SvGMAGICAL(sv))
 235         mg_get(sv);
 236
 237     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
 238         XSRETURN_UNDEF;
 239
 240     name = (char *)SvPV(ST(1),n_a);
 241     rv = &PL_sv_undef;
 242
 243     if (SvROK(sv)) {
 244         sv = (SV*)SvRV(sv);
 245         if (SvOBJECT(sv))
 246             pkg = SvSTASH(sv);
 247     }
 248     else {
 249         pkg = gv_stashsv(sv, FALSE);
 250     }
 251
 252     if (pkg) {
 253         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 254         if (gv && isGV(gv))
 255             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 256     }
 257
 258     ST(0) = rv;
 259     XSRETURN(1);
 260 }
 261
 262 XS(XS_UNIVERSAL_VERSION)
 263 {
 264     dXSARGS;
 265     HV *pkg;
 266     GV **gvp;
 267     GV *gv;
 268     SV *sv;
 269     char *undef;
 270
 271     if (SvROK(ST(0))) {
 272         sv = (SV*)SvRV(ST(0));
 273         if (!SvOBJECT(sv))
 274             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 275         pkg = SvSTASH(sv);
 276     }
 277     else {
 278         pkg = gv_stashsv(ST(0), FALSE);
 279     }
 280
 281     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 282
 283     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 284         SV *nsv = sv_newmortal();
 285         sv_setsv(nsv, sv);
 286         sv = nsv;
 287         undef = Nullch;
 288     }
 289     else {
 290         sv = (SV*)&PL_sv_undef;
 291         undef = "(undef)";
 292     }
 293
 294     if (items > 1) {
 295         STRLEN len;
 296         SV *req = ST(1);
 297
 298         if (undef) {
 299              if (pkg)
 300                   Perl_croak(aTHX_
 301                              "%s does not define $%s::VERSION--version check failed",
 302                              HvNAME(pkg), HvNAME(pkg));
 303              else {
 304                   char *str = SvPVx(ST(0), len);
 305
 306                   Perl_croak(aTHX_
 307                              "%s defines neither package nor VERSION--version check failed", str);
 308              }
 309         }
 310         if (!SvNIOK(sv) && SvPOK(sv)) {
 311             char *str = SvPVx(sv,len);
 312             while (len) {
 313                 --len;
 314                 /* XXX could DWIM "1.2.3" here */
 315                 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
 316                     break;
 317             }
 318             if (len) {
 319                 if (SvNOK(req) && SvPOK(req)) {
 320                     /* they said C<use Foo v1.2.3> and $Foo::VERSION
 321                      * doesn't look like a float: do string compare */
 322                     if (sv_cmp(req,sv) == 1) {
 323                         Perl_croak(aTHX_ "%s v%"VDf" required--"
 324                                    "this is only v%"VDf,
 325                                    HvNAME(pkg), req, sv);
 326                     }
 327                     goto finish;
 328                 }
 329                 /* they said C<use Foo 1.002_003> and $Foo::VERSION
 330                  * doesn't look like a float: force numeric compare */
 331                 (void)SvUPGRADE(sv, SVt_PVNV);
 332                 SvNVX(sv) = str_to_version(sv);
 333                 SvPOK_off(sv);
 334                 SvNOK_on(sv);
 335             }
 336         }
 337         /* if we get here, we're looking for a numeric comparison,
 338          * so force the required version into a float, even if they
 339          * said C<use Foo v1.2.3> */
 340         if (SvNOK(req) && SvPOK(req)) {
 341             NV n = SvNV(req);
 342             req = sv_newmortal();
 343             sv_setnv(req, n);
 344         }
 345
 346         if (SvNV(req) > SvNV(sv))
 347             Perl_croak(aTHX_ "%s version %s required--this is only version %s",
 348                        HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
 349     }
 350
 351 finish:
 352     ST(0) = sv;
 353
 354     XSRETURN(1);
 355 }
 356
 357 XS(XS_utf8_valid)
 358 {
 359     dXSARGS;
 360     if (items != 1)
 361         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 362     {
 363         SV *    sv = ST(0);
 364  {
 365   STRLEN len;
 366   char *s = SvPV(sv,len);
 367   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 368    XSRETURN_YES;
 369   else
 370    XSRETURN_NO;
 371  }
 372     }
 373     XSRETURN_EMPTY;
 374 }
 375
 376 XS(XS_utf8_encode)
 377 {
 378     dXSARGS;
 379     if (items != 1)
 380         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 381     {
 382         SV *    sv = ST(0);
 383
 384         sv_utf8_encode(sv);
 385     }
 386     XSRETURN_EMPTY;
 387 }
 388
 389 XS(XS_utf8_decode)
 390 {
 391     dXSARGS;
 392     if (items != 1)
 393         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 394     {
 395         SV *    sv = ST(0);
 396         bool    RETVAL;
 397
 398         RETVAL = sv_utf8_decode(sv);
 399         ST(0) = boolSV(RETVAL);
 400         sv_2mortal(ST(0));
 401     }
 402     XSRETURN(1);
 403 }
 404
 405 XS(XS_utf8_upgrade)
 406 {
 407     dXSARGS;
 408     if (items != 1)
 409         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 410     {
 411         SV *    sv = ST(0);
 412         STRLEN  RETVAL;
 413         dXSTARG;
 414
 415         RETVAL = sv_utf8_upgrade(sv);
 416         XSprePUSH; PUSHi((IV)RETVAL);
 417     }
 418     XSRETURN(1);
 419 }
 420
 421 XS(XS_utf8_downgrade)
 422 {
 423     dXSARGS;
 424     if (items < 1 || items > 2)
 425         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 426     {
 427         SV *    sv = ST(0);
 428         bool    failok;
 429         bool    RETVAL;
 430
 431         if (items < 2)
 432             failok = 0;
 433         else {
 434             failok = (int)SvIV(ST(1));
 435         }
 436
 437         RETVAL = sv_utf8_downgrade(sv, failok);
 438         ST(0) = boolSV(RETVAL);
 439         sv_2mortal(ST(0));
 440     }
 441     XSRETURN(1);
 442 }
 443
 444 XS(XS_utf8_native_to_unicode)
 445 {
 446  dXSARGS;
 447  UV uv = SvUV(ST(0));
 448
 449  if (items > 1)
 450      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 451
 452  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 453  XSRETURN(1);
 454 }
 455
 456 XS(XS_utf8_unicode_to_native)
 457 {
 458  dXSARGS;
 459  UV uv = SvUV(ST(0));
 460
 461  if (items > 1)
 462      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 463
 464  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 465  XSRETURN(1);
 466 }
 467
 468 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 469 {
 470     dXSARGS;
 471     SV *sv = SvRV(ST(0));
 472     if (items == 1) {
 473          if (SvREADONLY(sv))
 474              XSRETURN_YES;
 475          else
 476              XSRETURN_NO;
 477     }
 478     else if (items == 2) {
 479         if (SvTRUE(ST(1))) {
 480             SvREADONLY_on(sv);
 481             XSRETURN_YES;
 482         }
 483         else {
 484             /* I hope you really know what you are doing. */
 485             SvREADONLY_off(sv);
 486             XSRETURN_NO;
 487         }
 488     }
 489     XSRETURN_UNDEF; /* Can't happen. */
 490 }
 491
 492 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 493 {
 494     dXSARGS;
 495     SV *sv = SvRV(ST(0));
 496     if (items == 1)
 497          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 498     else if (items == 2) {
 499          /* I hope you really know what you are doing. */
 500          SvREFCNT(sv) = SvIV(ST(1));
 501          XSRETURN_IV(SvREFCNT(sv));
 502     }
 503     XSRETURN_UNDEF; /* Can't happen. */
 504 }
 505
 506 /* Maybe this should return the number of placeholders found in scalar context,
 507    and a list of them in list context.  */
 508 XS(XS_Internals_hv_clear_placehold)
 509 {
 510     dXSARGS;
 511     HV *hv = (HV *) SvRV(ST(0));
 512
 513     /* I don't care how many parameters were passed in, but I want to avoid
 514        the unused variable warning. */
 515
 516     items = (I32)HvPLACEHOLDERS(hv);
 517
 518     if (items) {
 519         HE *entry;
 520         I32 riter = HvRITER(hv);
 521         HE *eiter = HvEITER(hv);
 522         hv_iterinit(hv);
 523         /* This may look suboptimal with the items *after* the iternext, but
 524            it's quite deliberate. We only get here with items==0 if we've
 525            just deleted the last placeholder in the hash. If we've just done
 526            that then it means that the hash is in lazy delete mode, and the
 527            HE is now only referenced in our iterator. If we just quit the loop
 528            and discarded our iterator then the HE leaks. So we do the && the
 529            other way to ensure iternext is called just one more time, which
 530            has the side effect of triggering the lazy delete.  */
 531         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 532             && items) {
 533             SV *val = hv_iterval(hv, entry);
 534
 535             if (val == &PL_sv_undef) {
 536
 537                 /* It seems that I have to go back in the front of the hash
 538                    API to delete a hash, even though I have a HE structure
 539                    pointing to the very entry I want to delete, and could hold
 540                    onto the previous HE that points to it. And it's easier to
 541                    go in with SVs as I can then specify the precomputed hash,
 542                    and don't have fun and games with utf8 keys.  */
 543                 SV *key = hv_iterkeysv(entry);
 544
 545                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 546                 items--;
 547             }
 548         }
 549         HvRITER(hv) = riter;
 550         HvEITER(hv) = eiter;
 551     }
 552
 553     XSRETURN(0);
 554 }