universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4  *    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 story
  15  */
  16
  17 #include "EXTERN.h"
  18 #define PERL_IN_UNIVERSAL_C
  19 #include "perl.h"
  20
  21 #ifdef USE_PERLIO
  22 #include "perliol.h" /* For the PERLIO_F_XXX */
  23 #endif
  24
  25 /*
  26  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  27  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  28  */
  29
  30 STATIC SV *
  31 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
  32              int len, int level)
  33 {
  34     AV* av;
  35     GV* gv;
  36     GV** gvp;
  37     HV* hv = Nullhv;
  38     SV* subgen = Nullsv;
  39
  40     /* A stash/class can go by many names (ie. User == main::User), so
  41        we compare the stash itself just in case */
  42     if (name_stash && (stash == name_stash))
  43         return &PL_sv_yes;
  44
  45     if (strEQ(HvNAME(stash), name))
  46         return &PL_sv_yes;
  47
  48     if (strEQ(name, "UNIVERSAL"))
  49         return &PL_sv_yes;
  50
  51     if (level > 100)
  52         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  53                    HvNAME(stash));
  54
  55     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  56
  57     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  58         && (hv = GvHV(gv)))
  59     {
  60         if (SvIV(subgen) == (IV)PL_sub_generation) {
  61             SV* sv;
  62             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
  63             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
  64                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  65                                   name, HvNAME(stash)) );
  66                 return sv;
  67             }
  68         }
  69         else {
  70             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  71                               HvNAME(stash)) );
  72             hv_clear(hv);
  73             sv_setiv(subgen, PL_sub_generation);
  74         }
  75     }
  76
  77     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  78
  79     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  80         if (!hv || !subgen) {
  81             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  82
  83             gv = *gvp;
  84
  85             if (SvTYPE(gv) != SVt_PVGV)
  86                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  87
  88             if (!hv)
  89                 hv = GvHVn(gv);
  90             if (!subgen) {
  91                 subgen = newSViv(PL_sub_generation);
  92                 GvSV(gv) = subgen;
  93             }
  94         }
  95         if (hv) {
  96             SV** svp = AvARRAY(av);
  97             /* NOTE: No support for tied ISA */
  98             I32 items = AvFILLp(av) + 1;
  99             while (items--) {
 100                 SV* sv = *svp++;
 101                 HV* basestash = gv_stashsv(sv, FALSE);
 102                 if (!basestash) {
 103                     if (ckWARN(WARN_MISC))
 104                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 105                              "Can't locate package %"SVf" for @%s::ISA",
 106                             sv, HvNAME(stash));
 107                     continue;
 108                 }
 109                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
 110                                              len, level + 1)) {
 111                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 112                     return &PL_sv_yes;
 113                 }
 114             }
 115             (void)hv_store(hv,name,len,&PL_sv_no,0);
 116         }
 117     }
 118     return &PL_sv_no;
 119 }
 120
 121 /*
 122 =head1 SV Manipulation Functions
 123
 124 =for apidoc sv_derived_from
 125
 126 Returns a boolean indicating whether the SV is derived from the specified
 127 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
 128 for class names as well as for objects.
 129
 130 =cut
 131 */
 132
 133 bool
 134 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 135 {
 136     char *type;
 137     HV *stash;
 138     HV *name_stash;
 139
 140     stash = Nullhv;
 141     type = Nullch;
 142
 143     if (SvGMAGICAL(sv))
 144         mg_get(sv) ;
 145
 146     if (SvROK(sv)) {
 147         sv = SvRV(sv);
 148         type = sv_reftype(sv,0);
 149         if (SvOBJECT(sv))
 150             stash = SvSTASH(sv);
 151     }
 152     else {
 153         stash = gv_stashsv(sv, FALSE);
 154     }
 155
 156     name_stash = gv_stashpv(name, FALSE);
 157
 158     return (type && strEQ(type,name)) ||
 159             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
 160              == &PL_sv_yes)
 161         ? TRUE
 162         : FALSE ;
 163 }
 164
 165 #include "XSUB.h"
 166
 167 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 168 void XS_UNIVERSAL_can(pTHX_ CV *cv);
 169 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 170 XS(XS_version_new);
 171 XS(XS_version_stringify);
 172 XS(XS_version_numify);
 173 XS(XS_version_vcmp);
 174 XS(XS_version_boolean);
 175 XS(XS_version_noop);
 176 XS(XS_version_is_alpha);
 177 XS(XS_utf8_is_utf8);
 178 XS(XS_utf8_valid);
 179 XS(XS_utf8_encode);
 180 XS(XS_utf8_decode);
 181 XS(XS_utf8_upgrade);
 182 XS(XS_utf8_downgrade);
 183 XS(XS_utf8_unicode_to_native);
 184 XS(XS_utf8_native_to_unicode);
 185 XS(XS_Internals_SvREADONLY);
 186 XS(XS_Internals_SvREFCNT);
 187 XS(XS_Internals_hv_clear_placehold);
 188 XS(XS_PerlIO_get_layers);
 189 XS(XS_Regexp_DESTROY);
 190 XS(XS_Internals_hash_seed);
 191 XS(XS_Internals_HvREHASH);
 192
 193 void
 194 Perl_boot_core_UNIVERSAL(pTHX)
 195 {
 196     char *file = __FILE__;
 197
 198     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 199     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 200     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 201     {
 202         /* register the overloading (type 'A') magic */
 203         PL_amagic_generation++;
 204         /* Make it findable via fetchmethod */
 205         newXS("version::()", XS_version_noop, file);
 206         newXS("version::new", XS_version_new, file);
 207         newXS("version::(\"\"", XS_version_stringify, file);
 208         newXS("version::stringify", XS_version_stringify, file);
 209         newXS("version::(0+", XS_version_numify, file);
 210         newXS("version::numify", XS_version_numify, file);
 211         newXS("version::(cmp", XS_version_vcmp, file);
 212         newXS("version::(<=>", XS_version_vcmp, file);
 213         newXS("version::vcmp", XS_version_vcmp, file);
 214         newXS("version::(bool", XS_version_boolean, file);
 215         newXS("version::boolean", XS_version_boolean, file);
 216         newXS("version::(nomethod", XS_version_noop, file);
 217         newXS("version::noop", XS_version_noop, file);
 218         newXS("version::is_alpha", XS_version_is_alpha, file);
 219     }
 220     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 221     newXS("utf8::valid", XS_utf8_valid, file);
 222     newXS("utf8::encode", XS_utf8_encode, file);
 223     newXS("utf8::decode", XS_utf8_decode, file);
 224     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 225     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 226     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 227     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 228     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 229     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 230     newXSproto("Internals::hv_clear_placeholders",
 231                XS_Internals_hv_clear_placehold, file, "\\%");
 232     newXSproto("PerlIO::get_layers",
 233                XS_PerlIO_get_layers, file, "*;@");
 234     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 235     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 236     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 237 }
 238
 239
 240 XS(XS_UNIVERSAL_isa)
 241 {
 242     dXSARGS;
 243     SV *sv;
 244     char *name;
 245     STRLEN n_a;
 246
 247     if (items != 2)
 248         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 249
 250     sv = ST(0);
 251
 252     if (SvGMAGICAL(sv))
 253         mg_get(sv);
 254
 255     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 256                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 257         XSRETURN_UNDEF;
 258
 259     name = (char *)SvPV(ST(1),n_a);
 260
 261     ST(0) = boolSV(sv_derived_from(sv, name));
 262     XSRETURN(1);
 263 }
 264
 265 XS(XS_UNIVERSAL_can)
 266 {
 267     dXSARGS;
 268     SV   *sv;
 269     char *name;
 270     SV   *rv;
 271     HV   *pkg = NULL;
 272     STRLEN n_a;
 273
 274     if (items != 2)
 275         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 276
 277     sv = ST(0);
 278
 279     if (SvGMAGICAL(sv))
 280         mg_get(sv);
 281
 282     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 283                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 284         XSRETURN_UNDEF;
 285
 286     name = (char *)SvPV(ST(1),n_a);
 287     rv = &PL_sv_undef;
 288
 289     if (SvROK(sv)) {
 290         sv = (SV*)SvRV(sv);
 291         if (SvOBJECT(sv))
 292             pkg = SvSTASH(sv);
 293     }
 294     else {
 295         pkg = gv_stashsv(sv, FALSE);
 296     }
 297
 298     if (pkg) {
 299         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 300         if (gv && isGV(gv))
 301             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 302     }
 303
 304     ST(0) = rv;
 305     XSRETURN(1);
 306 }
 307
 308 XS(XS_UNIVERSAL_VERSION)
 309 {
 310     dXSARGS;
 311     HV *pkg;
 312     GV **gvp;
 313     GV *gv;
 314     SV *sv;
 315     char *undef;
 316
 317     if (SvROK(ST(0))) {
 318         sv = (SV*)SvRV(ST(0));
 319         if (!SvOBJECT(sv))
 320             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 321         pkg = SvSTASH(sv);
 322     }
 323     else {
 324         pkg = gv_stashsv(ST(0), FALSE);
 325     }
 326
 327     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 328
 329     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 330         SV *nsv = sv_newmortal();
 331         sv_setsv(nsv, sv);
 332         sv = nsv;
 333         undef = Nullch;
 334     }
 335     else {
 336         sv = (SV*)&PL_sv_undef;
 337         undef = "(undef)";
 338     }
 339
 340     if (items > 1) {
 341         STRLEN len;
 342         SV *req = ST(1);
 343
 344         if (undef) {
 345              if (pkg)
 346                   Perl_croak(aTHX_
 347                              "%s does not define $%s::VERSION--version check failed",
 348                              HvNAME(pkg), HvNAME(pkg));
 349              else {
 350                   char *str = SvPVx(ST(0), len);
 351
 352                   Perl_croak(aTHX_
 353                              "%s defines neither package nor VERSION--version check failed", str);
 354              }
 355         }
 356         if ( !sv_derived_from(sv, "version"))
 357             sv = new_version(sv);
 358
 359         if ( !sv_derived_from(req, "version"))
 360             req = new_version(req);
 361
 362         if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
 363             Perl_croak(aTHX_
 364                 "%s version %"SVf" required--this is only version %"SVf,
 365                 HvNAME(pkg), req, sv);
 366     }
 367
 368     ST(0) = sv;
 369
 370     XSRETURN(1);
 371 }
 372
 373 XS(XS_version_new)
 374 {
 375     dXSARGS;
 376     if (items > 3)
 377         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 378     SP -= items;
 379     {
 380 /*      char *  class = (char *)SvPV_nolen(ST(0)); */
 381         SV *version = ST(1);
 382         if (items == 3 )
 383         {
 384             char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
 385             version = Perl_newSVpvf(aTHX_ "v%s",vs);
 386         }
 387
 388         PUSHs(new_version(version));
 389         PUTBACK;
 390         return;
 391     }
 392 }
 393
 394 XS(XS_version_stringify)
 395 {
 396      dXSARGS;
 397      if (items < 1)
 398           Perl_croak(aTHX_ "Usage: version::stringify(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(vstringify(lobj));
 412           }
 413
 414           PUTBACK;
 415           return;
 416      }
 417 }
 418
 419 XS(XS_version_numify)
 420 {
 421      dXSARGS;
 422      if (items < 1)
 423           Perl_croak(aTHX_ "Usage: version::numify(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                PUSHs(vnumify(lobj));
 437           }
 438
 439           PUTBACK;
 440           return;
 441      }
 442 }
 443
 444 XS(XS_version_vcmp)
 445 {
 446      dXSARGS;
 447      if (items < 1)
 448           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 449      SP -= items;
 450      {
 451           SV *  lobj;
 452
 453           if (sv_derived_from(ST(0), "version")) {
 454                SV *tmp = SvRV(ST(0));
 455                lobj = tmp;
 456           }
 457           else
 458                Perl_croak(aTHX_ "lobj is not of type version");
 459
 460           {
 461                SV       *rs;
 462                SV       *rvs;
 463                SV * robj = ST(1);
 464                IV        swap = (IV)SvIV(ST(2));
 465
 466                if ( ! sv_derived_from(robj, "version") )
 467                {
 468                     robj = new_version(robj);
 469                }
 470                rvs = SvRV(robj);
 471
 472                if ( swap )
 473                {
 474                     rs = newSViv(vcmp(rvs,lobj));
 475                }
 476                else
 477                {
 478                     rs = newSViv(vcmp(lobj,rvs));
 479                }
 480
 481                PUSHs(rs);
 482           }
 483
 484           PUTBACK;
 485           return;
 486      }
 487 }
 488
 489 XS(XS_version_boolean)
 490 {
 491      dXSARGS;
 492      if (items < 1)
 493           Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 494      SP -= items;
 495      {
 496           SV *  lobj;
 497
 498           if (sv_derived_from(ST(0), "version")) {
 499                SV *tmp = SvRV(ST(0));
 500                lobj = tmp;
 501           }
 502           else
 503                Perl_croak(aTHX_ "lobj is not of type version");
 504
 505           {
 506                SV       *rs;
 507                rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
 508                PUSHs(rs);
 509           }
 510
 511           PUTBACK;
 512           return;
 513      }
 514 }
 515
 516 XS(XS_version_noop)
 517 {
 518      dXSARGS;
 519      if (items < 1)
 520           Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 521      {
 522           SV *  lobj;
 523
 524           if (sv_derived_from(ST(0), "version")) {
 525                SV *tmp = SvRV(ST(0));
 526                lobj = tmp;
 527           }
 528           else
 529                Perl_croak(aTHX_ "lobj is not of type version");
 530
 531           {
 532                Perl_croak(aTHX_ "operation not supported with version object");
 533           }
 534
 535      }
 536      XSRETURN_EMPTY;
 537 }
 538
 539 XS(XS_version_is_alpha)
 540 {
 541     dXSARGS;
 542     if (items != 1)
 543         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 544     SP -= items;
 545     {
 546         SV *lobj;
 547
 548         if (sv_derived_from(ST(0), "version")) {
 549                 SV *tmp = SvRV(ST(0));
 550                 lobj = tmp;
 551         }
 552         else
 553                 Perl_croak(aTHX_ "lobj is not of type version");
 554 {
 555     I32 len = av_len((AV *)lobj);
 556     I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
 557     if ( digit < 0 )
 558         XSRETURN_YES;
 559     else
 560         XSRETURN_NO;
 561 }
 562         PUTBACK;
 563         return;
 564     }
 565 }
 566
 567 XS(XS_utf8_is_utf8)
 568 {
 569      dXSARGS;
 570      if (items != 1)
 571           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 572      {
 573           SV *  sv = ST(0);
 574           {
 575                if (SvUTF8(sv))
 576                     XSRETURN_YES;
 577                else
 578                     XSRETURN_NO;
 579           }
 580      }
 581      XSRETURN_EMPTY;
 582 }
 583
 584 XS(XS_utf8_valid)
 585 {
 586      dXSARGS;
 587      if (items != 1)
 588           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 589      {
 590           SV *  sv = ST(0);
 591           {
 592                STRLEN len;
 593                char *s = SvPV(sv,len);
 594                if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 595                     XSRETURN_YES;
 596                else
 597                     XSRETURN_NO;
 598           }
 599      }
 600      XSRETURN_EMPTY;
 601 }
 602
 603 XS(XS_utf8_encode)
 604 {
 605     dXSARGS;
 606     if (items != 1)
 607         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 608     {
 609         SV *    sv = ST(0);
 610
 611         sv_utf8_encode(sv);
 612     }
 613     XSRETURN_EMPTY;
 614 }
 615
 616 XS(XS_utf8_decode)
 617 {
 618     dXSARGS;
 619     if (items != 1)
 620         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 621     {
 622         SV *    sv = ST(0);
 623         bool    RETVAL;
 624
 625         RETVAL = sv_utf8_decode(sv);
 626         ST(0) = boolSV(RETVAL);
 627         sv_2mortal(ST(0));
 628     }
 629     XSRETURN(1);
 630 }
 631
 632 XS(XS_utf8_upgrade)
 633 {
 634     dXSARGS;
 635     if (items != 1)
 636         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 637     {
 638         SV *    sv = ST(0);
 639         STRLEN  RETVAL;
 640         dXSTARG;
 641
 642         RETVAL = sv_utf8_upgrade(sv);
 643         XSprePUSH; PUSHi((IV)RETVAL);
 644     }
 645     XSRETURN(1);
 646 }
 647
 648 XS(XS_utf8_downgrade)
 649 {
 650     dXSARGS;
 651     if (items < 1 || items > 2)
 652         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 653     {
 654         SV *    sv = ST(0);
 655         bool    failok;
 656         bool    RETVAL;
 657
 658         if (items < 2)
 659             failok = 0;
 660         else {
 661             failok = (int)SvIV(ST(1));
 662         }
 663
 664         RETVAL = sv_utf8_downgrade(sv, failok);
 665         ST(0) = boolSV(RETVAL);
 666         sv_2mortal(ST(0));
 667     }
 668     XSRETURN(1);
 669 }
 670
 671 XS(XS_utf8_native_to_unicode)
 672 {
 673  dXSARGS;
 674  UV uv = SvUV(ST(0));
 675
 676  if (items > 1)
 677      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 678
 679  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 680  XSRETURN(1);
 681 }
 682
 683 XS(XS_utf8_unicode_to_native)
 684 {
 685  dXSARGS;
 686  UV uv = SvUV(ST(0));
 687
 688  if (items > 1)
 689      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 690
 691  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 692  XSRETURN(1);
 693 }
 694
 695 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 696 {
 697     dXSARGS;
 698     SV *sv = SvRV(ST(0));
 699     if (items == 1) {
 700          if (SvREADONLY(sv))
 701              XSRETURN_YES;
 702          else
 703              XSRETURN_NO;
 704     }
 705     else if (items == 2) {
 706         if (SvTRUE(ST(1))) {
 707             SvREADONLY_on(sv);
 708             XSRETURN_YES;
 709         }
 710         else {
 711             /* I hope you really know what you are doing. */
 712             SvREADONLY_off(sv);
 713             XSRETURN_NO;
 714         }
 715     }
 716     XSRETURN_UNDEF; /* Can't happen. */
 717 }
 718
 719 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 720 {
 721     dXSARGS;
 722     SV *sv = SvRV(ST(0));
 723     if (items == 1)
 724          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 725     else if (items == 2) {
 726          /* I hope you really know what you are doing. */
 727          SvREFCNT(sv) = SvIV(ST(1));
 728          XSRETURN_IV(SvREFCNT(sv));
 729     }
 730     XSRETURN_UNDEF; /* Can't happen. */
 731 }
 732
 733 /* Maybe this should return the number of placeholders found in scalar context,
 734    and a list of them in list context.  */
 735 XS(XS_Internals_hv_clear_placehold)
 736 {
 737     dXSARGS;
 738     HV *hv = (HV *) SvRV(ST(0));
 739
 740     /* I don't care how many parameters were passed in, but I want to avoid
 741        the unused variable warning. */
 742
 743     items = (I32)HvPLACEHOLDERS(hv);
 744
 745     if (items) {
 746         HE *entry;
 747         I32 riter = HvRITER(hv);
 748         HE *eiter = HvEITER(hv);
 749         hv_iterinit(hv);
 750         /* This may look suboptimal with the items *after* the iternext, but
 751            it's quite deliberate. We only get here with items==0 if we've
 752            just deleted the last placeholder in the hash. If we've just done
 753            that then it means that the hash is in lazy delete mode, and the
 754            HE is now only referenced in our iterator. If we just quit the loop
 755            and discarded our iterator then the HE leaks. So we do the && the
 756            other way to ensure iternext is called just one more time, which
 757            has the side effect of triggering the lazy delete.  */
 758         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 759             && items) {
 760             SV *val = hv_iterval(hv, entry);
 761
 762             if (val == &PL_sv_placeholder) {
 763
 764                 /* It seems that I have to go back in the front of the hash
 765                    API to delete a hash, even though I have a HE structure
 766                    pointing to the very entry I want to delete, and could hold
 767                    onto the previous HE that points to it. And it's easier to
 768                    go in with SVs as I can then specify the precomputed hash,
 769                    and don't have fun and games with utf8 keys.  */
 770                 SV *key = hv_iterkeysv(entry);
 771
 772                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 773                 items--;
 774             }
 775         }
 776         HvRITER(hv) = riter;
 777         HvEITER(hv) = eiter;
 778     }
 779
 780     XSRETURN(0);
 781 }
 782
 783 XS(XS_Regexp_DESTROY)
 784 {
 785
 786 }
 787
 788 XS(XS_PerlIO_get_layers)
 789 {
 790     dXSARGS;
 791     if (items < 1 || items % 2 == 0)
 792         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 793 #ifdef USE_PERLIO
 794     {
 795         SV *    sv;
 796         GV *    gv;
 797         IO *    io;
 798         bool    input = TRUE;
 799         bool    details = FALSE;
 800
 801         if (items > 1) {
 802              SV **svp;
 803
 804              for (svp = MARK + 2; svp <= SP; svp += 2) {
 805                   SV **varp = svp;
 806                   SV **valp = svp + 1;
 807                   STRLEN klen;
 808                   char *key = SvPV(*varp, klen);
 809
 810                   switch (*key) {
 811                   case 'i':
 812                        if (klen == 5 && memEQ(key, "input", 5)) {
 813                             input = SvTRUE(*valp);
 814                             break;
 815                        }
 816                        goto fail;
 817                   case 'o':
 818                        if (klen == 6 && memEQ(key, "output", 6)) {
 819                             input = !SvTRUE(*valp);
 820                             break;
 821                        }
 822                        goto fail;
 823                   case 'd':
 824                        if (klen == 7 && memEQ(key, "details", 7)) {
 825                             details = SvTRUE(*valp);
 826                             break;
 827                        }
 828                        goto fail;
 829                   default:
 830                   fail:
 831                        Perl_croak(aTHX_
 832                                   "get_layers: unknown argument '%s'",
 833                                   key);
 834                   }
 835              }
 836
 837              SP -= (items - 1);
 838         }
 839
 840         sv = POPs;
 841         gv = (GV*)sv;
 842
 843         if (!isGV(sv)) {
 844              if (SvROK(sv) && isGV(SvRV(sv)))
 845                   gv = (GV*)SvRV(sv);
 846              else
 847                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
 848         }
 849
 850         if (gv && (io = GvIO(gv))) {
 851              dTARGET;
 852              AV* av = PerlIO_get_layers(aTHX_ input ?
 853                                         IoIFP(io) : IoOFP(io));
 854              I32 i;
 855              I32 last = av_len(av);
 856              I32 nitem = 0;
 857
 858              for (i = last; i >= 0; i -= 3) {
 859                   SV **namsvp;
 860                   SV **argsvp;
 861                   SV **flgsvp;
 862                   bool namok, argok, flgok;
 863
 864                   namsvp = av_fetch(av, i - 2, FALSE);
 865                   argsvp = av_fetch(av, i - 1, FALSE);
 866                   flgsvp = av_fetch(av, i,     FALSE);
 867
 868                   namok = namsvp && *namsvp && SvPOK(*namsvp);
 869                   argok = argsvp && *argsvp && SvPOK(*argsvp);
 870                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 871
 872                   if (details) {
 873                        XPUSHs(namok ?
 874                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
 875                        XPUSHs(argok ?
 876                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
 877                        if (flgok)
 878                             XPUSHi(SvIVX(*flgsvp));
 879                        else
 880                             XPUSHs(&PL_sv_undef);
 881                        nitem += 3;
 882                   }
 883                   else {
 884                        if (namok && argok)
 885                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 886                                                *namsvp, *argsvp));
 887                        else if (namok)
 888                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 889                        else
 890                             XPUSHs(&PL_sv_undef);
 891                        nitem++;
 892                        if (flgok) {
 893                             IV flags = SvIVX(*flgsvp);
 894
 895                             if (flags & PERLIO_F_UTF8) {
 896                                  XPUSHs(newSVpvn("utf8", 4));
 897                                  nitem++;
 898                             }
 899                        }
 900                   }
 901              }
 902
 903              SvREFCNT_dec(av);
 904
 905              XSRETURN(nitem);
 906         }
 907     }
 908 #endif
 909
 910     XSRETURN(0);
 911 }
 912
 913 XS(XS_Internals_hash_seed)
 914 {
 915     /* Using dXSARGS would also have dITEM and dSP,
 916      * which define 2 unused local variables.  */
 917     dMARK; dAX;
 918     XSRETURN_UV(PERL_HASH_SEED);
 919 }
 920
 921 XS(XS_Internals_HvREHASH)       /* Subject to change  */
 922 {
 923     dXSARGS;
 924     if (SvROK(ST(0))) {
 925         HV *hv = (HV *) SvRV(ST(0));
 926         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
 927             if (HvREHASH(hv))
 928                 XSRETURN_YES;
 929             else
 930                 XSRETURN_NO;
 931         }
 932     }
 933     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
 934 }