universal.c

   1 /*    universal.c
   2  *
   3  *    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4  *    2005, 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 /* This file contains the code that implements the functions in Perl's
  18  * UNIVERSAL package, such as UNIVERSAL->can().
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_UNIVERSAL_C
  23 #include "perl.h"
  24
  25 #ifdef USE_PERLIO
  26 #include "perliol.h" /* For the PERLIO_F_XXX */
  27 #endif
  28
  29 /*
  30  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  31  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  32  */
  33
  34 STATIC SV *
  35 S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
  36              int len, int level)
  37 {
  38     AV* av;
  39     GV* gv;
  40     GV** gvp;
  41     HV* hv = Nullhv;
  42     SV* subgen = Nullsv;
  43     const char *hvname;
  44
  45     /* A stash/class can go by many names (ie. User == main::User), so
  46        we compare the stash itself just in case */
  47     if (name_stash && (stash == name_stash))
  48         return &PL_sv_yes;
  49
  50     hvname = HvNAME_get(stash);
  51
  52     if (strEQ(hvname, name))
  53         return &PL_sv_yes;
  54
  55     if (strEQ(name, "UNIVERSAL"))
  56         return &PL_sv_yes;
  57
  58     if (level > 100)
  59         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  60                    hvname);
  61
  62     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  63
  64     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  65         && (hv = GvHV(gv)))
  66     {
  67         if (SvIV(subgen) == (IV)PL_sub_generation) {
  68             SV* sv;
  69             SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
  70             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
  71                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  72                                   name, hvname) );
  73                 return sv;
  74             }
  75         }
  76         else {
  77             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  78                               hvname) );
  79             hv_clear(hv);
  80             sv_setiv(subgen, PL_sub_generation);
  81         }
  82     }
  83
  84     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  85
  86     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  87         if (!hv || !subgen) {
  88             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  89
  90             gv = *gvp;
  91
  92             if (SvTYPE(gv) != SVt_PVGV)
  93                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  94
  95             if (!hv)
  96                 hv = GvHVn(gv);
  97             if (!subgen) {
  98                 subgen = newSViv(PL_sub_generation);
  99                 GvSV(gv) = subgen;
 100             }
 101         }
 102         if (hv) {
 103             SV** svp = AvARRAY(av);
 104             /* NOTE: No support for tied ISA */
 105             I32 items = AvFILLp(av) + 1;
 106             while (items--) {
 107                 SV* const sv = *svp++;
 108                 HV* const basestash = gv_stashsv(sv, FALSE);
 109                 if (!basestash) {
 110                     if (ckWARN(WARN_MISC))
 111                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 112                                     "Can't locate package %"SVf" for @%s::ISA",
 113                                     sv, hvname);
 114                     continue;
 115                 }
 116                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
 117                                              len, level + 1)) {
 118                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 119                     return &PL_sv_yes;
 120                 }
 121             }
 122             (void)hv_store(hv,name,len,&PL_sv_no,0);
 123         }
 124     }
 125     return &PL_sv_no;
 126 }
 127
 128 /*
 129 =head1 SV Manipulation Functions
 130
 131 =for apidoc sv_derived_from
 132
 133 Returns a boolean indicating whether the SV is derived from the specified
 134 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
 135 for class names as well as for objects.
 136
 137 =cut
 138 */
 139
 140 bool
 141 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 142 {
 143     const char *type = Nullch;
 144     HV *stash = Nullhv;
 145     HV *name_stash;
 146
 147     SvGETMAGIC(sv);
 148
 149     if (SvROK(sv)) {
 150         sv = SvRV(sv);
 151         type = sv_reftype(sv,0);
 152         if (SvOBJECT(sv))
 153             stash = SvSTASH(sv);
 154     }
 155     else {
 156         stash = gv_stashsv(sv, FALSE);
 157     }
 158
 159     name_stash = gv_stashpv(name, FALSE);
 160
 161     return (type && strEQ(type,name)) ||
 162             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
 163              == &PL_sv_yes)
 164         ? TRUE
 165         : FALSE ;
 166 }
 167
 168 #include "XSUB.h"
 169
 170 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 171 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
 172 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 173 XS(XS_version_new);
 174 XS(XS_version_stringify);
 175 XS(XS_version_numify);
 176 XS(XS_version_normal);
 177 XS(XS_version_vcmp);
 178 XS(XS_version_boolean);
 179 #ifdef HASATTRIBUTE_NORETURN
 180 XS(XS_version_noop) __attribute__noreturn__;
 181 #else
 182 XS(XS_version_noop);
 183 #endif
 184 XS(XS_version_is_alpha);
 185 XS(XS_version_qv);
 186 XS(XS_utf8_is_utf8);
 187 XS(XS_utf8_valid);
 188 XS(XS_utf8_encode);
 189 XS(XS_utf8_decode);
 190 XS(XS_utf8_upgrade);
 191 XS(XS_utf8_downgrade);
 192 XS(XS_utf8_unicode_to_native);
 193 XS(XS_utf8_native_to_unicode);
 194 XS(XS_Internals_SvREADONLY);
 195 XS(XS_Internals_SvREFCNT);
 196 XS(XS_Internals_hv_clear_placehold);
 197 XS(XS_PerlIO_get_layers);
 198 XS(XS_Regexp_DESTROY);
 199 XS(XS_Internals_hash_seed);
 200 XS(XS_Internals_rehash_seed);
 201 XS(XS_Internals_HvREHASH);
 202 XS(XS_utf8_SWASHGET_heavy);
 203
 204 void
 205 Perl_boot_core_UNIVERSAL(pTHX)
 206 {
 207     const char file[] = __FILE__;
 208
 209     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 210     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 211     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 212     {
 213         /* register the overloading (type 'A') magic */
 214         PL_amagic_generation++;
 215         /* Make it findable via fetchmethod */
 216         newXS("version::()", XS_version_noop, file);
 217         newXS("version::new", XS_version_new, file);
 218         newXS("version::(\"\"", XS_version_stringify, file);
 219         newXS("version::stringify", XS_version_stringify, file);
 220         newXS("version::(0+", XS_version_numify, file);
 221         newXS("version::numify", XS_version_numify, file);
 222         newXS("version::normal", XS_version_normal, file);
 223         newXS("version::(cmp", XS_version_vcmp, file);
 224         newXS("version::(<=>", XS_version_vcmp, file);
 225         newXS("version::vcmp", XS_version_vcmp, file);
 226         newXS("version::(bool", XS_version_boolean, file);
 227         newXS("version::boolean", XS_version_boolean, file);
 228         newXS("version::(nomethod", XS_version_noop, file);
 229         newXS("version::noop", XS_version_noop, file);
 230         newXS("version::is_alpha", XS_version_is_alpha, file);
 231         newXS("version::qv", XS_version_qv, file);
 232     }
 233     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
 234     newXS("utf8::valid", XS_utf8_valid, file);
 235     newXS("utf8::encode", XS_utf8_encode, file);
 236     newXS("utf8::decode", XS_utf8_decode, file);
 237     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 238     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 239     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 240     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 241     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 242     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 243     newXSproto("Internals::hv_clear_placeholders",
 244                XS_Internals_hv_clear_placehold, file, "\\%");
 245     newXSproto("PerlIO::get_layers",
 246                XS_PerlIO_get_layers, file, "*;@");
 247     newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
 248     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
 249     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
 250     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
 251     newXS("utf8::SWASHGET_heavy", XS_utf8_SWASHGET_heavy, file);
 252 }
 253
 254
 255 XS(XS_UNIVERSAL_isa)
 256 {
 257     dXSARGS;
 258
 259     if (items != 2)
 260         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 261     else {
 262         SV * const sv = ST(0);
 263         const char *name;
 264
 265         SvGETMAGIC(sv);
 266
 267         if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 268                     || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 269             XSRETURN_UNDEF;
 270
 271         name = SvPV_nolen_const(ST(1));
 272
 273         ST(0) = boolSV(sv_derived_from(sv, name));
 274         XSRETURN(1);
 275     }
 276 }
 277
 278 XS(XS_UNIVERSAL_can)
 279 {
 280     dXSARGS;
 281     SV   *sv;
 282     const char *name;
 283     SV   *rv;
 284     HV   *pkg = NULL;
 285
 286     if (items != 2)
 287         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 288
 289     sv = ST(0);
 290
 291     SvGETMAGIC(sv);
 292
 293     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 294                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 295         XSRETURN_UNDEF;
 296
 297     name = SvPV_nolen_const(ST(1));
 298     rv = &PL_sv_undef;
 299
 300     if (SvROK(sv)) {
 301         sv = (SV*)SvRV(sv);
 302         if (SvOBJECT(sv))
 303             pkg = SvSTASH(sv);
 304     }
 305     else {
 306         pkg = gv_stashsv(sv, FALSE);
 307     }
 308
 309     if (pkg) {
 310         GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 311         if (gv && isGV(gv))
 312             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 313     }
 314
 315     ST(0) = rv;
 316     XSRETURN(1);
 317 }
 318
 319 XS(XS_UNIVERSAL_VERSION)
 320 {
 321     dXSARGS;
 322     HV *pkg;
 323     GV **gvp;
 324     GV *gv;
 325     SV *sv;
 326     const char *undef;
 327
 328     if (SvROK(ST(0))) {
 329         sv = (SV*)SvRV(ST(0));
 330         if (!SvOBJECT(sv))
 331             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 332         pkg = SvSTASH(sv);
 333     }
 334     else {
 335         pkg = gv_stashsv(ST(0), FALSE);
 336     }
 337
 338     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 339
 340     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
 341         SV * const nsv = sv_newmortal();
 342         sv_setsv(nsv, sv);
 343         sv = nsv;
 344         if ( !sv_derived_from(sv, "version"))
 345             upg_version(sv);
 346         undef = Nullch;
 347     }
 348     else {
 349         sv = (SV*)&PL_sv_undef;
 350         undef = "(undef)";
 351     }
 352
 353     if (items > 1) {
 354         SV *req = ST(1);
 355
 356         if (undef) {
 357             if (pkg) {
 358                 const char * const name = HvNAME_get(pkg);
 359                 Perl_croak(aTHX_
 360                            "%s does not define $%s::VERSION--version check failed",
 361                            name, name);
 362             } else {
 363                 Perl_croak(aTHX_
 364                              "%s defines neither package nor VERSION--version check failed",
 365                              SvPVx_nolen_const(ST(0)) );
 366              }
 367         }
 368
 369         if ( !sv_derived_from(req, "version")) {
 370             /* req may very well be R/O, so create a new object */
 371             SV * const nsv = sv_newmortal();
 372             sv_setsv(nsv, req);
 373             req = nsv;
 374             upg_version(req);
 375         }
 376
 377         if ( vcmp( req, sv ) > 0 )
 378             Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
 379                     "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
 380                     vnumify(req),vnormal(req),vnumify(sv),vnormal(sv));
 381     }
 382
 383     if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
 384         ST(0) = vnumify(sv);
 385     } else {
 386         ST(0) = sv;
 387     }
 388
 389     XSRETURN(1);
 390 }
 391
 392 XS(XS_version_new)
 393 {
 394     dXSARGS;
 395     if (items > 3)
 396         Perl_croak(aTHX_ "Usage: version::new(class, version)");
 397     SP -= items;
 398     {
 399         SV *vs = ST(1);
 400         SV *rv;
 401         const char * const classname =
 402             sv_isobject(ST(0)) /* get the class if called as an object method */
 403                 ? HvNAME(SvSTASH(SvRV(ST(0))))
 404                 : (char *)SvPV_nolen(ST(0));
 405
 406         if ( items == 1 ) {
 407             /* no parameter provided */
 408             if ( sv_isobject(ST(0)) ) {
 409                 /* copy existing object */
 410                 vs = ST(0);
 411             }
 412             else {
 413                 /* create empty object */
 414                 vs = sv_newmortal();
 415                 sv_setpvn(vs,"",0);
 416             }
 417         }
 418         else if ( items == 3 ) {
 419             vs = sv_newmortal();
 420             Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
 421         }
 422
 423         rv = new_version(vs);
 424         if ( strcmp(classname,"version") != 0 ) /* inherited new() */
 425             sv_bless(rv, gv_stashpv(classname,TRUE));
 426
 427         PUSHs(sv_2mortal(rv));
 428         PUTBACK;
 429         return;
 430     }
 431 }
 432
 433 XS(XS_version_stringify)
 434 {
 435      dXSARGS;
 436      if (items < 1)
 437           Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
 438      SP -= items;
 439      {
 440           SV *  lobj;
 441
 442           if (sv_derived_from(ST(0), "version")) {
 443                lobj = SvRV(ST(0));
 444           }
 445           else
 446                Perl_croak(aTHX_ "lobj is not of type version");
 447
 448           PUSHs(sv_2mortal(vstringify(lobj)));
 449
 450           PUTBACK;
 451           return;
 452      }
 453 }
 454
 455 XS(XS_version_numify)
 456 {
 457      dXSARGS;
 458      if (items < 1)
 459           Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
 460      SP -= items;
 461      {
 462           SV *  lobj;
 463
 464           if (sv_derived_from(ST(0), "version")) {
 465                lobj = SvRV(ST(0));
 466           }
 467           else
 468                Perl_croak(aTHX_ "lobj is not of type version");
 469
 470           PUSHs(sv_2mortal(vnumify(lobj)));
 471
 472           PUTBACK;
 473           return;
 474      }
 475 }
 476
 477 XS(XS_version_normal)
 478 {
 479      dXSARGS;
 480      if (items < 1)
 481           Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
 482      SP -= items;
 483      {
 484           SV *  lobj;
 485
 486           if (sv_derived_from(ST(0), "version")) {
 487                lobj = SvRV(ST(0));
 488           }
 489           else
 490                Perl_croak(aTHX_ "lobj is not of type version");
 491
 492           PUSHs(sv_2mortal(vnormal(lobj)));
 493
 494           PUTBACK;
 495           return;
 496      }
 497 }
 498
 499 XS(XS_version_vcmp)
 500 {
 501      dXSARGS;
 502      if (items < 1)
 503           Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
 504      SP -= items;
 505      {
 506           SV *  lobj;
 507
 508           if (sv_derived_from(ST(0), "version")) {
 509                lobj = SvRV(ST(0));
 510           }
 511           else
 512                Perl_croak(aTHX_ "lobj is not of type version");
 513
 514           {
 515                SV       *rs;
 516                SV       *rvs;
 517                SV * robj = ST(1);
 518                const IV  swap = (IV)SvIV(ST(2));
 519
 520                if ( ! sv_derived_from(robj, "version") )
 521                {
 522                     robj = new_version(robj);
 523                }
 524                rvs = SvRV(robj);
 525
 526                if ( swap )
 527                {
 528                     rs = newSViv(vcmp(rvs,lobj));
 529                }
 530                else
 531                {
 532                     rs = newSViv(vcmp(lobj,rvs));
 533                }
 534
 535                PUSHs(sv_2mortal(rs));
 536           }
 537
 538           PUTBACK;
 539           return;
 540      }
 541 }
 542
 543 XS(XS_version_boolean)
 544 {
 545      dXSARGS;
 546      if (items < 1)
 547           Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
 548      SP -= items;
 549     if (sv_derived_from(ST(0), "version")) {
 550         SV * const lobj = SvRV(ST(0));
 551         SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
 552         PUSHs(sv_2mortal(rs));
 553         PUTBACK;
 554         return;
 555     }
 556     else
 557         Perl_croak(aTHX_ "lobj is not of type version");
 558 }
 559
 560 XS(XS_version_noop)
 561 {
 562     dXSARGS;
 563     if (items < 1)
 564         Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
 565     if (sv_derived_from(ST(0), "version"))
 566         Perl_croak(aTHX_ "operation not supported with version object");
 567     else
 568         Perl_croak(aTHX_ "lobj is not of type version");
 569 #ifndef HASATTRIBUTE_NORETURN
 570     XSRETURN_EMPTY;
 571 #endif
 572 }
 573
 574 XS(XS_version_is_alpha)
 575 {
 576     dXSARGS;
 577     if (items != 1)
 578         Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
 579     SP -= items;
 580     if (sv_derived_from(ST(0), "version")) {
 581         SV * const lobj = ST(0);
 582         if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
 583             XSRETURN_YES;
 584         else
 585             XSRETURN_NO;
 586         PUTBACK;
 587         return;
 588     }
 589     else
 590         Perl_croak(aTHX_ "lobj is not of type version");
 591 }
 592
 593 XS(XS_version_qv)
 594 {
 595     dXSARGS;
 596     if (items != 1)
 597         Perl_croak(aTHX_ "Usage: version::qv(ver)");
 598     SP -= items;
 599     {
 600         SV *    ver = ST(0);
 601         if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
 602             SV * const vs = sv_newmortal();
 603             char *version;
 604             if ( SvNOK(ver) ) /* may get too much accuracy */
 605             {
 606                 char tbuf[64];
 607                 const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
 608                 version = savepvn(tbuf, len);
 609             }
 610             else
 611             {
 612                 version = savesvpv(ver);
 613             }
 614             (void)scan_version(version,vs,TRUE);
 615             Safefree(version);
 616
 617             PUSHs(vs);
 618         }
 619         else
 620         {
 621             PUSHs(sv_2mortal(new_version(ver)));
 622         }
 623
 624         PUTBACK;
 625         return;
 626     }
 627 }
 628
 629 XS(XS_utf8_is_utf8)
 630 {
 631      dXSARGS;
 632      if (items != 1)
 633           Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
 634      else {
 635         const SV * const sv = ST(0);
 636             if (SvUTF8(sv))
 637                 XSRETURN_YES;
 638             else
 639                 XSRETURN_NO;
 640      }
 641      XSRETURN_EMPTY;
 642 }
 643
 644 XS(XS_utf8_valid)
 645 {
 646      dXSARGS;
 647      if (items != 1)
 648           Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 649     else {
 650         SV * const sv = ST(0);
 651         STRLEN len;
 652         const char * const s = SvPV_const(sv,len);
 653         if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
 654             XSRETURN_YES;
 655         else
 656             XSRETURN_NO;
 657     }
 658      XSRETURN_EMPTY;
 659 }
 660
 661 XS(XS_utf8_encode)
 662 {
 663     dXSARGS;
 664     if (items != 1)
 665         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 666     sv_utf8_encode(ST(0));
 667     XSRETURN_EMPTY;
 668 }
 669
 670 XS(XS_utf8_decode)
 671 {
 672     dXSARGS;
 673     if (items != 1)
 674         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 675     else {
 676         SV * const sv = ST(0);
 677         const bool RETVAL = sv_utf8_decode(sv);
 678         ST(0) = boolSV(RETVAL);
 679         sv_2mortal(ST(0));
 680     }
 681     XSRETURN(1);
 682 }
 683
 684 XS(XS_utf8_upgrade)
 685 {
 686     dXSARGS;
 687     if (items != 1)
 688         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 689     else {
 690         SV * const sv = ST(0);
 691         STRLEN  RETVAL;
 692         dXSTARG;
 693
 694         RETVAL = sv_utf8_upgrade(sv);
 695         XSprePUSH; PUSHi((IV)RETVAL);
 696     }
 697     XSRETURN(1);
 698 }
 699
 700 XS(XS_utf8_downgrade)
 701 {
 702     dXSARGS;
 703     if (items < 1 || items > 2)
 704         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 705     else {
 706         SV * const sv = ST(0);
 707         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
 708         const bool RETVAL = sv_utf8_downgrade(sv, failok);
 709
 710         ST(0) = boolSV(RETVAL);
 711         sv_2mortal(ST(0));
 712     }
 713     XSRETURN(1);
 714 }
 715
 716 XS(XS_utf8_native_to_unicode)
 717 {
 718  dXSARGS;
 719  const UV uv = SvUV(ST(0));
 720
 721  if (items > 1)
 722      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 723
 724  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 725  XSRETURN(1);
 726 }
 727
 728 XS(XS_utf8_unicode_to_native)
 729 {
 730  dXSARGS;
 731  const UV uv = SvUV(ST(0));
 732
 733  if (items > 1)
 734      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 735
 736  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 737  XSRETURN(1);
 738 }
 739
 740 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 741 {
 742     dXSARGS;
 743     SV * const sv = SvRV(ST(0));
 744
 745     if (items == 1) {
 746          if (SvREADONLY(sv))
 747              XSRETURN_YES;
 748          else
 749              XSRETURN_NO;
 750     }
 751     else if (items == 2) {
 752         if (SvTRUE(ST(1))) {
 753             SvREADONLY_on(sv);
 754             XSRETURN_YES;
 755         }
 756         else {
 757             /* I hope you really know what you are doing. */
 758             SvREADONLY_off(sv);
 759             XSRETURN_NO;
 760         }
 761     }
 762     XSRETURN_UNDEF; /* Can't happen. */
 763 }
 764
 765 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 766 {
 767     dXSARGS;
 768     SV * const sv = SvRV(ST(0));
 769
 770     if (items == 1)
 771          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 772     else if (items == 2) {
 773          /* I hope you really know what you are doing. */
 774          SvREFCNT(sv) = SvIV(ST(1));
 775          XSRETURN_IV(SvREFCNT(sv));
 776     }
 777     XSRETURN_UNDEF; /* Can't happen. */
 778 }
 779
 780 XS(XS_Internals_hv_clear_placehold)
 781 {
 782     dXSARGS;
 783
 784     if (items != 1)
 785         Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
 786     else {
 787         HV * const hv = (HV *) SvRV(ST(0));
 788         hv_clear_placeholders(hv);
 789         XSRETURN(0);
 790     }
 791 }
 792
 793 XS(XS_Regexp_DESTROY)
 794 {
 795     PERL_UNUSED_ARG(cv);
 796 }
 797
 798 XS(XS_PerlIO_get_layers)
 799 {
 800     dXSARGS;
 801     if (items < 1 || items % 2 == 0)
 802         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 803 #ifdef USE_PERLIO
 804     {
 805         SV *    sv;
 806         GV *    gv;
 807         IO *    io;
 808         bool    input = TRUE;
 809         bool    details = FALSE;
 810
 811         if (items > 1) {
 812              SV * const *svp;
 813              for (svp = MARK + 2; svp <= SP; svp += 2) {
 814                   SV * const * const varp = svp;
 815                   SV * const * const valp = svp + 1;
 816                   STRLEN klen;
 817                   const char * const key = SvPV_const(*varp, klen);
 818
 819                   switch (*key) {
 820                   case 'i':
 821                        if (klen == 5 && memEQ(key, "input", 5)) {
 822                             input = SvTRUE(*valp);
 823                             break;
 824                        }
 825                        goto fail;
 826                   case 'o':
 827                        if (klen == 6 && memEQ(key, "output", 6)) {
 828                             input = !SvTRUE(*valp);
 829                             break;
 830                        }
 831                        goto fail;
 832                   case 'd':
 833                        if (klen == 7 && memEQ(key, "details", 7)) {
 834                             details = SvTRUE(*valp);
 835                             break;
 836                        }
 837                        goto fail;
 838                   default:
 839                   fail:
 840                        Perl_croak(aTHX_
 841                                   "get_layers: unknown argument '%s'",
 842                                   key);
 843                   }
 844              }
 845
 846              SP -= (items - 1);
 847         }
 848
 849         sv = POPs;
 850         gv = (GV*)sv;
 851
 852         if (!isGV(sv)) {
 853              if (SvROK(sv) && isGV(SvRV(sv)))
 854                   gv = (GV*)SvRV(sv);
 855              else if (SvPOKp(sv))
 856                   gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
 857         }
 858
 859         if (gv && (io = GvIO(gv))) {
 860              dTARGET;
 861              AV* const av = PerlIO_get_layers(aTHX_ input ?
 862                                         IoIFP(io) : IoOFP(io));
 863              I32 i;
 864              const I32 last = av_len(av);
 865              I32 nitem = 0;
 866
 867              for (i = last; i >= 0; i -= 3) {
 868                   SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
 869                   SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
 870                   SV * const * const flgsvp = av_fetch(av, i,     FALSE);
 871
 872                   const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
 873                   const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
 874                   const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 875
 876                   if (details) {
 877                        XPUSHs(namok
 878                               ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
 879                               : &PL_sv_undef);
 880                        XPUSHs(argok
 881                               ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
 882                               : &PL_sv_undef);
 883                        if (flgok)
 884                             XPUSHi(SvIVX(*flgsvp));
 885                        else
 886                             XPUSHs(&PL_sv_undef);
 887                        nitem += 3;
 888                   }
 889                   else {
 890                        if (namok && argok)
 891                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 892                                                *namsvp, *argsvp));
 893                        else if (namok)
 894                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 895                        else
 896                             XPUSHs(&PL_sv_undef);
 897                        nitem++;
 898                        if (flgok) {
 899                             const IV flags = SvIVX(*flgsvp);
 900
 901                             if (flags & PERLIO_F_UTF8) {
 902                                  XPUSHs(newSVpvn("utf8", 4));
 903                                  nitem++;
 904                             }
 905                        }
 906                   }
 907              }
 908
 909              SvREFCNT_dec(av);
 910
 911              XSRETURN(nitem);
 912         }
 913     }
 914 #endif
 915
 916     XSRETURN(0);
 917 }
 918
 919 XS(XS_Internals_hash_seed)
 920 {
 921     /* Using dXSARGS would also have dITEM and dSP,
 922      * which define 2 unused local variables.  */
 923     dAXMARK;
 924     PERL_UNUSED_ARG(cv);
 925     PERL_UNUSED_VAR(mark);
 926     XSRETURN_UV(PERL_HASH_SEED);
 927 }
 928
 929 XS(XS_Internals_rehash_seed)
 930 {
 931     /* Using dXSARGS would also have dITEM and dSP,
 932      * which define 2 unused local variables.  */
 933     dAXMARK;
 934     PERL_UNUSED_ARG(cv);
 935     PERL_UNUSED_VAR(mark);
 936     XSRETURN_UV(PL_rehash_seed);
 937 }
 938
 939 XS(XS_Internals_HvREHASH)       /* Subject to change  */
 940 {
 941     dXSARGS;
 942     if (SvROK(ST(0))) {
 943         const HV * const hv = (HV *) SvRV(ST(0));
 944         if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
 945             if (HvREHASH(hv))
 946                 XSRETURN_YES;
 947             else
 948                 XSRETURN_NO;
 949         }
 950     }
 951     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
 952 }
 953
 954 XS(XS_utf8_SWASHGET_heavy)
 955 {
 956     dXSARGS;
 957     if (items != 4) {
 958         Perl_croak(aTHX_
 959             "Usage: utf8::SWASHGET_heavy($self, $start, $len, DEBUG)");
 960     }
 961     {
 962         SV* self    = ST(0);
 963         const I32 i_start = (I32)SvIV(ST(1));
 964         const I32 i_len   = (I32)SvIV(ST(2));
 965         const I32 debug   = (I32)SvIV(ST(3));
 966         U32 start = (U32)i_start;
 967         U32 len   = (U32)i_len;
 968
 969         HV *hv;
 970         SV **listsvp, **typesvp, **bitssvp, **nonesvp, **extssvp, *swatch;
 971         U8 *l, *lend, *x, *xend, *s, *nextline;
 972         STRLEN lcur, xcur, scur;
 973         U8* typestr;
 974         int typeto;
 975         U32 bits, none, end, octets;
 976
 977         if (SvROK(self) && SvTYPE(SvRV(self))==SVt_PVHV)
 978             hv = (HV*)SvRV(self);
 979         else
 980             Perl_croak(aTHX_ "hv is not a hash reference");
 981
 982         if (i_start < 0)
 983             Perl_croak(aTHX_ "SWASHGET negative start");
 984         if (i_len < 0)
 985             Perl_croak(aTHX_ "SWASHGET negative len");
 986
 987         listsvp = hv_fetch(hv, "LIST", 4, FALSE);
 988         typesvp = hv_fetch(hv, "TYPE", 4, FALSE);
 989         bitssvp = hv_fetch(hv, "BITS", 4, FALSE);
 990         nonesvp = hv_fetch(hv, "NONE", 4, FALSE);
 991         extssvp = hv_fetch(hv, "EXTRAS", 6, FALSE);
 992         typestr = (U8*)SvPV_nolen(*typesvp);
 993         typeto  = typestr[0] == 'T' && typestr[1] == 'o';
 994         bits    = (U32)SvUV(*bitssvp);
 995         none    = (U32)SvUV(*nonesvp);
 996         end     = start + len;
 997         octets  = bits >> 3; /* if bits == 1, then octets == 0 */
 998
 999         if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1000             Perl_croak(aTHX_ "SWASHGET unknown bits %"UVuf, (UV)bits);
1001         }
1002         if (debug) {
1003             char* selfstr = SvPV_nolen(self);
1004             PerlIO_printf(Perl_error_log, "SWASHGET ");
1005             PerlIO_printf(Perl_error_log, "%s %"UVuf" %"UVuf" ",
1006                                           selfstr, (UV)start, (UV)len);
1007             PerlIO_printf(Perl_error_log, "[%s/%"UVuf"/%"UVuf"]\n",
1008                                           typestr, (UV)bits, (UV)none);
1009         }
1010
1011         /* initialize $swatch */
1012         swatch = newSVpvn("",0);
1013         scur   = octets ? (len * octets) : (len + 7) / 8;
1014         SvGROW(swatch, scur + 1);
1015         s = (U8*)SvPVX(swatch);
1016         if (octets && none) {
1017             const U8* e = s + scur;
1018             while (s < e) {
1019                 if (bits == 8)
1020                     *s++ = (U8)(none & 0xff);
1021                 else if (bits == 16) {
1022                     *s++ = (U8)((none >>  8) & 0xff);
1023                     *s++ = (U8)( none        & 0xff);
1024                 }
1025                 else if (bits == 32) {
1026                     *s++ = (U8)((none >> 24) & 0xff);
1027                     *s++ = (U8)((none >> 16) & 0xff);
1028                     *s++ = (U8)((none >>  8) & 0xff);
1029                     *s++ = (U8)( none        & 0xff);
1030                 }
1031             }
1032             *s = '\0';
1033         }
1034         else {
1035             (void)memzero((U8*)s, scur + 1);
1036         }
1037         SvCUR_set(swatch, scur);
1038         s = (U8*)SvPVX(swatch);
1039
1040         /* read $self->{LIST} */
1041         l = (U8*)SvPV(*listsvp, lcur);
1042         lend = l + lcur;
1043         while (l < lend) {
1044             U32 min, max, val, key;
1045             STRLEN numlen;
1046             I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1047
1048             nextline = (U8*)memchr(l, '\n', lend - l);
1049
1050             numlen = lend - l;
1051             min = (U32)grok_hex((char *)l, &numlen, &flags, NULL);
1052             if (numlen)
1053                 l += numlen;
1054             else if (nextline) {
1055                 l = nextline + 1; /* 1 is length of "\n" */
1056                 continue;
1057             }
1058             else {
1059                 l = lend; /* to the end of LIST, at which no \n */
1060                 break;
1061             }
1062
1063             if (isBLANK(*l)) {
1064                 ++l;
1065                 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1066                 numlen = lend - l;
1067                 max = (U32)grok_hex((char *)l, &numlen, &flags, NULL);
1068                 if (numlen)
1069                     l += numlen;
1070                 else
1071                     max = min;
1072
1073                 if (octets) {
1074                     if (isBLANK(*l)) {
1075                         ++l;
1076                         flags = PERL_SCAN_SILENT_ILLDIGIT |
1077                                 PERL_SCAN_DISALLOW_PREFIX;
1078                         numlen = lend - l;
1079                         val = (U32)grok_hex((char *)l, &numlen, &flags, NULL);
1080                         if (numlen)
1081                             l += numlen;
1082                         else
1083                             val = 0;
1084                     }
1085                     else {
1086                         val = 0;
1087                         if (typeto) {
1088                             Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1089                                              typestr, l);
1090                         }
1091                     }
1092                 }
1093             }
1094             else {
1095                 max = min;
1096                 if (octets) {
1097                     val = 0;
1098                     if (typeto) {
1099                         Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1100                                          typestr, l);
1101                     }
1102                 }
1103             }
1104
1105             if (nextline)
1106                 l = nextline + 1;
1107             else
1108                 l = lend;
1109
1110             if (max < start)
1111                 continue;
1112
1113             if (octets) {
1114                 if (debug) {
1115                     PerlIO_printf(Perl_error_log,
1116                         "%"UVuf" %"UVuf" %"UVuf"\n",
1117                         (UV)min, (UV)max, (UV)val);
1118                 }
1119                 if (min < start) {
1120                     if (!none || val < none) {
1121                         val += start - min;
1122                     }
1123                     min = start;
1124                 }
1125                 for (key = min; key <= max; key++) {
1126                     U32 offset;
1127                     if (key >= end)
1128                         goto go_out_list;
1129                     if (debug) {
1130                         PerlIO_printf(Perl_error_log,
1131                                 "%"UVuf" => %"UVuf"\n",
1132                                 (UV)key, (UV)val);
1133                     }
1134
1135                 /* offset must be non-negative (start <= min <= key < end) */
1136                     offset = (key - start) * octets;
1137                     if (bits == 8)
1138                         s[offset] = (U8)(val & 0xff);
1139                     else if (bits == 16) {
1140                         s[offset    ] = (U8)((val >>  8) & 0xff);
1141                         s[offset + 1] = (U8)( val        & 0xff);
1142                     }
1143                     else if (bits == 32) {
1144                         s[offset    ] = (U8)((val >> 24) & 0xff);
1145                         s[offset + 1] = (U8)((val >> 16) & 0xff);
1146                         s[offset + 2] = (U8)((val >>  8) & 0xff);
1147                         s[offset + 3] = (U8)( val        & 0xff);
1148                     }
1149
1150                     if (!none || val < none)
1151                         ++val;
1152                 }
1153             }
1154             else {
1155                 if (min < start)
1156                     min = start;
1157                 for (key = min; key <= max; key++) {
1158                     U32 offset = key - start;
1159                     if (key >= end)
1160                         goto go_out_list;
1161                     if (debug) {
1162                         PerlIO_printf(Perl_error_log,
1163                                 "%"UVuf" => 1\n", (UV)key);
1164                     }
1165                     s[offset >> 3] |= 1 << (offset & 7);
1166                 }
1167             }
1168         }
1169     go_out_list:
1170
1171         /* read $self->{EXTRAS} */
1172         x = (U8*)SvPV(*extssvp, xcur);
1173         xend = x + xcur;
1174         while (x < xend) {
1175             STRLEN namelen;
1176             U8 *namestr;
1177             SV** othersvp;
1178             U32 otherbits;
1179
1180             U8 opc = *x++;
1181             if (opc == '\n')
1182                 continue;
1183
1184             nextline = (U8*)memchr(x, '\n', xend - x);
1185
1186             if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
1187                 if (nextline) {
1188                     x = nextline + 1;
1189                     continue;
1190                 }
1191                 else {
1192                     x = xend;
1193                     break;
1194                 }
1195             }
1196
1197             namestr = x;
1198
1199             if (nextline) {
1200                 namelen = nextline - namestr;
1201                 x = nextline + 1;
1202             }
1203             else {
1204                 namelen = xend - namestr;
1205                 x = xend;
1206             }
1207
1208             if (debug) {
1209                 U8* tmpstr;
1210                 Newx(tmpstr, namelen + 1, U8);
1211                 Move(namestr, tmpstr, namelen, U8);
1212                 tmpstr[namelen] = '\0';
1213                 PerlIO_printf(Perl_error_log,
1214                         "INDIRECT %c %s\n", opc, tmpstr);
1215                 Safefree(tmpstr);
1216             }
1217
1218             {
1219                 HV* otherhv;
1220                 SV **otherbitssvp;
1221
1222                 othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
1223                 if (*othersvp && SvROK(*othersvp) &&
1224                                  SvTYPE(SvRV(*othersvp))==SVt_PVHV)
1225                     otherhv = (HV*)SvRV(*othersvp);
1226                 else
1227                     Perl_croak(aTHX_ "otherhv is not a hash reference");
1228
1229                 otherbitssvp = hv_fetch(otherhv, "BITS", 4, FALSE);
1230                 otherbits = (U32)SvUV(*otherbitssvp);
1231                 if (bits < otherbits)
1232                     Perl_croak(aTHX_ "SWASHGET size mismatch");
1233             }
1234
1235             {
1236                 dSP;
1237                 ENTER;
1238                 SAVETMPS;
1239                 PUSHMARK(SP);
1240                 EXTEND(SP,3);
1241                 PUSHs(*othersvp);
1242                 PUSHs(sv_2mortal(newSViv(start)));
1243                 PUSHs(sv_2mortal(newSViv(len)));
1244                 PUTBACK;
1245                 if (call_method("SWASHGET", G_SCALAR)) {
1246                     U8 *s, *o;
1247                     STRLEN slen, olen;
1248                     SV* tmpsv = *PL_stack_sp--;
1249                     o = (U8*)SvPV(tmpsv, olen);
1250
1251                     if (!olen)
1252                         Perl_croak(aTHX_ "SWASHGET didn't return valid swatch");
1253                     s = (U8*)SvPV(swatch, slen);
1254                     if (bits == 1 && otherbits == 1) {
1255                         if (slen != olen)
1256                             Perl_croak(aTHX_ "SWASHGET length mismatch");
1257
1258                         switch (opc) {
1259                         case '+':
1260                             while (slen--)
1261                                 *s++ |= *o++;
1262                             break;
1263                         case '!':
1264                             while (slen--)
1265                                 *s++ |= ~*o++;
1266                             break;
1267                         case '-':
1268                             while (slen--)
1269                                 *s++ &= ~*o++;
1270                             break;
1271                         case '&':
1272                             while (slen--)
1273                                 *s++ &= *o++;
1274                             break;
1275                         default:
1276                             break;
1277                         }
1278                     }
1279                     else {
1280                         U32 otheroctets = otherbits / 8;
1281                         U32 offset = 0;
1282                         U8* send = s + slen;
1283
1284                         while (s < send) {
1285                             U32 val = 0;
1286
1287                             if (otherbits == 1) {
1288                                 val = (o[offset >> 3] >> (offset & 7)) & 1;
1289                                 ++offset;
1290                             }
1291                             else {
1292                                 U32 vlen = otheroctets;
1293                                 val = *o++;
1294                                 while (--vlen) {
1295                                     val <<= 8;
1296                                     val |= *o++;
1297                                 }
1298                             }
1299
1300                             if      (opc == '+' && val)
1301                                 val = 1;
1302                             else if (opc == '!' && !val)
1303                                 val = 1;
1304                             else if (opc == '-' && val)
1305                                 val = 0;
1306                             else if (opc == '&' && !val)
1307                                 val = 0;
1308                             else {
1309                                 s += octets;
1310                                 continue;
1311                             }
1312
1313                             if (bits == 8)
1314                                 *s++ = (U8)( val & 0xff);
1315                             else if (bits == 16) {
1316                                 *s++ = (U8)((val >>  8) & 0xff);
1317                                 *s++ = (U8)( val        & 0xff);
1318                             }
1319                             else if (bits == 32) {
1320                                 *s++ = (U8)((val >> 24) & 0xff);
1321                                 *s++ = (U8)((val >> 16) & 0xff);
1322                                 *s++ = (U8)((val >>  8) & 0xff);
1323                                 *s++ = (U8)( val        & 0xff);
1324                             }
1325                         }
1326                     }
1327                 }
1328                 FREETMPS;
1329                 LEAVE;
1330             }
1331         }
1332
1333         if (debug) {
1334             U8* s = (U8*)SvPVX(swatch);
1335             PerlIO_printf(Perl_error_log, "CELLS ");
1336             if (bits == 1) {
1337                 U32 key;
1338                 for (key = 0; key < len; key++) {
1339                     int val = (s[key >> 3] >> (key & 7)) & 1;
1340                     PerlIO_printf(Perl_error_log, val ? "1 " : "0 ");
1341                 }
1342             }
1343             else {
1344                 U8* send = s + len * octets;
1345                 while (s < send) {
1346                     U32 vlen = octets;
1347                     U32 val = *s++;
1348                     while (--vlen) {
1349                         val <<= 8;
1350                         val |= *s++;
1351                     }
1352                     PerlIO_printf(Perl_error_log, "%"UVuf" ", (UV)val);
1353                 }
1354             }
1355             PerlIO_printf(Perl_error_log, "\n");
1356         }
1357
1358         ST(0) = swatch;
1359         sv_2mortal(ST(0));
1360     }
1361     XSRETURN(1);
1362 }
1363
1364
1365 /*
1366  * Local variables:
1367  * c-indentation-style: bsd
1368  * c-basic-offset: 4
1369  * indent-tabs-mode: t
1370  * End:
1371  *
1372  * ex: set ts=8 sts=4 sw=4 noet:
1373  */