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