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 (level > 100)
  49         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  50                    HvNAME(stash));
  51
  52     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  53
  54     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
  55         && (hv = GvHV(gv)))
  56     {
  57         if (SvIV(subgen) == (IV)PL_sub_generation) {
  58             SV* sv;
  59             SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
  60             if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
  61                 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
  62                                   name, HvNAME(stash)) );
  63                 return sv;
  64             }
  65         }
  66         else {
  67             DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
  68                               HvNAME(stash)) );
  69             hv_clear(hv);
  70             sv_setiv(subgen, PL_sub_generation);
  71         }
  72     }
  73
  74     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  75
  76     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  77         if (!hv || !subgen) {
  78             gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  79
  80             gv = *gvp;
  81
  82             if (SvTYPE(gv) != SVt_PVGV)
  83                 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  84
  85             if (!hv)
  86                 hv = GvHVn(gv);
  87             if (!subgen) {
  88                 subgen = newSViv(PL_sub_generation);
  89                 GvSV(gv) = subgen;
  90             }
  91         }
  92         if (hv) {
  93             SV** svp = AvARRAY(av);
  94             /* NOTE: No support for tied ISA */
  95             I32 items = AvFILLp(av) + 1;
  96             while (items--) {
  97                 SV* sv = *svp++;
  98                 HV* basestash = gv_stashsv(sv, FALSE);
  99                 if (!basestash) {
 100                     if (ckWARN(WARN_MISC))
 101                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 102                              "Can't locate package %"SVf" for @%s::ISA",
 103                             sv, HvNAME(stash));
 104                     continue;
 105                 }
 106                 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
 107                                              len, level + 1)) {
 108                     (void)hv_store(hv,name,len,&PL_sv_yes,0);
 109                     return &PL_sv_yes;
 110                 }
 111             }
 112             (void)hv_store(hv,name,len,&PL_sv_no,0);
 113         }
 114     }
 115
 116     return boolSV(strEQ(name, "UNIVERSAL"));
 117 }
 118
 119 /*
 120 =head1 SV Manipulation Functions
 121
 122 =for apidoc sv_derived_from
 123
 124 Returns a boolean indicating whether the SV is derived from the specified
 125 class.  This is the function that implements C<UNIVERSAL::isa>.  It works
 126 for class names as well as for objects.
 127
 128 =cut
 129 */
 130
 131 bool
 132 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 133 {
 134     char *type;
 135     HV *stash;
 136     HV *name_stash;
 137
 138     stash = Nullhv;
 139     type = Nullch;
 140
 141     if (SvGMAGICAL(sv))
 142         mg_get(sv) ;
 143
 144     if (SvROK(sv)) {
 145         sv = SvRV(sv);
 146         type = sv_reftype(sv,0);
 147         if (SvOBJECT(sv))
 148             stash = SvSTASH(sv);
 149     }
 150     else {
 151         stash = gv_stashsv(sv, FALSE);
 152     }
 153
 154     name_stash = gv_stashpv(name, FALSE);
 155
 156     return (type && strEQ(type,name)) ||
 157             (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
 158              == &PL_sv_yes)
 159         ? TRUE
 160         : FALSE ;
 161 }
 162
 163 #include "XSUB.h"
 164
 165 void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 166 void XS_UNIVERSAL_can(pTHX_ CV *cv);
 167 void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 168 XS(XS_utf8_valid);
 169 XS(XS_utf8_encode);
 170 XS(XS_utf8_decode);
 171 XS(XS_utf8_upgrade);
 172 XS(XS_utf8_downgrade);
 173 XS(XS_utf8_unicode_to_native);
 174 XS(XS_utf8_native_to_unicode);
 175 XS(XS_Internals_SvREADONLY);
 176 XS(XS_Internals_SvREFCNT);
 177 XS(XS_Internals_hv_clear_placehold);
 178 XS(XS_PerlIO_get_layers);
 179
 180 void
 181 Perl_boot_core_UNIVERSAL(pTHX)
 182 {
 183     char *file = __FILE__;
 184
 185     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
 186     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
 187     newXS("UNIVERSAL::VERSION",         XS_UNIVERSAL_VERSION,     file);
 188     newXS("utf8::valid", XS_utf8_valid, file);
 189     newXS("utf8::encode", XS_utf8_encode, file);
 190     newXS("utf8::decode", XS_utf8_decode, file);
 191     newXS("utf8::upgrade", XS_utf8_upgrade, file);
 192     newXS("utf8::downgrade", XS_utf8_downgrade, file);
 193     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
 194     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
 195     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
 196     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
 197     newXSproto("Internals::hv_clear_placeholders",
 198                XS_Internals_hv_clear_placehold, file, "\\%");
 199     newXSproto("PerlIO::get_layers",
 200                XS_PerlIO_get_layers, file, "*;@");
 201 }
 202
 203
 204 XS(XS_UNIVERSAL_isa)
 205 {
 206     dXSARGS;
 207     SV *sv;
 208     char *name;
 209     STRLEN n_a;
 210
 211     if (items != 2)
 212         Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 213
 214     sv = ST(0);
 215
 216     if (SvGMAGICAL(sv))
 217         mg_get(sv);
 218
 219     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 220                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 221         XSRETURN_UNDEF;
 222
 223     name = (char *)SvPV(ST(1),n_a);
 224
 225     ST(0) = boolSV(sv_derived_from(sv, name));
 226     XSRETURN(1);
 227 }
 228
 229 XS(XS_UNIVERSAL_can)
 230 {
 231     dXSARGS;
 232     SV   *sv;
 233     char *name;
 234     SV   *rv;
 235     HV   *pkg = NULL;
 236     STRLEN n_a;
 237
 238     if (items != 2)
 239         Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 240
 241     sv = ST(0);
 242
 243     if (SvGMAGICAL(sv))
 244         mg_get(sv);
 245
 246     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
 247                 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
 248         XSRETURN_UNDEF;
 249
 250     name = (char *)SvPV(ST(1),n_a);
 251     rv = &PL_sv_undef;
 252
 253     if (SvROK(sv)) {
 254         sv = (SV*)SvRV(sv);
 255         if (SvOBJECT(sv))
 256             pkg = SvSTASH(sv);
 257     }
 258     else {
 259         pkg = gv_stashsv(sv, FALSE);
 260     }
 261
 262     if (pkg) {
 263         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
 264         if (gv && isGV(gv))
 265             rv = sv_2mortal(newRV((SV*)GvCV(gv)));
 266     }
 267
 268     ST(0) = rv;
 269     XSRETURN(1);
 270 }
 271
 272 XS(XS_UNIVERSAL_VERSION)
 273 {
 274     dXSARGS;
 275     HV *pkg;
 276     GV **gvp;
 277     GV *gv;
 278     SV *sv;
 279     char *undef;
 280
 281     if (SvROK(ST(0))) {
 282         sv = (SV*)SvRV(ST(0));
 283         if (!SvOBJECT(sv))
 284             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
 285         pkg = SvSTASH(sv);
 286     }
 287     else {
 288         pkg = gv_stashsv(ST(0), FALSE);
 289     }
 290
 291     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
 292
 293     if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
 294         SV *nsv = sv_newmortal();
 295         sv_setsv(nsv, sv);
 296         sv = nsv;
 297         undef = Nullch;
 298     }
 299     else {
 300         sv = (SV*)&PL_sv_undef;
 301         undef = "(undef)";
 302     }
 303
 304     if (items > 1) {
 305         STRLEN len;
 306         SV *req = ST(1);
 307
 308         if (undef) {
 309              if (pkg)
 310                   Perl_croak(aTHX_
 311                              "%s does not define $%s::VERSION--version check failed",
 312                              HvNAME(pkg), HvNAME(pkg));
 313              else {
 314                   char *str = SvPVx(ST(0), len);
 315
 316                   Perl_croak(aTHX_
 317                              "%s defines neither package nor VERSION--version check failed", str);
 318              }
 319         }
 320         if (!SvNIOK(sv) && SvPOK(sv)) {
 321             char *str = SvPVx(sv,len);
 322             while (len) {
 323                 --len;
 324                 /* XXX could DWIM "1.2.3" here */
 325                 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
 326                     break;
 327             }
 328             if (len) {
 329                 if (SvNOK(req) && SvPOK(req)) {
 330                     /* they said C<use Foo v1.2.3> and $Foo::VERSION
 331                      * doesn't look like a float: do string compare */
 332                     if (sv_cmp(req,sv) == 1) {
 333                         Perl_croak(aTHX_ "%s v%"VDf" required--"
 334                                    "this is only v%"VDf,
 335                                    HvNAME(pkg), req, sv);
 336                     }
 337                     goto finish;
 338                 }
 339                 /* they said C<use Foo 1.002_003> and $Foo::VERSION
 340                  * doesn't look like a float: force numeric compare */
 341                 (void)SvUPGRADE(sv, SVt_PVNV);
 342                 SvNVX(sv) = str_to_version(sv);
 343                 SvPOK_off(sv);
 344                 SvNOK_on(sv);
 345             }
 346         }
 347         /* if we get here, we're looking for a numeric comparison,
 348          * so force the required version into a float, even if they
 349          * said C<use Foo v1.2.3> */
 350         if (SvNOK(req) && SvPOK(req)) {
 351             NV n = SvNV(req);
 352             req = sv_newmortal();
 353             sv_setnv(req, n);
 354         }
 355
 356         if (SvNV(req) > SvNV(sv))
 357             Perl_croak(aTHX_ "%s version %s required--this is only version %s",
 358                        HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
 359     }
 360
 361 finish:
 362     ST(0) = sv;
 363
 364     XSRETURN(1);
 365 }
 366
 367 XS(XS_utf8_valid)
 368 {
 369     dXSARGS;
 370     if (items != 1)
 371         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
 372     {
 373         SV *    sv = ST(0);
 374  {
 375   STRLEN len;
 376   char *s = SvPV(sv,len);
 377   if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
 378    XSRETURN_YES;
 379   else
 380    XSRETURN_NO;
 381  }
 382     }
 383     XSRETURN_EMPTY;
 384 }
 385
 386 XS(XS_utf8_encode)
 387 {
 388     dXSARGS;
 389     if (items != 1)
 390         Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
 391     {
 392         SV *    sv = ST(0);
 393
 394         sv_utf8_encode(sv);
 395     }
 396     XSRETURN_EMPTY;
 397 }
 398
 399 XS(XS_utf8_decode)
 400 {
 401     dXSARGS;
 402     if (items != 1)
 403         Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
 404     {
 405         SV *    sv = ST(0);
 406         bool    RETVAL;
 407
 408         RETVAL = sv_utf8_decode(sv);
 409         ST(0) = boolSV(RETVAL);
 410         sv_2mortal(ST(0));
 411     }
 412     XSRETURN(1);
 413 }
 414
 415 XS(XS_utf8_upgrade)
 416 {
 417     dXSARGS;
 418     if (items != 1)
 419         Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
 420     {
 421         SV *    sv = ST(0);
 422         STRLEN  RETVAL;
 423         dXSTARG;
 424
 425         RETVAL = sv_utf8_upgrade(sv);
 426         XSprePUSH; PUSHi((IV)RETVAL);
 427     }
 428     XSRETURN(1);
 429 }
 430
 431 XS(XS_utf8_downgrade)
 432 {
 433     dXSARGS;
 434     if (items < 1 || items > 2)
 435         Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
 436     {
 437         SV *    sv = ST(0);
 438         bool    failok;
 439         bool    RETVAL;
 440
 441         if (items < 2)
 442             failok = 0;
 443         else {
 444             failok = (int)SvIV(ST(1));
 445         }
 446
 447         RETVAL = sv_utf8_downgrade(sv, failok);
 448         ST(0) = boolSV(RETVAL);
 449         sv_2mortal(ST(0));
 450     }
 451     XSRETURN(1);
 452 }
 453
 454 XS(XS_utf8_native_to_unicode)
 455 {
 456  dXSARGS;
 457  UV uv = SvUV(ST(0));
 458
 459  if (items > 1)
 460      Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
 461
 462  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
 463  XSRETURN(1);
 464 }
 465
 466 XS(XS_utf8_unicode_to_native)
 467 {
 468  dXSARGS;
 469  UV uv = SvUV(ST(0));
 470
 471  if (items > 1)
 472      Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
 473
 474  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
 475  XSRETURN(1);
 476 }
 477
 478 XS(XS_Internals_SvREADONLY)     /* This is dangerous stuff. */
 479 {
 480     dXSARGS;
 481     SV *sv = SvRV(ST(0));
 482     if (items == 1) {
 483          if (SvREADONLY(sv))
 484              XSRETURN_YES;
 485          else
 486              XSRETURN_NO;
 487     }
 488     else if (items == 2) {
 489         if (SvTRUE(ST(1))) {
 490             SvREADONLY_on(sv);
 491             XSRETURN_YES;
 492         }
 493         else {
 494             /* I hope you really know what you are doing. */
 495             SvREADONLY_off(sv);
 496             XSRETURN_NO;
 497         }
 498     }
 499     XSRETURN_UNDEF; /* Can't happen. */
 500 }
 501
 502 XS(XS_Internals_SvREFCNT)       /* This is dangerous stuff. */
 503 {
 504     dXSARGS;
 505     SV *sv = SvRV(ST(0));
 506     if (items == 1)
 507          XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
 508     else if (items == 2) {
 509          /* I hope you really know what you are doing. */
 510          SvREFCNT(sv) = SvIV(ST(1));
 511          XSRETURN_IV(SvREFCNT(sv));
 512     }
 513     XSRETURN_UNDEF; /* Can't happen. */
 514 }
 515
 516 /* Maybe this should return the number of placeholders found in scalar context,
 517    and a list of them in list context.  */
 518 XS(XS_Internals_hv_clear_placehold)
 519 {
 520     dXSARGS;
 521     HV *hv = (HV *) SvRV(ST(0));
 522
 523     /* I don't care how many parameters were passed in, but I want to avoid
 524        the unused variable warning. */
 525
 526     items = (I32)HvPLACEHOLDERS(hv);
 527
 528     if (items) {
 529         HE *entry;
 530         I32 riter = HvRITER(hv);
 531         HE *eiter = HvEITER(hv);
 532         hv_iterinit(hv);
 533         /* This may look suboptimal with the items *after* the iternext, but
 534            it's quite deliberate. We only get here with items==0 if we've
 535            just deleted the last placeholder in the hash. If we've just done
 536            that then it means that the hash is in lazy delete mode, and the
 537            HE is now only referenced in our iterator. If we just quit the loop
 538            and discarded our iterator then the HE leaks. So we do the && the
 539            other way to ensure iternext is called just one more time, which
 540            has the side effect of triggering the lazy delete.  */
 541         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
 542             && items) {
 543             SV *val = hv_iterval(hv, entry);
 544
 545             if (val == &PL_sv_undef) {
 546
 547                 /* It seems that I have to go back in the front of the hash
 548                    API to delete a hash, even though I have a HE structure
 549                    pointing to the very entry I want to delete, and could hold
 550                    onto the previous HE that points to it. And it's easier to
 551                    go in with SVs as I can then specify the precomputed hash,
 552                    and don't have fun and games with utf8 keys.  */
 553                 SV *key = hv_iterkeysv(entry);
 554
 555                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
 556                 items--;
 557             }
 558         }
 559         HvRITER(hv) = riter;
 560         HvEITER(hv) = eiter;
 561     }
 562
 563     XSRETURN(0);
 564 }
 565
 566 XS(XS_PerlIO_get_layers)
 567 {
 568     dXSARGS;
 569     if (items < 1 || items % 2 == 0)
 570         Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
 571 #ifdef USE_PERLIO
 572     {
 573         SV *    sv;
 574         GV *    gv;
 575         IO *    io;
 576         bool    input = TRUE;
 577         bool    details = FALSE;
 578
 579         if (items > 1) {
 580              SV **svp;
 581
 582              for (svp = MARK + 2; svp <= SP; svp += 2) {
 583                   SV **varp = svp;
 584                   SV **valp = svp + 1;
 585                   STRLEN klen;
 586                   char *key = SvPV(*varp, klen);
 587
 588                   switch (*key) {
 589                   case 'i':
 590                        if (klen == 5 && memEQ(key, "input", 5)) {
 591                             input = SvTRUE(*valp);
 592                             break;
 593                        }
 594                        goto fail;
 595                   case 'o':
 596                        if (klen == 6 && memEQ(key, "output", 6)) {
 597                             input = !SvTRUE(*valp);
 598                             break;
 599                        }
 600                        goto fail;
 601                   case 'd':
 602                        if (klen == 7 && memEQ(key, "details", 7)) {
 603                             details = SvTRUE(*valp);
 604                             break;
 605                        }
 606                        goto fail;
 607                   default:
 608                   fail:
 609                        Perl_croak(aTHX_
 610                                   "get_layers: unknown argument '%s'",
 611                                   key);
 612                   }
 613              }
 614
 615              SP -= (items - 1);
 616         }
 617
 618         sv = POPs;
 619         gv = (GV*)sv;
 620
 621         if (!isGV(sv)) {
 622              if (SvROK(sv) && isGV(SvRV(sv)))
 623                   gv = (GV*)SvRV(sv);
 624              else
 625                   gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
 626         }
 627
 628         if (gv && (io = GvIO(gv))) {
 629              dTARGET;
 630              AV* av = PerlIO_get_layers(aTHX_ input ?
 631                                         IoIFP(io) : IoOFP(io));
 632              I32 i;
 633              I32 last = av_len(av);
 634              I32 nitem = 0;
 635
 636              for (i = last; i >= 0; i -= 3) {
 637                   SV **namsvp;
 638                   SV **argsvp;
 639                   SV **flgsvp;
 640                   bool namok, argok, flgok;
 641
 642                   namsvp = av_fetch(av, i - 2, FALSE);
 643                   argsvp = av_fetch(av, i - 1, FALSE);
 644                   flgsvp = av_fetch(av, i,     FALSE);
 645
 646                   namok = namsvp && *namsvp && SvPOK(*namsvp);
 647                   argok = argsvp && *argsvp && SvPOK(*argsvp);
 648                   flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 649
 650                   if (details) {
 651                        XPUSHs(namok ?
 652                              newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
 653                        XPUSHs(argok ?
 654                              newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
 655                        if (flgok)
 656                             XPUSHi(SvIVX(*flgsvp));
 657                        else
 658                             XPUSHs(&PL_sv_undef);
 659                        nitem += 3;
 660                   }
 661                   else {
 662                        if (namok && argok)
 663                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
 664                                                *namsvp, *argsvp));
 665                        else if (namok)
 666                             XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
 667                        else
 668                             XPUSHs(&PL_sv_undef);
 669                        nitem++;
 670                        if (flgok) {
 671                             IV flags = SvIVX(*flgsvp);
 672
 673                             if (flags & PERLIO_F_UTF8) {
 674                                  XPUSHs(newSVpvn("utf8", 4));
 675                                  nitem++;
 676                             }
 677                        }
 678                   }
 679              }
 680
 681              SvREFCNT_dec(av);
 682
 683              XSRETURN(nitem);
 684         }
 685     }
 686 #endif
 687
 688     XSRETURN(0);
 689 }
 690