perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2001, Nick Ing-Simmons
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
  11    a dTHX to get at the dispatch tables, even when we do not
  12    need it for other reasons.
  13    Invent a dSYS macro to abstract this out
  14 */
  15 #ifdef PERL_IMPLICIT_SYS
  16 #define dSYS dTHX
  17 #else
  18 #define dSYS dNOOP
  19 #endif
  20
  21 #define VOIDUSED 1
  22 #ifdef PERL_MICRO
  23 #   include "uconfig.h"
  24 #else
  25 #   include "config.h"
  26 #endif
  27
  28 #define PERLIO_NOT_STDIO 0
  29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  30 /* #define PerlIO FILE */
  31 #endif
  32 /*
  33  * This file provides those parts of PerlIO abstraction
  34  * which are not #defined in perlio.h.
  35  * Which these are depends on various Configure #ifdef's
  36  */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_PERLIO_C
  40 #include "perl.h"
  41
  42 #undef PerlMemShared_calloc
  43 #define PerlMemShared_calloc(x,y) calloc(x,y)
  44 #undef PerlMemShared_free
  45 #define PerlMemShared_free(x) free(x)
  46
  47 int
  48 perlsio_binmode(FILE *fp, int iotype, int mode)
  49 {
  50 /* This used to be contents of do_binmode in doio.c */
  51 #ifdef DOSISH
  52 #  if defined(atarist) || defined(__MINT__)
  53     if (!fflush(fp)) {
  54         if (mode & O_BINARY)
  55             ((FILE*)fp)->_flag |= _IOBIN;
  56         else
  57             ((FILE*)fp)->_flag &= ~ _IOBIN;
  58         return 1;
  59     }
  60     return 0;
  61 #  else
  62     dTHX;
  63     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  64 #    if defined(WIN32) && defined(__BORLANDC__)
  65         /* The translation mode of the stream is maintained independent
  66          * of the translation mode of the fd in the Borland RTL (heavy
  67          * digging through their runtime sources reveal).  User has to
  68          * set the mode explicitly for the stream (though they don't
  69          * document this anywhere). GSAR 97-5-24
  70          */
  71         fseek(fp,0L,0);
  72         if (mode & O_BINARY)
  73             fp->flags |= _F_BIN;
  74         else
  75             fp->flags &= ~ _F_BIN;
  76 #    endif
  77         return 1;
  78     }
  79     else
  80         return 0;
  81 #  endif
  82 #else
  83 #  if defined(USEMYBINMODE)
  84     if (my_binmode(fp, iotype, mode) != FALSE)
  85         return 1;
  86     else
  87         return 0;
  88 #  else
  89     return 1;
  90 #  endif
  91 #endif
  92 }
  93
  94 #ifndef PERLIO_LAYERS
  95 int
  96 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  97 {
  98  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  99   {
 100    return 0;
 101   }
 102  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
 103  /* NOTREACHED */
 104  return -1;
 105 }
 106
 107 void
 108 PerlIO_destruct(pTHX)
 109 {
 110 }
 111
 112 int
 113 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 114 {
 115  return perlsio_binmode(fp,iotype,mode);
 116 }
 117
 118 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
 119
 120 PerlIO *
 121 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
 122 {
 123  if (narg == 1)
 124   {
 125    if (*args == &PL_sv_undef)
 126     return PerlIO_tmpfile();
 127    else
 128     {
 129      char *name = SvPV_nolen(*args);
 130      if (*mode == '#')
 131       {
 132        fd = PerlLIO_open3(name,imode,perm);
 133        if (fd >= 0)
 134         return PerlIO_fdopen(fd,(char *)mode+1);
 135       }
 136      else if (old)
 137       {
 138        return PerlIO_reopen(name,mode,old);
 139       }
 140      else
 141       {
 142        return PerlIO_open(name,mode);
 143       }
 144     }
 145   }
 146  else
 147   {
 148    return PerlIO_fdopen(fd,(char *)mode);
 149   }
 150  return NULL;
 151 }
 152
 153 #endif
 154
 155
 156 #ifdef PERLIO_IS_STDIO
 157
 158 void
 159 PerlIO_init(void)
 160 {
 161  /* Does nothing (yet) except force this file to be included
 162     in perl binary. That allows this file to force inclusion
 163     of other functions that may be required by loadable
 164     extensions e.g. for FileHandle::tmpfile
 165  */
 166 }
 167
 168 #undef PerlIO_tmpfile
 169 PerlIO *
 170 PerlIO_tmpfile(void)
 171 {
 172  return tmpfile();
 173 }
 174
 175 #else /* PERLIO_IS_STDIO */
 176
 177 #ifdef USE_SFIO
 178
 179 #undef HAS_FSETPOS
 180 #undef HAS_FGETPOS
 181
 182 /* This section is just to make sure these functions
 183    get pulled in from libsfio.a
 184 */
 185
 186 #undef PerlIO_tmpfile
 187 PerlIO *
 188 PerlIO_tmpfile(void)
 189 {
 190  return sftmp(0);
 191 }
 192
 193 void
 194 PerlIO_init(void)
 195 {
 196  /* Force this file to be included  in perl binary. Which allows
 197   *  this file to force inclusion  of other functions that may be
 198   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 199   */
 200
 201  /* Hack
 202   * sfio does its own 'autoflush' on stdout in common cases.
 203   * Flush results in a lot of lseek()s to regular files and
 204   * lot of small writes to pipes.
 205   */
 206  sfset(sfstdout,SF_SHARE,0);
 207 }
 208
 209 #else /* USE_SFIO */
 210 /*======================================================================================*/
 211 /* Implement all the PerlIO interface ourselves.
 212  */
 213
 214 #include "perliol.h"
 215
 216 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 217 #ifdef I_UNISTD
 218 #include <unistd.h>
 219 #endif
 220 #ifdef HAS_MMAP
 221 #include <sys/mman.h>
 222 #endif
 223
 224 #include "XSUB.h"
 225
 226 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 227
 228 void
 229 PerlIO_debug(const char *fmt,...)
 230 {
 231  static int dbg = 0;
 232  va_list ap;
 233  dSYS;
 234  va_start(ap,fmt);
 235  if (!dbg)
 236   {
 237    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 238    if (s && *s)
 239     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 240    else
 241     dbg = -1;
 242   }
 243  if (dbg > 0)
 244   {
 245    dTHX;
 246    SV *sv = newSVpvn("",0);
 247    char *s;
 248    STRLEN len;
 249    s = CopFILE(PL_curcop);
 250    if (!s)
 251     s = "(none)";
 252    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 253    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 254
 255    s = SvPV(sv,len);
 256    PerlLIO_write(dbg,s,len);
 257    SvREFCNT_dec(sv);
 258   }
 259  va_end(ap);
 260 }
 261
 262 /*--------------------------------------------------------------------------------------*/
 263
 264 /* Inner level routines */
 265
 266 /* Table of pointers to the PerlIO structs (malloc'ed) */
 267 PerlIO *_perlio      = NULL;
 268 #define PERLIO_TABLE_SIZE 64
 269
 270
 271
 272 PerlIO *
 273 PerlIO_allocate(pTHX)
 274 {
 275  /* Find a free slot in the table, allocating new table as necessary */
 276  PerlIO **last;
 277  PerlIO *f;
 278  last = &_perlio;
 279  while ((f = *last))
 280   {
 281    int i;
 282    last = (PerlIO **)(f);
 283    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 284     {
 285      if (!*++f)
 286       {
 287        return f;
 288       }
 289     }
 290   }
 291  f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
 292  if (!f)
 293   {
 294    return NULL;
 295   }
 296  *last = f;
 297  return f+1;
 298 }
 299
 300 void
 301 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 302 {
 303  PerlIO *table = *tablep;
 304  if (table)
 305   {
 306    int i;
 307    PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
 308    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 309     {
 310      PerlIO *f = table+i;
 311      if (*f)
 312       {
 313        PerlIO_close(f);
 314       }
 315     }
 316    PerlMemShared_free(table);
 317    *tablep = NULL;
 318   }
 319 }
 320
 321 HV *PerlIO_layer_hv;
 322 AV *PerlIO_layer_av;
 323
 324 void
 325 PerlIO_cleanup_layers(pTHXo_ void *data)
 326 {
 327  PerlIO_layer_hv = Nullhv;
 328  PerlIO_layer_av = Nullav;
 329 }
 330
 331 void
 332 PerlIO_cleanup()
 333 {
 334  dTHX;
 335  PerlIO_cleantable(aTHX_ &_perlio);
 336 }
 337
 338 void
 339 PerlIO_destruct(pTHX)
 340 {
 341  PerlIO **table = &_perlio;
 342  PerlIO *f;
 343  while ((f = *table))
 344   {
 345    int i;
 346    table = (PerlIO **)(f++);
 347    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 348     {
 349      PerlIO *x = f;
 350      PerlIOl *l;
 351      while ((l = *x))
 352       {
 353        if (l->tab->kind & PERLIO_K_DESTRUCT)
 354         {
 355          PerlIO_debug("Destruct popping %s\n",l->tab->name);
 356          PerlIO_flush(x);
 357          PerlIO_pop(aTHX_ x);
 358         }
 359        else
 360         {
 361          x = PerlIONext(x);
 362         }
 363       }
 364      f++;
 365     }
 366   }
 367 }
 368
 369 void
 370 PerlIO_pop(pTHX_ PerlIO *f)
 371 {
 372  PerlIOl *l = *f;
 373  if (l)
 374   {
 375    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 376    if (l->tab->Popped)
 377     (*l->tab->Popped)(f);
 378    *f = l->next;
 379    PerlMemShared_free(l);
 380   }
 381 }
 382
 383 /*--------------------------------------------------------------------------------------*/
 384 /* XS Interface for perl code */
 385
 386 SV *
 387 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 388 {
 389  SV **svp;
 390  SV *sv;
 391  if ((SSize_t) len <= 0)
 392   len = strlen(name);
 393  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 394  if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
 395   {
 396    SV *pkgsv  = newSVpvn("PerlIO",6);
 397    SV *layer  = newSVpvn(name,len);
 398    ENTER;
 399    /* The two SVs are magically freed by load_module */
 400    Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
 401    LEAVE;
 402    /* Say this is lvalue so we get an 'undef' if still not there */
 403    svp  = hv_fetch(PerlIO_layer_hv,name,len,1);
 404   }
 405  if (svp && (sv = *svp))
 406   {
 407    if (SvROK(sv))
 408     return *svp;
 409   }
 410  return Nullsv;
 411 }
 412
 413 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 414
 415 static int
 416 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 417 {
 418  if (SvROK(sv))
 419   {
 420    IO *io = GvIOn((GV *)SvRV(sv));
 421    PerlIO *ifp = IoIFP(io);
 422    PerlIO *ofp = IoOFP(io);
 423    Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
 424   }
 425  return 0;
 426 }
 427
 428 static int
 429 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 430 {
 431  if (SvROK(sv))
 432   {
 433    IO *io = GvIOn((GV *)SvRV(sv));
 434    PerlIO *ifp = IoIFP(io);
 435    PerlIO *ofp = IoOFP(io);
 436    Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
 437   }
 438  return 0;
 439 }
 440
 441 static int
 442 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 443 {
 444  Perl_warn(aTHX_ "clear %"SVf,sv);
 445  return 0;
 446 }
 447
 448 static int
 449 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 450 {
 451  Perl_warn(aTHX_ "free %"SVf,sv);
 452  return 0;
 453 }
 454
 455 MGVTBL perlio_vtab = {
 456  perlio_mg_get,
 457  perlio_mg_set,
 458  NULL, /* len */
 459  perlio_mg_clear,
 460  perlio_mg_free
 461 };
 462
 463 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 464 {
 465  dXSARGS;
 466  SV *sv    = SvRV(ST(1));
 467  AV *av    = newAV();
 468  MAGIC *mg;
 469  int count = 0;
 470  int i;
 471  sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
 472  SvRMAGICAL_off(sv);
 473  mg = mg_find(sv, PERL_MAGIC_ext);
 474  mg->mg_virtual = &perlio_vtab;
 475  mg_magical(sv);
 476  Perl_warn(aTHX_ "attrib %"SVf,sv);
 477  for (i=2; i < items; i++)
 478   {
 479    STRLEN len;
 480    const char *name = SvPV(ST(i),len);
 481    SV *layer  = PerlIO_find_layer(aTHX_ name,len,1);
 482    if (layer)
 483     {
 484      av_push(av,SvREFCNT_inc(layer));
 485     }
 486    else
 487     {
 488      ST(count) = ST(i);
 489      count++;
 490     }
 491   }
 492  SvREFCNT_dec(av);
 493  XSRETURN(count);
 494 }
 495
 496 #endif /* USE_ATTIBUTES_FOR_PERLIO */
 497
 498 SV *
 499 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 500 {
 501  HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
 502  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 503  return sv;
 504 }
 505
 506 void
 507 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 508 {
 509  if (!PerlIO_layer_hv)
 510   {
 511    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 512   }
 513  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
 514  PerlIO_debug("define %s %p\n",tab->name,tab);
 515 }
 516
 517 int
 518 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
 519 {
 520  if (names)
 521   {
 522    const char *s = names;
 523    while (*s)
 524     {
 525      while (isSPACE(*s) || *s == ':')
 526       s++;
 527      if (*s)
 528       {
 529        STRLEN llen = 0;
 530        const char *e = s;
 531        const char *as = Nullch;
 532        STRLEN alen = 0;
 533        if (!isIDFIRST(*s))
 534         {
 535          /* Message is consistent with how attribute lists are passed.
 536             Even though this means "foo : : bar" is seen as an invalid separator
 537             character.  */
 538          char q = ((*s == '\'') ? '"' : '\'');
 539          Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
 540          return -1;
 541         }
 542        do
 543         {
 544          e++;
 545         } while (isALNUM(*e));
 546        llen = e-s;
 547        if (*e == '(')
 548         {
 549          int nesting = 1;
 550          as = ++e;
 551          while (nesting)
 552           {
 553            switch (*e++)
 554             {
 555              case ')':
 556               if (--nesting == 0)
 557                alen = (e-1)-as;
 558               break;
 559              case '(':
 560               ++nesting;
 561               break;
 562              case '\\':
 563               /* It's a nul terminated string, not allowed to \ the terminating null.
 564                  Anything other character is passed over.  */
 565               if (*e++)
 566                {
 567                 break;
 568                }
 569               /* Drop through */
 570              case '\0':
 571               e--;
 572               Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
 573               return -1;
 574              default:
 575               /* boring.  */
 576               break;
 577             }
 578           }
 579         }
 580        if (e > s)
 581         {
 582          SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
 583          if (layer)
 584           {
 585            av_push(av,SvREFCNT_inc(layer));
 586            av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
 587           }
 588          else {
 589           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
 590           return -1;
 591          }
 592         }
 593        s = e;
 594       }
 595     }
 596   }
 597  return 0;
 598 }
 599
 600 void
 601 PerlIO_default_buffer(pTHX_ AV *av)
 602 {
 603  PerlIO_funcs *tab = &PerlIO_perlio;
 604  if (O_BINARY != O_TEXT)
 605   {
 606    tab = &PerlIO_crlf;
 607   }
 608  else
 609   {
 610    if (PerlIO_stdio.Set_ptrcnt)
 611     {
 612      tab = &PerlIO_stdio;
 613     }
 614   }
 615  PerlIO_debug("Pushing %s\n",tab->name);
 616  av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
 617  av_push(av,&PL_sv_undef);
 618 }
 619
 620 SV *
 621 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
 622 {
 623  SV **svp = av_fetch(av,n,FALSE);
 624  return (svp) ? *svp : Nullsv;
 625 }
 626
 627 PerlIO_funcs *
 628 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
 629 {
 630  SV **svp = av_fetch(av,n,FALSE);
 631  SV *layer;
 632  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 633   {
 634    /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
 635    return INT2PTR(PerlIO_funcs *, SvIV(layer));
 636   }
 637  if (!def)
 638   Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
 639  return def;
 640 }
 641
 642 AV *
 643 PerlIO_default_layers(pTHX)
 644 {
 645  IV len;
 646  if (!PerlIO_layer_av)
 647   {
 648    const char *s  = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
 649    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 650
 651 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 652    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 653 #endif
 654
 655    PerlIO_define_layer(aTHX_ &PerlIO_raw);
 656    PerlIO_define_layer(aTHX_ &PerlIO_unix);
 657    PerlIO_define_layer(aTHX_ &PerlIO_perlio);
 658    PerlIO_define_layer(aTHX_ &PerlIO_stdio);
 659    PerlIO_define_layer(aTHX_ &PerlIO_crlf);
 660 #ifdef HAS_MMAP
 661    PerlIO_define_layer(aTHX_ &PerlIO_mmap);
 662 #endif
 663    PerlIO_define_layer(aTHX_ &PerlIO_utf8);
 664    PerlIO_define_layer(aTHX_ &PerlIO_byte);
 665    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
 666    av_push(PerlIO_layer_av,&PL_sv_undef);
 667    if (s)
 668     {
 669      PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
 670     }
 671    else
 672     {
 673      PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
 674     }
 675   }
 676  len  = av_len(PerlIO_layer_av)+1;
 677  if (len < 2)
 678   {
 679    PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
 680    len  = av_len(PerlIO_layer_av);
 681   }
 682  return PerlIO_layer_av;
 683 }
 684
 685
 686 PerlIO_funcs *
 687 PerlIO_default_layer(pTHX_ I32 n)
 688 {
 689  AV *av = PerlIO_default_layers(aTHX);
 690  n *= 2;
 691  if (n < 0)
 692   n += av_len(PerlIO_layer_av)+1;
 693  return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
 694 }
 695
 696 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
 697 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
 698
 699 void
 700 PerlIO_stdstreams(pTHX)
 701 {
 702  if (!_perlio)
 703   {
 704    PerlIO_allocate(aTHX);
 705    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 706    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 707    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 708   }
 709 }
 710
 711 PerlIO *
 712 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
 713 {
 714  PerlIOl *l = NULL;
 715  l = PerlMemShared_calloc(tab->size,sizeof(char));
 716  if (l)
 717   {
 718    Zero(l,tab->size,char);
 719    l->next = *f;
 720    l->tab  = tab;
 721    *f      = l;
 722    PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
 723                  (mode) ? mode : "(Null)",arg);
 724    if ((*l->tab->Pushed)(f,mode,arg) != 0)
 725     {
 726      PerlIO_pop(aTHX_ f);
 727      return NULL;
 728     }
 729   }
 730  return f;
 731 }
 732
 733 IV
 734 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
 735 {
 736  dTHX;
 737  PerlIO_pop(aTHX_ f);
 738  if (*f)
 739   {
 740    PerlIO_flush(f);
 741    PerlIO_pop(aTHX_ f);
 742    return 0;
 743   }
 744  return -1;
 745 }
 746
 747 IV
 748 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
 749 {
 750  /* Remove the dummy layer */
 751  dTHX;
 752  PerlIO_pop(aTHX_ f);
 753  /* Pop back to bottom layer */
 754  if (f && *f)
 755   {
 756    PerlIO_flush(f);
 757    while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
 758     {
 759      if (*PerlIONext(f))
 760       {
 761        PerlIO_pop(aTHX_ f);
 762       }
 763      else
 764       {
 765        /* Nothing bellow - push unix on top then remove it */
 766        if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
 767         {
 768          PerlIO_pop(aTHX_ PerlIONext(f));
 769         }
 770        break;
 771       }
 772     }
 773    PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
 774    return 0;
 775   }
 776  return -1;
 777 }
 778
 779 int
 780 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
 781 {
 782  IV max = av_len(layers)+1;
 783  int code = 0;
 784  while (n < max)
 785   {
 786    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
 787    if (tab)
 788     {
 789      if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
 790       {
 791        code = -1;
 792        break;
 793       }
 794     }
 795    n += 2;
 796   }
 797  return code;
 798 }
 799
 800 int
 801 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 802 {
 803  int code = 0;
 804  if (names)
 805   {
 806    AV *layers = newAV();
 807    code = PerlIO_parse_layers(aTHX_ layers,names);
 808    if (code == 0)
 809     {
 810      code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
 811     }
 812    SvREFCNT_dec((SV *) layers);
 813   }
 814  return code;
 815 }
 816
 817
 818 /*--------------------------------------------------------------------------------------*/
 819 /* Given the abstraction above the public API functions */
 820
 821 int
 822 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 823 {
 824  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 825               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 826  if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
 827   {
 828    PerlIO *top = f;
 829    PerlIOl *l;
 830    while ((l = *top))
 831     {
 832      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 833       {
 834        PerlIO_flush(top);
 835        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 836        break;
 837       }
 838      top = PerlIONext(top);
 839     }
 840   }
 841  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 842 }
 843
 844 #undef PerlIO__close
 845 int
 846 PerlIO__close(PerlIO *f)
 847 {
 848  if (f && *f)
 849    return (*PerlIOBase(f)->tab->Close)(f);
 850  else
 851   {
 852    SETERRNO(EBADF,SS$_IVCHAN);
 853    return -1;
 854   }
 855 }
 856
 857 #undef PerlIO_fdupopen
 858 PerlIO *
 859 PerlIO_fdupopen(pTHX_ PerlIO *f)
 860 {
 861  if (f && *f)
 862   {
 863    char buf[8];
 864    int fd = PerlLIO_dup(PerlIO_fileno(f));
 865    PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
 866    if (new)
 867     {
 868      Off_t posn = PerlIO_tell(f);
 869      PerlIO_seek(new,posn,SEEK_SET);
 870     }
 871    return new;
 872   }
 873  else
 874   {
 875    SETERRNO(EBADF,SS$_IVCHAN);
 876    return NULL;
 877   }
 878 }
 879
 880 #undef PerlIO_close
 881 int
 882 PerlIO_close(PerlIO *f)
 883 {
 884  dTHX;
 885  int code = -1;
 886  if (f && *f)
 887   {
 888    code = (*PerlIOBase(f)->tab->Close)(f);
 889    while (*f)
 890     {
 891      PerlIO_pop(aTHX_ f);
 892     }
 893   }
 894  return code;
 895 }
 896
 897 #undef PerlIO_fileno
 898 int
 899 PerlIO_fileno(PerlIO *f)
 900 {
 901  if (f && *f)
 902   return (*PerlIOBase(f)->tab->Fileno)(f);
 903  else
 904   {
 905    SETERRNO(EBADF,SS$_IVCHAN);
 906    return -1;
 907   }
 908 }
 909
 910 static const char *
 911 PerlIO_context_layers(pTHX_ const char *mode)
 912 {
 913  const char *type = NULL;
 914  /* Need to supply default layer info from open.pm */
 915  if (PL_curcop)
 916   {
 917    SV *layers = PL_curcop->cop_io;
 918    if (layers)
 919     {
 920      STRLEN len;
 921      type = SvPV(layers,len);
 922      if (type && mode[0] != 'r')
 923       {
 924        /* Skip to write part */
 925        const char *s = strchr(type,0);
 926        if (s && (s-type) < len)
 927         {
 928          type = s+1;
 929         }
 930       }
 931     }
 932   }
 933  return type;
 934 }
 935
 936 static SV *
 937 PerlIO_layer_from_ref(pTHX_ SV *sv)
 938 {
 939  /* For any scalar type load the handler which is bundled with perl */
 940  if (SvTYPE(sv) < SVt_PVAV)
 941   return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
 942
 943  /* For other types allow if layer is known but don't try and load it */
 944  switch (SvTYPE(sv))
 945   {
 946    case SVt_PVAV:
 947     return PerlIO_find_layer(aTHX_ "Array",5, 0);
 948    case SVt_PVHV:
 949     return PerlIO_find_layer(aTHX_ "Hash",4, 0);
 950    case SVt_PVCV:
 951     return PerlIO_find_layer(aTHX_ "Code",4, 0);
 952    case SVt_PVGV:
 953     return PerlIO_find_layer(aTHX_ "Glob",4, 0);
 954   }
 955  return Nullsv;
 956 }
 957
 958 AV *
 959 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
 960 {
 961  AV *def = PerlIO_default_layers(aTHX);
 962  int incdef = 1;
 963  if (!_perlio)
 964   PerlIO_stdstreams(aTHX);
 965  if (narg)
 966   {
 967    SV *arg = *args;
 968    /* If it is a reference but not an object see if we have a handler for it */
 969    if (SvROK(arg) && !sv_isobject(arg))
 970     {
 971      SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
 972      if (handler)
 973       {
 974        def = newAV();
 975        av_push(def,SvREFCNT_inc(handler));
 976        av_push(def,&PL_sv_undef);
 977        incdef = 0;
 978       }
 979      /* Don't fail if handler cannot be found
 980       * :Via(...) etc. may do something sensible
 981       * else we will just stringfy and open resulting string.
 982       */
 983     }
 984   }
 985  if (!layers)
 986   layers = PerlIO_context_layers(aTHX_ mode);
 987  if (layers && *layers)
 988   {
 989    AV *av;
 990    if (incdef)
 991     {
 992      IV n = av_len(def)+1;
 993      av = newAV();
 994      while (n-- > 0)
 995       {
 996        SV **svp = av_fetch(def,n,0);
 997        av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
 998       }
 999     }
1000    else
1001     {
1002      av = def;
1003     }
1004    PerlIO_parse_layers(aTHX_ av,layers);
1005    return av;
1006   }
1007  else
1008   {
1009    if (incdef)
1010     SvREFCNT_inc(def);
1011    return def;
1012   }
1013 }
1014
1015 PerlIO *
1016 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1017 {
1018  if (!f && narg == 1 && *args == &PL_sv_undef)
1019   {
1020    if ((f = PerlIO_tmpfile()))
1021     {
1022      if (!layers)
1023       layers = PerlIO_context_layers(aTHX_ mode);
1024      if (layers && *layers)
1025       PerlIO_apply_layers(aTHX_ f,mode,layers);
1026     }
1027   }
1028  else
1029   {
1030    AV *layera;
1031    IV n;
1032    PerlIO_funcs *tab = NULL;
1033    if (f && *f)
1034     {
1035      /* This is "reopen" - it is not tested as perl does not use it yet */
1036      PerlIOl *l = *f;
1037      layera = newAV();
1038      while (l)
1039       {
1040        SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1041        av_unshift(layera,2);
1042        av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1043        av_store(layera,1,arg);
1044        l = *PerlIONext(&l);
1045       }
1046     }
1047    else
1048     {
1049      layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1050     }
1051    n = av_len(layera)-1;
1052    while (n >= 0)
1053     {
1054      PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1055      if (t && t->Open)
1056       {
1057        tab = t;
1058        break;
1059       }
1060      n -= 2;
1061     }
1062    if (tab)
1063     {
1064      PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1065                   tab->name,layers,mode,fd,imode,perm,f,narg,args);
1066      f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1067      if (f)
1068       {
1069        if (n+2 < av_len(layera)+1)
1070         {
1071          if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1072           {
1073            f = NULL;
1074           }
1075         }
1076       }
1077     }
1078    SvREFCNT_dec(layera);
1079   }
1080  return f;
1081 }
1082
1083
1084 #undef PerlIO_fdopen
1085 PerlIO *
1086 PerlIO_fdopen(int fd, const char *mode)
1087 {
1088  dTHX;
1089  return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1090 }
1091
1092 #undef PerlIO_open
1093 PerlIO *
1094 PerlIO_open(const char *path, const char *mode)
1095 {
1096  dTHX;
1097  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1098  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1099 }
1100
1101 #undef PerlIO_reopen
1102 PerlIO *
1103 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1104 {
1105  dTHX;
1106  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1107  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1108 }
1109
1110 #undef PerlIO_read
1111 SSize_t
1112 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1113 {
1114  if (f && *f)
1115   return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1116  else
1117   {
1118    SETERRNO(EBADF,SS$_IVCHAN);
1119    return -1;
1120   }
1121 }
1122
1123 #undef PerlIO_unread
1124 SSize_t
1125 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1126 {
1127  if (f && *f)
1128   return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1129  else
1130   {
1131    SETERRNO(EBADF,SS$_IVCHAN);
1132    return -1;
1133   }
1134 }
1135
1136 #undef PerlIO_write
1137 SSize_t
1138 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1139 {
1140  if (f && *f)
1141   return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1142  else
1143   {
1144    SETERRNO(EBADF,SS$_IVCHAN);
1145    return -1;
1146   }
1147 }
1148
1149 #undef PerlIO_seek
1150 int
1151 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1152 {
1153  if (f && *f)
1154   return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1155  else
1156   {
1157    SETERRNO(EBADF,SS$_IVCHAN);
1158    return -1;
1159   }
1160 }
1161
1162 #undef PerlIO_tell
1163 Off_t
1164 PerlIO_tell(PerlIO *f)
1165 {
1166   if (f && *f)
1167    return (*PerlIOBase(f)->tab->Tell)(f);
1168   else
1169    {
1170     SETERRNO(EBADF,SS$_IVCHAN);
1171     return -1;
1172    }
1173 }
1174
1175 #undef PerlIO_flush
1176 int
1177 PerlIO_flush(PerlIO *f)
1178 {
1179  if (f)
1180   {
1181    if (*f)
1182     {
1183      PerlIO_funcs *tab = PerlIOBase(f)->tab;
1184      if (tab && tab->Flush)
1185       {
1186        return (*tab->Flush)(f);
1187       }
1188      else
1189       {
1190        PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1191        SETERRNO(EBADF,SS$_IVCHAN);
1192        return -1;
1193       }
1194     }
1195    else
1196     {
1197      PerlIO_debug("Cannot flush f=%p\n",f);
1198      SETERRNO(EBADF,SS$_IVCHAN);
1199      return -1;
1200     }
1201   }
1202  else
1203   {
1204    /* Is it good API design to do flush-all on NULL,
1205     * a potentially errorneous input?  Maybe some magical
1206     * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1207     * Yes, stdio does similar things on fflush(NULL),
1208     * but should we be bound by their design decisions?
1209     * --jhi */
1210    PerlIO **table = &_perlio;
1211    int code = 0;
1212    while ((f = *table))
1213     {
1214      int i;
1215      table = (PerlIO **)(f++);
1216      for (i=1; i < PERLIO_TABLE_SIZE; i++)
1217       {
1218        if (*f && PerlIO_flush(f) != 0)
1219         code = -1;
1220        f++;
1221       }
1222     }
1223    return code;
1224   }
1225 }
1226
1227 void
1228 PerlIOBase_flush_linebuf()
1229 {
1230  PerlIO **table = &_perlio;
1231  PerlIO *f;
1232  while ((f = *table))
1233   {
1234    int i;
1235    table = (PerlIO **)(f++);
1236    for (i=1; i < PERLIO_TABLE_SIZE; i++)
1237     {
1238      if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1239                 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1240       PerlIO_flush(f);
1241      f++;
1242     }
1243   }
1244 }
1245
1246 #undef PerlIO_fill
1247 int
1248 PerlIO_fill(PerlIO *f)
1249 {
1250  if (f && *f)
1251   return (*PerlIOBase(f)->tab->Fill)(f);
1252  else
1253   {
1254    SETERRNO(EBADF,SS$_IVCHAN);
1255    return -1;
1256   }
1257 }
1258
1259 #undef PerlIO_isutf8
1260 int
1261 PerlIO_isutf8(PerlIO *f)
1262 {
1263  if (f && *f)
1264   return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1265  else
1266   {
1267    SETERRNO(EBADF,SS$_IVCHAN);
1268    return -1;
1269   }
1270 }
1271
1272 #undef PerlIO_eof
1273 int
1274 PerlIO_eof(PerlIO *f)
1275 {
1276  if (f && *f)
1277   return (*PerlIOBase(f)->tab->Eof)(f);
1278  else
1279   {
1280    SETERRNO(EBADF,SS$_IVCHAN);
1281    return -1;
1282   }
1283 }
1284
1285 #undef PerlIO_error
1286 int
1287 PerlIO_error(PerlIO *f)
1288 {
1289  if (f && *f)
1290   return (*PerlIOBase(f)->tab->Error)(f);
1291  else
1292   {
1293    SETERRNO(EBADF,SS$_IVCHAN);
1294    return -1;
1295   }
1296 }
1297
1298 #undef PerlIO_clearerr
1299 void
1300 PerlIO_clearerr(PerlIO *f)
1301 {
1302  if (f && *f)
1303   (*PerlIOBase(f)->tab->Clearerr)(f);
1304  else
1305   SETERRNO(EBADF,SS$_IVCHAN);
1306 }
1307
1308 #undef PerlIO_setlinebuf
1309 void
1310 PerlIO_setlinebuf(PerlIO *f)
1311 {
1312  if (f && *f)
1313   (*PerlIOBase(f)->tab->Setlinebuf)(f);
1314  else
1315   SETERRNO(EBADF,SS$_IVCHAN);
1316 }
1317
1318 #undef PerlIO_has_base
1319 int
1320 PerlIO_has_base(PerlIO *f)
1321 {
1322  if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1323  return 0;
1324 }
1325
1326 #undef PerlIO_fast_gets
1327 int
1328 PerlIO_fast_gets(PerlIO *f)
1329 {
1330  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1331   {
1332    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1333    return (tab->Set_ptrcnt != NULL);
1334   }
1335  return 0;
1336 }
1337
1338 #undef PerlIO_has_cntptr
1339 int
1340 PerlIO_has_cntptr(PerlIO *f)
1341 {
1342  if (f && *f)
1343   {
1344    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1345    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1346   }
1347  return 0;
1348 }
1349
1350 #undef PerlIO_canset_cnt
1351 int
1352 PerlIO_canset_cnt(PerlIO *f)
1353 {
1354  if (f && *f)
1355   {
1356    PerlIOl *l = PerlIOBase(f);
1357    return (l->tab->Set_ptrcnt != NULL);
1358   }
1359  return 0;
1360 }
1361
1362 #undef PerlIO_get_base
1363 STDCHAR *
1364 PerlIO_get_base(PerlIO *f)
1365 {
1366  if (f && *f)
1367   return (*PerlIOBase(f)->tab->Get_base)(f);
1368  return NULL;
1369 }
1370
1371 #undef PerlIO_get_bufsiz
1372 int
1373 PerlIO_get_bufsiz(PerlIO *f)
1374 {
1375  if (f && *f)
1376   return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1377  return 0;
1378 }
1379
1380 #undef PerlIO_get_ptr
1381 STDCHAR *
1382 PerlIO_get_ptr(PerlIO *f)
1383 {
1384  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1385  if (tab->Get_ptr == NULL)
1386   return NULL;
1387  return (*tab->Get_ptr)(f);
1388 }
1389
1390 #undef PerlIO_get_cnt
1391 int
1392 PerlIO_get_cnt(PerlIO *f)
1393 {
1394  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1395  if (tab->Get_cnt == NULL)
1396   return 0;
1397  return (*tab->Get_cnt)(f);
1398 }
1399
1400 #undef PerlIO_set_cnt
1401 void
1402 PerlIO_set_cnt(PerlIO *f,int cnt)
1403 {
1404  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1405 }
1406
1407 #undef PerlIO_set_ptrcnt
1408 void
1409 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1410 {
1411  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1412  if (tab->Set_ptrcnt == NULL)
1413   {
1414    dTHX;
1415    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1416   }
1417  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1418 }
1419
1420 /*--------------------------------------------------------------------------------------*/
1421 /* utf8 and raw dummy layers */
1422
1423 IV
1424 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1425 {
1426  if (PerlIONext(f))
1427   {
1428    dTHX;
1429    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1430    PerlIO_pop(aTHX_ f);
1431    if (tab->kind & PERLIO_K_UTF8)
1432     PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1433    else
1434     PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1435    return 0;
1436   }
1437  return -1;
1438 }
1439
1440 PerlIO_funcs PerlIO_utf8 = {
1441  "utf8",
1442  sizeof(PerlIOl),
1443  PERLIO_K_DUMMY|PERLIO_F_UTF8,
1444  PerlIOUtf8_pushed,
1445  NULL,
1446  NULL,
1447  NULL,
1448  NULL,
1449  NULL,
1450  NULL,
1451  NULL,
1452  NULL,
1453  NULL,
1454  NULL,
1455  NULL, /* flush */
1456  NULL, /* fill */
1457  NULL,
1458  NULL,
1459  NULL,
1460  NULL,
1461  NULL, /* get_base */
1462  NULL, /* get_bufsiz */
1463  NULL, /* get_ptr */
1464  NULL, /* get_cnt */
1465  NULL, /* set_ptrcnt */
1466 };
1467
1468 PerlIO_funcs PerlIO_byte = {
1469  "bytes",
1470  sizeof(PerlIOl),
1471  PERLIO_K_DUMMY,
1472  PerlIOUtf8_pushed,
1473  NULL,
1474  NULL,
1475  NULL,
1476  NULL,
1477  NULL,
1478  NULL,
1479  NULL,
1480  NULL,
1481  NULL,
1482  NULL,
1483  NULL, /* flush */
1484  NULL, /* fill */
1485  NULL,
1486  NULL,
1487  NULL,
1488  NULL,
1489  NULL, /* get_base */
1490  NULL, /* get_bufsiz */
1491  NULL, /* get_ptr */
1492  NULL, /* get_cnt */
1493  NULL, /* set_ptrcnt */
1494 };
1495
1496 PerlIO *
1497 PerlIORaw_open(pTHX_ PerlIO_funcs *self,  AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1498 {
1499  PerlIO_funcs *tab = PerlIO_default_btm();
1500  return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1501 }
1502
1503 PerlIO_funcs PerlIO_raw = {
1504  "raw",
1505  sizeof(PerlIOl),
1506  PERLIO_K_DUMMY,
1507  PerlIORaw_pushed,
1508  PerlIOBase_popped,
1509  PerlIORaw_open,
1510  NULL,
1511  NULL,
1512  NULL,
1513  NULL,
1514  NULL,
1515  NULL,
1516  NULL,
1517  NULL,
1518  NULL, /* flush */
1519  NULL, /* fill */
1520  NULL,
1521  NULL,
1522  NULL,
1523  NULL,
1524  NULL, /* get_base */
1525  NULL, /* get_bufsiz */
1526  NULL, /* get_ptr */
1527  NULL, /* get_cnt */
1528  NULL, /* set_ptrcnt */
1529 };
1530 /*--------------------------------------------------------------------------------------*/
1531 /*--------------------------------------------------------------------------------------*/
1532 /* "Methods" of the "base class" */
1533
1534 IV
1535 PerlIOBase_fileno(PerlIO *f)
1536 {
1537  return PerlIO_fileno(PerlIONext(f));
1538 }
1539
1540 char *
1541 PerlIO_modestr(PerlIO *f,char *buf)
1542 {
1543  char *s = buf;
1544  IV flags = PerlIOBase(f)->flags;
1545  if (flags & PERLIO_F_APPEND)
1546   {
1547    *s++ = 'a';
1548    if (flags & PERLIO_F_CANREAD)
1549     {
1550      *s++ = '+';
1551     }
1552   }
1553  else if (flags & PERLIO_F_CANREAD)
1554   {
1555    *s++ = 'r';
1556    if (flags & PERLIO_F_CANWRITE)
1557     *s++ = '+';
1558   }
1559  else if (flags & PERLIO_F_CANWRITE)
1560   {
1561    *s++ = 'w';
1562    if (flags & PERLIO_F_CANREAD)
1563     {
1564      *s++ = '+';
1565     }
1566   }
1567 #if O_TEXT != O_BINARY
1568  if (!(flags & PERLIO_F_CRLF))
1569   *s++ = 'b';
1570 #endif
1571  *s = '\0';
1572  return buf;
1573 }
1574
1575 IV
1576 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1577 {
1578  PerlIOl *l = PerlIOBase(f);
1579 #if 0
1580  const char *omode = mode;
1581  char temp[8];
1582 #endif
1583  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1584  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1585                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1586  if (tab->Set_ptrcnt != NULL)
1587   l->flags |= PERLIO_F_FASTGETS;
1588  if (mode)
1589   {
1590    if (*mode == '#' || *mode == 'I')
1591     mode++;
1592    switch (*mode++)
1593     {
1594      case 'r':
1595       l->flags |= PERLIO_F_CANREAD;
1596       break;
1597      case 'a':
1598       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1599       break;
1600      case 'w':
1601       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1602       break;
1603      default:
1604       SETERRNO(EINVAL,LIB$_INVARG);
1605       return -1;
1606     }
1607    while (*mode)
1608     {
1609      switch (*mode++)
1610       {
1611        case '+':
1612         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1613         break;
1614        case 'b':
1615         l->flags &= ~PERLIO_F_CRLF;
1616         break;
1617        case 't':
1618         l->flags |= PERLIO_F_CRLF;
1619         break;
1620       default:
1621         SETERRNO(EINVAL,LIB$_INVARG);
1622         return -1;
1623       }
1624     }
1625   }
1626  else
1627   {
1628    if (l->next)
1629     {
1630      l->flags |= l->next->flags &
1631                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1632     }
1633   }
1634 #if 0
1635  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1636               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1637               l->flags,PerlIO_modestr(f,temp));
1638 #endif
1639  return 0;
1640 }
1641
1642 IV
1643 PerlIOBase_popped(PerlIO *f)
1644 {
1645  return 0;
1646 }
1647
1648 SSize_t
1649 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1650 {
1651  dTHX;
1652  Off_t old = PerlIO_tell(f);
1653  SSize_t done;
1654  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1655  done = PerlIOBuf_unread(f,vbuf,count);
1656  PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1657  return done;
1658 }
1659
1660 SSize_t
1661 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1662 {
1663  STDCHAR *buf  = (STDCHAR *) vbuf;
1664  if (f)
1665   {
1666    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1667     return 0;
1668    while (count > 0)
1669     {
1670      SSize_t avail = PerlIO_get_cnt(f);
1671      SSize_t take = 0;
1672      if (avail > 0)
1673        take = (count < avail) ? count : avail;
1674      if (take > 0)
1675       {
1676        STDCHAR *ptr = PerlIO_get_ptr(f);
1677        Copy(ptr,buf,take,STDCHAR);
1678        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1679        count   -= take;
1680        buf     += take;
1681       }
1682      if (count > 0  && avail <= 0)
1683       {
1684        if (PerlIO_fill(f) != 0)
1685         break;
1686       }
1687     }
1688    return (buf - (STDCHAR *) vbuf);
1689   }
1690  return 0;
1691 }
1692
1693 IV
1694 PerlIOBase_noop_ok(PerlIO *f)
1695 {
1696  return 0;
1697 }
1698
1699 IV
1700 PerlIOBase_noop_fail(PerlIO *f)
1701 {
1702  return -1;
1703 }
1704
1705 IV
1706 PerlIOBase_close(PerlIO *f)
1707 {
1708  IV code = 0;
1709  PerlIO *n = PerlIONext(f);
1710  if (PerlIO_flush(f) != 0)
1711   code = -1;
1712  if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1713   code = -1;
1714  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1715  return code;
1716 }
1717
1718 IV
1719 PerlIOBase_eof(PerlIO *f)
1720 {
1721  if (f && *f)
1722   {
1723    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1724   }
1725  return 1;
1726 }
1727
1728 IV
1729 PerlIOBase_error(PerlIO *f)
1730 {
1731  if (f && *f)
1732   {
1733    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1734   }
1735  return 1;
1736 }
1737
1738 void
1739 PerlIOBase_clearerr(PerlIO *f)
1740 {
1741  if (f && *f)
1742   {
1743    PerlIO *n = PerlIONext(f);
1744    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1745    if (n)
1746     PerlIO_clearerr(n);
1747   }
1748 }
1749
1750 void
1751 PerlIOBase_setlinebuf(PerlIO *f)
1752 {
1753  if (f)
1754   {
1755    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1756   }
1757 }
1758
1759 /*--------------------------------------------------------------------------------------*/
1760 /* Bottom-most level for UNIX-like case */
1761
1762 typedef struct
1763 {
1764  struct _PerlIO base;       /* The generic part */
1765  int            fd;         /* UNIX like file descriptor */
1766  int            oflags;     /* open/fcntl flags */
1767 } PerlIOUnix;
1768
1769 int
1770 PerlIOUnix_oflags(const char *mode)
1771 {
1772  int oflags = -1;
1773  switch(*mode)
1774   {
1775    case 'r':
1776     oflags = O_RDONLY;
1777     if (*++mode == '+')
1778      {
1779       oflags = O_RDWR;
1780       mode++;
1781      }
1782     break;
1783
1784    case 'w':
1785     oflags = O_CREAT|O_TRUNC;
1786     if (*++mode == '+')
1787      {
1788       oflags |= O_RDWR;
1789       mode++;
1790      }
1791     else
1792      oflags |= O_WRONLY;
1793     break;
1794
1795    case 'a':
1796     oflags = O_CREAT|O_APPEND;
1797     if (*++mode == '+')
1798      {
1799       oflags |= O_RDWR;
1800       mode++;
1801      }
1802     else
1803      oflags |= O_WRONLY;
1804     break;
1805   }
1806  if (*mode == 'b')
1807   {
1808    oflags |=  O_BINARY;
1809    oflags &= ~O_TEXT;
1810    mode++;
1811   }
1812  else if (*mode == 't')
1813   {
1814    oflags |=  O_TEXT;
1815    oflags &= ~O_BINARY;
1816    mode++;
1817   }
1818  /* Always open in binary mode */
1819  oflags |= O_BINARY;
1820  if (*mode || oflags == -1)
1821   {
1822    SETERRNO(EINVAL,LIB$_INVARG);
1823    oflags = -1;
1824   }
1825  return oflags;
1826 }
1827
1828 IV
1829 PerlIOUnix_fileno(PerlIO *f)
1830 {
1831  return PerlIOSelf(f,PerlIOUnix)->fd;
1832 }
1833
1834 IV
1835 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1836 {
1837  IV code = PerlIOBase_pushed(f,mode,arg);
1838  if (*PerlIONext(f))
1839   {
1840    PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1841    s->fd     = PerlIO_fileno(PerlIONext(f));
1842    s->oflags = PerlIOUnix_oflags(mode);
1843   }
1844  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1845  return code;
1846 }
1847
1848 PerlIO *
1849 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1850 {
1851  if (f)
1852   {
1853    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1854     (*PerlIOBase(f)->tab->Close)(f);
1855   }
1856  if (narg > 0)
1857   {
1858    char *path = SvPV_nolen(*args);
1859    if (*mode == '#')
1860     mode++;
1861    else
1862     {
1863      imode = PerlIOUnix_oflags(mode);
1864      perm  = 0666;
1865     }
1866    if (imode != -1)
1867     {
1868      fd = PerlLIO_open3(path,imode,perm);
1869     }
1870   }
1871  if (fd >= 0)
1872   {
1873    PerlIOUnix *s;
1874    if (*mode == 'I')
1875     mode++;
1876    if (!f)
1877     {
1878      f = PerlIO_allocate(aTHX);
1879      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1880     }
1881    else
1882     s = PerlIOSelf(f,PerlIOUnix);
1883    s->fd     = fd;
1884    s->oflags = imode;
1885    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1886    return f;
1887   }
1888  else
1889   {
1890    if (f)
1891     {
1892      /* FIXME: pop layers ??? */
1893     }
1894    return NULL;
1895   }
1896 }
1897
1898 SSize_t
1899 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1900 {
1901  dTHX;
1902  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1903  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1904   return 0;
1905  while (1)
1906   {
1907    SSize_t len = PerlLIO_read(fd,vbuf,count);
1908    if (len >= 0 || errno != EINTR)
1909     {
1910      if (len < 0)
1911       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1912      else if (len == 0 && count != 0)
1913       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1914      return len;
1915     }
1916    PERL_ASYNC_CHECK();
1917   }
1918 }
1919
1920 SSize_t
1921 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1922 {
1923  dTHX;
1924  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1925  while (1)
1926   {
1927    SSize_t len = PerlLIO_write(fd,vbuf,count);
1928    if (len >= 0 || errno != EINTR)
1929     {
1930      if (len < 0)
1931       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1932      return len;
1933     }
1934    PERL_ASYNC_CHECK();
1935   }
1936 }
1937
1938 IV
1939 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1940 {
1941  dSYS;
1942  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1943  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1944  return (new == (Off_t) -1) ? -1 : 0;
1945 }
1946
1947 Off_t
1948 PerlIOUnix_tell(PerlIO *f)
1949 {
1950  dSYS;
1951  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1952 }
1953
1954 IV
1955 PerlIOUnix_close(PerlIO *f)
1956 {
1957  dTHX;
1958  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1959  int code = 0;
1960  while (PerlLIO_close(fd) != 0)
1961   {
1962    if (errno != EINTR)
1963     {
1964      code = -1;
1965      break;
1966     }
1967    PERL_ASYNC_CHECK();
1968   }
1969  if (code == 0)
1970   {
1971    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1972   }
1973  return code;
1974 }
1975
1976 PerlIO_funcs PerlIO_unix = {
1977  "unix",
1978  sizeof(PerlIOUnix),
1979  PERLIO_K_RAW,
1980  PerlIOUnix_pushed,
1981  PerlIOBase_noop_ok,
1982  PerlIOUnix_open,
1983  NULL,
1984  PerlIOUnix_fileno,
1985  PerlIOUnix_read,
1986  PerlIOBase_unread,
1987  PerlIOUnix_write,
1988  PerlIOUnix_seek,
1989  PerlIOUnix_tell,
1990  PerlIOUnix_close,
1991  PerlIOBase_noop_ok,   /* flush */
1992  PerlIOBase_noop_fail, /* fill */
1993  PerlIOBase_eof,
1994  PerlIOBase_error,
1995  PerlIOBase_clearerr,
1996  PerlIOBase_setlinebuf,
1997  NULL, /* get_base */
1998  NULL, /* get_bufsiz */
1999  NULL, /* get_ptr */
2000  NULL, /* get_cnt */
2001  NULL, /* set_ptrcnt */
2002 };
2003
2004 /*--------------------------------------------------------------------------------------*/
2005 /* stdio as a layer */
2006
2007 typedef struct
2008 {
2009  struct _PerlIO base;
2010  FILE *         stdio;      /* The stream */
2011 } PerlIOStdio;
2012
2013 IV
2014 PerlIOStdio_fileno(PerlIO *f)
2015 {
2016  dSYS;
2017  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2018 }
2019
2020 char *
2021 PerlIOStdio_mode(const char *mode,char *tmode)
2022 {
2023  char *ret = tmode;
2024  while (*mode)
2025   {
2026    *tmode++ = *mode++;
2027   }
2028  if (O_BINARY != O_TEXT)
2029   {
2030    *tmode++ = 'b';
2031   }
2032  *tmode = '\0';
2033  return ret;
2034 }
2035
2036 /* This isn't used yet ... */
2037 IV
2038 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2039 {
2040  if (*PerlIONext(f))
2041   {
2042    dSYS;
2043    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2044    char tmode[8];
2045    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2046    if (stdio)
2047     s->stdio = stdio;
2048    else
2049     return -1;
2050   }
2051  return PerlIOBase_pushed(f,mode,arg);
2052 }
2053
2054 #undef PerlIO_importFILE
2055 PerlIO *
2056 PerlIO_importFILE(FILE *stdio, int fl)
2057 {
2058  dTHX;
2059  PerlIO *f = NULL;
2060  if (stdio)
2061   {
2062    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2063    s->stdio  = stdio;
2064   }
2065  return f;
2066 }
2067
2068 PerlIO *
2069 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2070 {
2071  char tmode[8];
2072  if (f)
2073   {
2074    char *path = SvPV_nolen(*args);
2075    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2076    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2077    if (!s->stdio)
2078     return NULL;
2079    s->stdio = stdio;
2080    return f;
2081   }
2082  else
2083   {
2084    if (narg > 0)
2085     {
2086      char *path = SvPV_nolen(*args);
2087      if (*mode == '#')
2088       {
2089        mode++;
2090        fd = PerlLIO_open3(path,imode,perm);
2091       }
2092      else
2093       {
2094        FILE *stdio = PerlSIO_fopen(path,mode);
2095        if (stdio)
2096         {
2097          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2098                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2099                                      PerlIOStdio);
2100          s->stdio  = stdio;
2101         }
2102        return f;
2103       }
2104     }
2105    if (fd >= 0)
2106     {
2107      FILE *stdio = NULL;
2108      int init = 0;
2109      if (*mode == 'I')
2110       {
2111        init = 1;
2112        mode++;
2113       }
2114      if (init)
2115       {
2116        switch(fd)
2117         {
2118          case 0:
2119           stdio = PerlSIO_stdin;
2120           break;
2121          case 1:
2122           stdio = PerlSIO_stdout;
2123           break;
2124          case 2:
2125           stdio = PerlSIO_stderr;
2126           break;
2127         }
2128       }
2129      else
2130       {
2131        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2132       }
2133      if (stdio)
2134       {
2135        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2136        s->stdio  = stdio;
2137        return f;
2138       }
2139     }
2140   }
2141  return NULL;
2142 }
2143
2144 SSize_t
2145 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2146 {
2147  dSYS;
2148  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2149  SSize_t got = 0;
2150  if (count == 1)
2151   {
2152    STDCHAR *buf = (STDCHAR *) vbuf;
2153    /* Perl is expecting PerlIO_getc() to fill the buffer
2154     * Linux's stdio does not do that for fread()
2155     */
2156    int ch = PerlSIO_fgetc(s);
2157    if (ch != EOF)
2158     {
2159      *buf = ch;
2160      got = 1;
2161     }
2162   }
2163  else
2164   got = PerlSIO_fread(vbuf,1,count,s);
2165  return got;
2166 }
2167
2168 SSize_t
2169 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2170 {
2171  dSYS;
2172  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2173  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2174  SSize_t unread = 0;
2175  while (count > 0)
2176   {
2177    int ch = *buf-- & 0xff;
2178    if (PerlSIO_ungetc(ch,s) != ch)
2179     break;
2180    unread++;
2181    count--;
2182   }
2183  return unread;
2184 }
2185
2186 SSize_t
2187 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2188 {
2189  dSYS;
2190  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2191 }
2192
2193 IV
2194 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2195 {
2196  dSYS;
2197  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2198  return PerlSIO_fseek(stdio,offset,whence);
2199 }
2200
2201 Off_t
2202 PerlIOStdio_tell(PerlIO *f)
2203 {
2204  dSYS;
2205  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2206  return PerlSIO_ftell(stdio);
2207 }
2208
2209 IV
2210 PerlIOStdio_close(PerlIO *f)
2211 {
2212  dSYS;
2213 #ifdef SOCKS5_VERSION_NAME
2214  int optval;
2215  Sock_size_t optlen = sizeof(int);
2216 #endif
2217  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2218  return(
2219 #ifdef SOCKS5_VERSION_NAME
2220    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2221        PerlSIO_fclose(stdio) :
2222        close(PerlIO_fileno(f))
2223 #else
2224    PerlSIO_fclose(stdio)
2225 #endif
2226      );
2227
2228 }
2229
2230 IV
2231 PerlIOStdio_flush(PerlIO *f)
2232 {
2233  dSYS;
2234  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2235  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2236   {
2237    return PerlSIO_fflush(stdio);
2238   }
2239  else
2240   {
2241 #if 0
2242    /* FIXME: This discards ungetc() and pre-read stuff which is
2243       not right if this is just a "sync" from a layer above
2244       Suspect right design is to do _this_ but not have layer above
2245       flush this layer read-to-read
2246     */
2247    /* Not writeable - sync by attempting a seek */
2248    int err = errno;
2249    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2250     errno = err;
2251 #endif
2252   }
2253  return 0;
2254 }
2255
2256 IV
2257 PerlIOStdio_fill(PerlIO *f)
2258 {
2259  dSYS;
2260  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2261  int c;
2262  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2263  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2264   {
2265    if (PerlSIO_fflush(stdio) != 0)
2266     return EOF;
2267   }
2268  c = PerlSIO_fgetc(stdio);
2269  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2270   return EOF;
2271  return 0;
2272 }
2273
2274 IV
2275 PerlIOStdio_eof(PerlIO *f)
2276 {
2277  dSYS;
2278  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2279 }
2280
2281 IV
2282 PerlIOStdio_error(PerlIO *f)
2283 {
2284  dSYS;
2285  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2286 }
2287
2288 void
2289 PerlIOStdio_clearerr(PerlIO *f)
2290 {
2291  dSYS;
2292  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2293 }
2294
2295 void
2296 PerlIOStdio_setlinebuf(PerlIO *f)
2297 {
2298  dSYS;
2299 #ifdef HAS_SETLINEBUF
2300  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2301 #else
2302  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2303 #endif
2304 }
2305
2306 #ifdef FILE_base
2307 STDCHAR *
2308 PerlIOStdio_get_base(PerlIO *f)
2309 {
2310  dSYS;
2311  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2312  return PerlSIO_get_base(stdio);
2313 }
2314
2315 Size_t
2316 PerlIOStdio_get_bufsiz(PerlIO *f)
2317 {
2318  dSYS;
2319  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2320  return PerlSIO_get_bufsiz(stdio);
2321 }
2322 #endif
2323
2324 #ifdef USE_STDIO_PTR
2325 STDCHAR *
2326 PerlIOStdio_get_ptr(PerlIO *f)
2327 {
2328  dSYS;
2329  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2330  return PerlSIO_get_ptr(stdio);
2331 }
2332
2333 SSize_t
2334 PerlIOStdio_get_cnt(PerlIO *f)
2335 {
2336  dSYS;
2337  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2338  return PerlSIO_get_cnt(stdio);
2339 }
2340
2341 void
2342 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2343 {
2344  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2345  dSYS;
2346  if (ptr != NULL)
2347   {
2348 #ifdef STDIO_PTR_LVALUE
2349    PerlSIO_set_ptr(stdio,ptr);
2350 #ifdef STDIO_PTR_LVAL_SETS_CNT
2351    if (PerlSIO_get_cnt(stdio) != (cnt))
2352     {
2353      dTHX;
2354      assert(PerlSIO_get_cnt(stdio) == (cnt));
2355     }
2356 #endif
2357 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2358    /* Setting ptr _does_ change cnt - we are done */
2359    return;
2360 #endif
2361 #else  /* STDIO_PTR_LVALUE */
2362    PerlProc_abort();
2363 #endif /* STDIO_PTR_LVALUE */
2364   }
2365 /* Now (or only) set cnt */
2366 #ifdef STDIO_CNT_LVALUE
2367  PerlSIO_set_cnt(stdio,cnt);
2368 #else  /* STDIO_CNT_LVALUE */
2369 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2370  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2371 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2372  PerlProc_abort();
2373 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2374 #endif /* STDIO_CNT_LVALUE */
2375 }
2376
2377 #endif
2378
2379 PerlIO_funcs PerlIO_stdio = {
2380  "stdio",
2381  sizeof(PerlIOStdio),
2382  PERLIO_K_BUFFERED,
2383  PerlIOBase_pushed,
2384  PerlIOBase_noop_ok,
2385  PerlIOStdio_open,
2386  NULL,
2387  PerlIOStdio_fileno,
2388  PerlIOStdio_read,
2389  PerlIOStdio_unread,
2390  PerlIOStdio_write,
2391  PerlIOStdio_seek,
2392  PerlIOStdio_tell,
2393  PerlIOStdio_close,
2394  PerlIOStdio_flush,
2395  PerlIOStdio_fill,
2396  PerlIOStdio_eof,
2397  PerlIOStdio_error,
2398  PerlIOStdio_clearerr,
2399  PerlIOStdio_setlinebuf,
2400 #ifdef FILE_base
2401  PerlIOStdio_get_base,
2402  PerlIOStdio_get_bufsiz,
2403 #else
2404  NULL,
2405  NULL,
2406 #endif
2407 #ifdef USE_STDIO_PTR
2408  PerlIOStdio_get_ptr,
2409  PerlIOStdio_get_cnt,
2410 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2411  PerlIOStdio_set_ptrcnt
2412 #else  /* STDIO_PTR_LVALUE */
2413  NULL
2414 #endif /* STDIO_PTR_LVALUE */
2415 #else  /* USE_STDIO_PTR */
2416  NULL,
2417  NULL,
2418  NULL
2419 #endif /* USE_STDIO_PTR */
2420 };
2421
2422 #undef PerlIO_exportFILE
2423 FILE *
2424 PerlIO_exportFILE(PerlIO *f, int fl)
2425 {
2426  FILE *stdio;
2427  PerlIO_flush(f);
2428  stdio = fdopen(PerlIO_fileno(f),"r+");
2429  if (stdio)
2430   {
2431    dTHX;
2432    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2433    s->stdio  = stdio;
2434   }
2435  return stdio;
2436 }
2437
2438 #undef PerlIO_findFILE
2439 FILE *
2440 PerlIO_findFILE(PerlIO *f)
2441 {
2442  PerlIOl *l = *f;
2443  while (l)
2444   {
2445    if (l->tab == &PerlIO_stdio)
2446     {
2447      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2448      return s->stdio;
2449     }
2450    l = *PerlIONext(&l);
2451   }
2452  return PerlIO_exportFILE(f,0);
2453 }
2454
2455 #undef PerlIO_releaseFILE
2456 void
2457 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2458 {
2459 }
2460
2461 /*--------------------------------------------------------------------------------------*/
2462 /* perlio buffer layer */
2463
2464 IV
2465 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2466 {
2467  dSYS;
2468  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2469  int fd  = PerlIO_fileno(f);
2470  Off_t posn;
2471  if (fd >= 0 && PerlLIO_isatty(fd))
2472   {
2473    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2474   }
2475  posn = PerlIO_tell(PerlIONext(f));
2476  if (posn != (Off_t) -1)
2477   {
2478    b->posn = posn;
2479   }
2480  return PerlIOBase_pushed(f,mode,arg);
2481 }
2482
2483 PerlIO *
2484 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2485 {
2486  if (f)
2487   {
2488    PerlIO *next = PerlIONext(f);
2489    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2490    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2491    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2492     {
2493      return NULL;
2494     }
2495   }
2496  else
2497   {
2498    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2499    int init = 0;
2500    if (*mode == 'I')
2501     {
2502      init = 1;
2503      mode++;
2504     }
2505    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2506    if (f)
2507     {
2508      PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2509      fd = PerlIO_fileno(f);
2510 #if O_BINARY != O_TEXT
2511      /* do something about failing setmode()? --jhi */
2512      PerlLIO_setmode(fd , O_BINARY);
2513 #endif
2514      if (init && fd == 2)
2515       {
2516        /* Initial stderr is unbuffered */
2517        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2518       }
2519     }
2520   }
2521  return f;
2522 }
2523
2524 /* This "flush" is akin to sfio's sync in that it handles files in either
2525    read or write state
2526 */
2527 IV
2528 PerlIOBuf_flush(PerlIO *f)
2529 {
2530  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2531  int code = 0;
2532  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2533   {
2534    /* write() the buffer */
2535    STDCHAR *buf = b->buf;
2536    STDCHAR *p = buf;
2537    PerlIO *n = PerlIONext(f);
2538    while (p < b->ptr)
2539     {
2540      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2541      if (count > 0)
2542       {
2543        p += count;
2544       }
2545      else if (count < 0 || PerlIO_error(n))
2546       {
2547        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2548        code = -1;
2549        break;
2550       }
2551     }
2552    b->posn += (p - buf);
2553   }
2554  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2555   {
2556    STDCHAR *buf = PerlIO_get_base(f);
2557    /* Note position change */
2558    b->posn += (b->ptr - buf);
2559    if (b->ptr < b->end)
2560     {
2561      /* We did not consume all of it */
2562      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2563       {
2564        b->posn = PerlIO_tell(PerlIONext(f));
2565       }
2566     }
2567   }
2568  b->ptr = b->end = b->buf;
2569  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2570  /* FIXME: Is this right for read case ? */
2571  if (PerlIO_flush(PerlIONext(f)) != 0)
2572   code = -1;
2573  return code;
2574 }
2575
2576 IV
2577 PerlIOBuf_fill(PerlIO *f)
2578 {
2579  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2580  PerlIO *n = PerlIONext(f);
2581  SSize_t avail;
2582  /* FIXME: doing the down-stream flush is a bad idea if it causes
2583     pre-read data in stdio buffer to be discarded
2584     but this is too simplistic - as it skips _our_ hosekeeping
2585     and breaks tell tests.
2586  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2587   {
2588   }
2589   */
2590  if (PerlIO_flush(f) != 0)
2591   return -1;
2592  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2593   PerlIOBase_flush_linebuf();
2594
2595  if (!b->buf)
2596   PerlIO_get_base(f); /* allocate via vtable */
2597
2598  b->ptr = b->end = b->buf;
2599  if (PerlIO_fast_gets(n))
2600   {
2601    /* Layer below is also buffered
2602     * We do _NOT_ want to call its ->Read() because that will loop
2603     * till it gets what we asked for which may hang on a pipe etc.
2604     * Instead take anything it has to hand, or ask it to fill _once_.
2605     */
2606    avail  = PerlIO_get_cnt(n);
2607    if (avail <= 0)
2608     {
2609      avail = PerlIO_fill(n);
2610      if (avail == 0)
2611       avail = PerlIO_get_cnt(n);
2612      else
2613       {
2614        if (!PerlIO_error(n) && PerlIO_eof(n))
2615         avail = 0;
2616       }
2617     }
2618    if (avail > 0)
2619     {
2620      STDCHAR *ptr = PerlIO_get_ptr(n);
2621      SSize_t cnt  = avail;
2622      if (avail > b->bufsiz)
2623       avail = b->bufsiz;
2624      Copy(ptr,b->buf,avail,STDCHAR);
2625      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2626     }
2627   }
2628  else
2629   {
2630    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2631   }
2632  if (avail <= 0)
2633   {
2634    if (avail == 0)
2635     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2636    else
2637     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2638    return -1;
2639   }
2640  b->end      = b->buf+avail;
2641  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2642  return 0;
2643 }
2644
2645 SSize_t
2646 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2647 {
2648  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2649  if (f)
2650   {
2651    if (!b->ptr)
2652     PerlIO_get_base(f);
2653    return PerlIOBase_read(f,vbuf,count);
2654   }
2655  return 0;
2656 }
2657
2658 SSize_t
2659 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2660 {
2661  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2662  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2663  SSize_t unread = 0;
2664  SSize_t avail;
2665  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2666   PerlIO_flush(f);
2667  if (!b->buf)
2668   PerlIO_get_base(f);
2669  if (b->buf)
2670   {
2671    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2672     {
2673      avail = (b->ptr - b->buf);
2674     }
2675    else
2676     {
2677      avail = b->bufsiz;
2678      b->end = b->buf + avail;
2679      b->ptr = b->end;
2680      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2681      b->posn -= b->bufsiz;
2682     }
2683    if (avail > (SSize_t) count)
2684     avail = count;
2685    if (avail > 0)
2686     {
2687      b->ptr -= avail;
2688      buf    -= avail;
2689      if (buf != b->ptr)
2690       {
2691        Copy(buf,b->ptr,avail,STDCHAR);
2692       }
2693      count  -= avail;
2694      unread += avail;
2695      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2696     }
2697   }
2698  return unread;
2699 }
2700
2701 SSize_t
2702 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2703 {
2704  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2705  const STDCHAR *buf = (const STDCHAR *) vbuf;
2706  Size_t written = 0;
2707  if (!b->buf)
2708   PerlIO_get_base(f);
2709  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2710   return 0;
2711  while (count > 0)
2712   {
2713    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2714    if ((SSize_t) count < avail)
2715     avail = count;
2716    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2717    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2718     {
2719      while (avail > 0)
2720       {
2721        int ch = *buf++;
2722        *(b->ptr)++ = ch;
2723        count--;
2724        avail--;
2725        written++;
2726        if (ch == '\n')
2727         {
2728          PerlIO_flush(f);
2729          break;
2730         }
2731       }
2732     }
2733    else
2734     {
2735      if (avail)
2736       {
2737        Copy(buf,b->ptr,avail,STDCHAR);
2738        count   -= avail;
2739        buf     += avail;
2740        written += avail;
2741        b->ptr  += avail;
2742       }
2743     }
2744    if (b->ptr >= (b->buf + b->bufsiz))
2745     PerlIO_flush(f);
2746   }
2747  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2748   PerlIO_flush(f);
2749  return written;
2750 }
2751
2752 IV
2753 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2754 {
2755  IV code;
2756  if ((code = PerlIO_flush(f)) == 0)
2757   {
2758    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2759    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2760    code = PerlIO_seek(PerlIONext(f),offset,whence);
2761    if (code == 0)
2762     {
2763      b->posn = PerlIO_tell(PerlIONext(f));
2764     }
2765   }
2766  return code;
2767 }
2768
2769 Off_t
2770 PerlIOBuf_tell(PerlIO *f)
2771 {
2772  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2773  Off_t posn = b->posn;
2774  if (b->buf)
2775   posn += (b->ptr - b->buf);
2776  return posn;
2777 }
2778
2779 IV
2780 PerlIOBuf_close(PerlIO *f)
2781 {
2782  IV code = PerlIOBase_close(f);
2783  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2784  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2785   {
2786    PerlMemShared_free(b->buf);
2787   }
2788  b->buf = NULL;
2789  b->ptr = b->end = b->buf;
2790  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2791  return code;
2792 }
2793
2794 STDCHAR *
2795 PerlIOBuf_get_ptr(PerlIO *f)
2796 {
2797  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2798  if (!b->buf)
2799   PerlIO_get_base(f);
2800  return b->ptr;
2801 }
2802
2803 SSize_t
2804 PerlIOBuf_get_cnt(PerlIO *f)
2805 {
2806  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2807  if (!b->buf)
2808   PerlIO_get_base(f);
2809  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2810   return (b->end - b->ptr);
2811  return 0;
2812 }
2813
2814 STDCHAR *
2815 PerlIOBuf_get_base(PerlIO *f)
2816 {
2817  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2818  if (!b->buf)
2819   {
2820    if (!b->bufsiz)
2821     b->bufsiz = 4096;
2822    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2823    if (!b->buf)
2824     {
2825      b->buf = (STDCHAR *)&b->oneword;
2826      b->bufsiz = sizeof(b->oneword);
2827     }
2828    b->ptr = b->buf;
2829    b->end = b->ptr;
2830   }
2831  return b->buf;
2832 }
2833
2834 Size_t
2835 PerlIOBuf_bufsiz(PerlIO *f)
2836 {
2837  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2838  if (!b->buf)
2839   PerlIO_get_base(f);
2840  return (b->end - b->buf);
2841 }
2842
2843 void
2844 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2845 {
2846  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2847  if (!b->buf)
2848   PerlIO_get_base(f);
2849  b->ptr = ptr;
2850  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2851   {
2852    dTHX;
2853    assert(PerlIO_get_cnt(f) == cnt);
2854    assert(b->ptr >= b->buf);
2855   }
2856  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2857 }
2858
2859 PerlIO_funcs PerlIO_perlio = {
2860  "perlio",
2861  sizeof(PerlIOBuf),
2862  PERLIO_K_BUFFERED,
2863  PerlIOBuf_pushed,
2864  PerlIOBase_noop_ok,
2865  PerlIOBuf_open,
2866  NULL,
2867  PerlIOBase_fileno,
2868  PerlIOBuf_read,
2869  PerlIOBuf_unread,
2870  PerlIOBuf_write,
2871  PerlIOBuf_seek,
2872  PerlIOBuf_tell,
2873  PerlIOBuf_close,
2874  PerlIOBuf_flush,
2875  PerlIOBuf_fill,
2876  PerlIOBase_eof,
2877  PerlIOBase_error,
2878  PerlIOBase_clearerr,
2879  PerlIOBase_setlinebuf,
2880  PerlIOBuf_get_base,
2881  PerlIOBuf_bufsiz,
2882  PerlIOBuf_get_ptr,
2883  PerlIOBuf_get_cnt,
2884  PerlIOBuf_set_ptrcnt,
2885 };
2886
2887 /*--------------------------------------------------------------------------------------*/
2888 /* Temp layer to hold unread chars when cannot do it any other way */
2889
2890 IV
2891 PerlIOPending_fill(PerlIO *f)
2892 {
2893  /* Should never happen */
2894  PerlIO_flush(f);
2895  return 0;
2896 }
2897
2898 IV
2899 PerlIOPending_close(PerlIO *f)
2900 {
2901  /* A tad tricky - flush pops us, then we close new top */
2902  PerlIO_flush(f);
2903  return PerlIO_close(f);
2904 }
2905
2906 IV
2907 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2908 {
2909  /* A tad tricky - flush pops us, then we seek new top */
2910  PerlIO_flush(f);
2911  return PerlIO_seek(f,offset,whence);
2912 }
2913
2914
2915 IV
2916 PerlIOPending_flush(PerlIO *f)
2917 {
2918  dTHX;
2919  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2920  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2921   {
2922    PerlMemShared_free(b->buf);
2923    b->buf = NULL;
2924   }
2925  PerlIO_pop(aTHX_ f);
2926  return 0;
2927 }
2928
2929 void
2930 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2931 {
2932  if (cnt <= 0)
2933   {
2934    PerlIO_flush(f);
2935   }
2936  else
2937   {
2938    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2939   }
2940 }
2941
2942 IV
2943 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2944 {
2945  IV code    = PerlIOBase_pushed(f,mode,arg);
2946  PerlIOl *l = PerlIOBase(f);
2947  /* Our PerlIO_fast_gets must match what we are pushed on,
2948     or sv_gets() etc. get muddled when it changes mid-string
2949     when we auto-pop.
2950   */
2951  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2952               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2953  return code;
2954 }
2955
2956 SSize_t
2957 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2958 {
2959  SSize_t avail = PerlIO_get_cnt(f);
2960  SSize_t got   = 0;
2961  if (count < avail)
2962   avail = count;
2963  if (avail > 0)
2964   got = PerlIOBuf_read(f,vbuf,avail);
2965  if (got >= 0 && got < count)
2966   {
2967    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2968    if (more >= 0 || got == 0)
2969     got += more;
2970   }
2971  return got;
2972 }
2973
2974 PerlIO_funcs PerlIO_pending = {
2975  "pending",
2976  sizeof(PerlIOBuf),
2977  PERLIO_K_BUFFERED,
2978  PerlIOPending_pushed,
2979  PerlIOBase_noop_ok,
2980  NULL,
2981  NULL,
2982  PerlIOBase_fileno,
2983  PerlIOPending_read,
2984  PerlIOBuf_unread,
2985  PerlIOBuf_write,
2986  PerlIOPending_seek,
2987  PerlIOBuf_tell,
2988  PerlIOPending_close,
2989  PerlIOPending_flush,
2990  PerlIOPending_fill,
2991  PerlIOBase_eof,
2992  PerlIOBase_error,
2993  PerlIOBase_clearerr,
2994  PerlIOBase_setlinebuf,
2995  PerlIOBuf_get_base,
2996  PerlIOBuf_bufsiz,
2997  PerlIOBuf_get_ptr,
2998  PerlIOBuf_get_cnt,
2999  PerlIOPending_set_ptrcnt,
3000 };
3001
3002
3003
3004 /*--------------------------------------------------------------------------------------*/
3005 /* crlf - translation
3006    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3007    to hand back a line at a time and keeping a record of which nl we "lied" about.
3008    On write translate "\n" to CR,LF
3009  */
3010
3011 typedef struct
3012 {
3013  PerlIOBuf      base;         /* PerlIOBuf stuff */
3014  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
3015 } PerlIOCrlf;
3016
3017 IV
3018 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3019 {
3020  IV code;
3021  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3022  code = PerlIOBuf_pushed(f,mode,arg);
3023 #if 0
3024  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3025               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3026               PerlIOBase(f)->flags);
3027 #endif
3028  return code;
3029 }
3030
3031
3032 SSize_t
3033 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3034 {
3035  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3036  if (c->nl)
3037   {
3038    *(c->nl) = 0xd;
3039    c->nl = NULL;
3040   }
3041  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3042   return PerlIOBuf_unread(f,vbuf,count);
3043  else
3044   {
3045    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3046    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3047    SSize_t unread = 0;
3048    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3049     PerlIO_flush(f);
3050    if (!b->buf)
3051     PerlIO_get_base(f);
3052    if (b->buf)
3053     {
3054      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3055       {
3056        b->end = b->ptr = b->buf + b->bufsiz;
3057        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3058        b->posn -= b->bufsiz;
3059       }
3060      while (count > 0 && b->ptr > b->buf)
3061       {
3062        int ch = *--buf;
3063        if (ch == '\n')
3064         {
3065          if (b->ptr - 2 >= b->buf)
3066           {
3067            *--(b->ptr) = 0xa;
3068            *--(b->ptr) = 0xd;
3069            unread++;
3070            count--;
3071           }
3072          else
3073           {
3074            buf++;
3075            break;
3076           }
3077         }
3078        else
3079         {
3080          *--(b->ptr) = ch;
3081          unread++;
3082          count--;
3083         }
3084       }
3085     }
3086    return unread;
3087   }
3088 }
3089
3090 SSize_t
3091 PerlIOCrlf_get_cnt(PerlIO *f)
3092 {
3093  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3094  if (!b->buf)
3095   PerlIO_get_base(f);
3096  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3097   {
3098    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3099    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3100     {
3101      STDCHAR *nl   = b->ptr;
3102     scan:
3103      while (nl < b->end && *nl != 0xd)
3104       nl++;
3105      if (nl < b->end && *nl == 0xd)
3106       {
3107      test:
3108        if (nl+1 < b->end)
3109         {
3110          if (nl[1] == 0xa)
3111           {
3112            *nl   = '\n';
3113            c->nl = nl;
3114           }
3115          else
3116           {
3117            /* Not CR,LF but just CR */
3118            nl++;
3119            goto scan;
3120           }
3121         }
3122        else
3123         {
3124          /* Blast - found CR as last char in buffer */
3125          if (b->ptr < nl)
3126           {
3127            /* They may not care, defer work as long as possible */
3128            return (nl - b->ptr);
3129           }
3130          else
3131           {
3132            int code;
3133            b->ptr++;               /* say we have read it as far as flush() is concerned */
3134            b->buf++;               /* Leave space an front of buffer */
3135            b->bufsiz--;            /* Buffer is thus smaller */
3136            code = PerlIO_fill(f);  /* Fetch some more */
3137            b->bufsiz++;            /* Restore size for next time */
3138            b->buf--;               /* Point at space */
3139            b->ptr = nl = b->buf;   /* Which is what we hand off */
3140            b->posn--;              /* Buffer starts here */
3141            *nl = 0xd;              /* Fill in the CR */
3142            if (code == 0)
3143             goto test;             /* fill() call worked */
3144            /* CR at EOF - just fall through */
3145           }
3146         }
3147       }
3148     }
3149    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3150   }
3151  return 0;
3152 }
3153
3154 void
3155 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3156 {
3157  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3158  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3159  IV flags = PerlIOBase(f)->flags;
3160  if (!b->buf)
3161   PerlIO_get_base(f);
3162  if (!ptr)
3163   {
3164    if (c->nl)
3165     ptr = c->nl+1;
3166    else
3167     {
3168      ptr = b->end;
3169      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3170       ptr--;
3171     }
3172    ptr -= cnt;
3173   }
3174  else
3175   {
3176    /* Test code - delete when it works ... */
3177    STDCHAR *chk;
3178    if (c->nl)
3179     chk = c->nl+1;
3180    else
3181     {
3182      chk = b->end;
3183      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3184       chk--;
3185     }
3186    chk -= cnt;
3187
3188    if (ptr != chk)
3189     {
3190      dTHX;
3191      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3192                 ptr, chk, flags, c->nl, b->end, cnt);
3193     }
3194   }
3195  if (c->nl)
3196   {
3197    if (ptr > c->nl)
3198     {
3199      /* They have taken what we lied about */
3200      *(c->nl) = 0xd;
3201      c->nl = NULL;
3202      ptr++;
3203     }
3204   }
3205  b->ptr = ptr;
3206  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3207 }
3208
3209 SSize_t
3210 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3211 {
3212  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3213   return PerlIOBuf_write(f,vbuf,count);
3214  else
3215   {
3216    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3217    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3218    const STDCHAR *ebuf = buf+count;
3219    if (!b->buf)
3220     PerlIO_get_base(f);
3221    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3222     return 0;
3223    while (buf < ebuf)
3224     {
3225      STDCHAR *eptr = b->buf+b->bufsiz;
3226      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3227      while (buf < ebuf && b->ptr < eptr)
3228       {
3229        if (*buf == '\n')
3230         {
3231          if ((b->ptr + 2) > eptr)
3232           {
3233            /* Not room for both */
3234            PerlIO_flush(f);
3235            break;
3236           }
3237          else
3238           {
3239            *(b->ptr)++ = 0xd; /* CR */
3240            *(b->ptr)++ = 0xa; /* LF */
3241            buf++;
3242            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3243             {
3244              PerlIO_flush(f);
3245              break;
3246             }
3247           }
3248         }
3249        else
3250         {
3251          int ch = *buf++;
3252          *(b->ptr)++ = ch;
3253         }
3254        if (b->ptr >= eptr)
3255         {
3256          PerlIO_flush(f);
3257          break;
3258         }
3259       }
3260     }
3261    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3262     PerlIO_flush(f);
3263    return (buf - (STDCHAR *) vbuf);
3264   }
3265 }
3266
3267 IV
3268 PerlIOCrlf_flush(PerlIO *f)
3269 {
3270  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3271  if (c->nl)
3272   {
3273    *(c->nl) = 0xd;
3274    c->nl = NULL;
3275   }
3276  return PerlIOBuf_flush(f);
3277 }
3278
3279 PerlIO_funcs PerlIO_crlf = {
3280  "crlf",
3281  sizeof(PerlIOCrlf),
3282  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3283  PerlIOCrlf_pushed,
3284  PerlIOBase_noop_ok,   /* popped */
3285  PerlIOBuf_open,
3286  NULL,
3287  PerlIOBase_fileno,
3288  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3289  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3290  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3291  PerlIOBuf_seek,
3292  PerlIOBuf_tell,
3293  PerlIOBuf_close,
3294  PerlIOCrlf_flush,
3295  PerlIOBuf_fill,
3296  PerlIOBase_eof,
3297  PerlIOBase_error,
3298  PerlIOBase_clearerr,
3299  PerlIOBase_setlinebuf,
3300  PerlIOBuf_get_base,
3301  PerlIOBuf_bufsiz,
3302  PerlIOBuf_get_ptr,
3303  PerlIOCrlf_get_cnt,
3304  PerlIOCrlf_set_ptrcnt,
3305 };
3306
3307 #ifdef HAS_MMAP
3308 /*--------------------------------------------------------------------------------------*/
3309 /* mmap as "buffer" layer */
3310
3311 typedef struct
3312 {
3313  PerlIOBuf      base;         /* PerlIOBuf stuff */
3314  Mmap_t         mptr;        /* Mapped address */
3315  Size_t         len;          /* mapped length */
3316  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3317 } PerlIOMmap;
3318
3319 static size_t page_size = 0;
3320
3321 IV
3322 PerlIOMmap_map(PerlIO *f)
3323 {
3324  dTHX;
3325  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3326  IV flags = PerlIOBase(f)->flags;
3327  IV code  = 0;
3328  if (m->len)
3329   abort();
3330  if (flags & PERLIO_F_CANREAD)
3331   {
3332    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3333    int fd   = PerlIO_fileno(f);
3334    struct stat st;
3335    code = fstat(fd,&st);
3336    if (code == 0 && S_ISREG(st.st_mode))
3337     {
3338      SSize_t len = st.st_size - b->posn;
3339      if (len > 0)
3340       {
3341        Off_t posn;
3342        if (!page_size) {
3343 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3344            {
3345                SETERRNO(0,SS$_NORMAL);
3346 #   ifdef _SC_PAGESIZE
3347                page_size = sysconf(_SC_PAGESIZE);
3348 #   else
3349                page_size = sysconf(_SC_PAGE_SIZE);
3350 #   endif
3351                if ((long)page_size < 0) {
3352                    if (errno) {
3353                        SV *error = ERRSV;
3354                        char *msg;
3355                        STRLEN n_a;
3356                        (void)SvUPGRADE(error, SVt_PV);
3357                        msg = SvPVx(error, n_a);
3358                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3359                    }
3360                    else
3361                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3362                }
3363            }
3364 #else
3365 #   ifdef HAS_GETPAGESIZE
3366         page_size = getpagesize();
3367 #   else
3368 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3369         page_size = PAGESIZE; /* compiletime, bad */
3370 #       endif
3371 #   endif
3372 #endif
3373         if ((IV)page_size <= 0)
3374             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3375        }
3376        if (b->posn < 0)
3377         {
3378          /* This is a hack - should never happen - open should have set it ! */
3379          b->posn = PerlIO_tell(PerlIONext(f));
3380         }
3381        posn = (b->posn / page_size) * page_size;
3382        len  = st.st_size - posn;
3383        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3384        if (m->mptr && m->mptr != (Mmap_t) -1)
3385         {
3386 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3387          madvise(m->mptr, len, MADV_SEQUENTIAL);
3388 #endif
3389 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3390          madvise(m->mptr, len, MADV_WILLNEED);
3391 #endif
3392          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3393          b->end  = ((STDCHAR *)m->mptr) + len;
3394          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3395          b->ptr  = b->buf;
3396          m->len  = len;
3397         }
3398        else
3399         {
3400          b->buf = NULL;
3401         }
3402       }
3403      else
3404       {
3405        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3406        b->buf = NULL;
3407        b->ptr = b->end = b->ptr;
3408        code = -1;
3409       }
3410     }
3411   }
3412  return code;
3413 }
3414
3415 IV
3416 PerlIOMmap_unmap(PerlIO *f)
3417 {
3418  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3419  PerlIOBuf  *b = &m->base;
3420  IV code = 0;
3421  if (m->len)
3422   {
3423    if (b->buf)
3424     {
3425      code = munmap(m->mptr, m->len);
3426      b->buf  = NULL;
3427      m->len  = 0;
3428      m->mptr = NULL;
3429      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3430       code = -1;
3431     }
3432    b->ptr = b->end = b->buf;
3433    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3434   }
3435  return code;
3436 }
3437
3438 STDCHAR *
3439 PerlIOMmap_get_base(PerlIO *f)
3440 {
3441  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3442  PerlIOBuf  *b = &m->base;
3443  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3444   {
3445    /* Already have a readbuffer in progress */
3446    return b->buf;
3447   }
3448  if (b->buf)
3449   {
3450    /* We have a write buffer or flushed PerlIOBuf read buffer */
3451    m->bbuf = b->buf;  /* save it in case we need it again */
3452    b->buf  = NULL;    /* Clear to trigger below */
3453   }
3454  if (!b->buf)
3455   {
3456    PerlIOMmap_map(f);     /* Try and map it */
3457    if (!b->buf)
3458     {
3459      /* Map did not work - recover PerlIOBuf buffer if we have one */
3460      b->buf = m->bbuf;
3461     }
3462   }
3463  b->ptr  = b->end = b->buf;
3464  if (b->buf)
3465   return b->buf;
3466  return PerlIOBuf_get_base(f);
3467 }
3468
3469 SSize_t
3470 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3471 {
3472  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3473  PerlIOBuf  *b = &m->base;
3474  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3475   PerlIO_flush(f);
3476  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3477   {
3478    b->ptr -= count;
3479    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3480    return count;
3481   }
3482  if (m->len)
3483   {
3484    /* Loose the unwritable mapped buffer */
3485    PerlIO_flush(f);
3486    /* If flush took the "buffer" see if we have one from before */
3487    if (!b->buf && m->bbuf)
3488     b->buf = m->bbuf;
3489    if (!b->buf)
3490     {
3491      PerlIOBuf_get_base(f);
3492      m->bbuf = b->buf;
3493     }
3494   }
3495 return PerlIOBuf_unread(f,vbuf,count);
3496 }
3497
3498 SSize_t
3499 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3500 {
3501  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3502  PerlIOBuf  *b = &m->base;
3503  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3504   {
3505    /* No, or wrong sort of, buffer */
3506    if (m->len)
3507     {
3508      if (PerlIOMmap_unmap(f) != 0)
3509       return 0;
3510     }
3511    /* If unmap took the "buffer" see if we have one from before */
3512    if (!b->buf && m->bbuf)
3513     b->buf = m->bbuf;
3514    if (!b->buf)
3515     {
3516      PerlIOBuf_get_base(f);
3517      m->bbuf = b->buf;
3518     }
3519   }
3520  return PerlIOBuf_write(f,vbuf,count);
3521 }
3522
3523 IV
3524 PerlIOMmap_flush(PerlIO *f)
3525 {
3526  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3527  PerlIOBuf  *b = &m->base;
3528  IV code = PerlIOBuf_flush(f);
3529  /* Now we are "synced" at PerlIOBuf level */
3530  if (b->buf)
3531   {
3532    if (m->len)
3533     {
3534      /* Unmap the buffer */
3535      if (PerlIOMmap_unmap(f) != 0)
3536       code = -1;
3537     }
3538    else
3539     {
3540      /* We seem to have a PerlIOBuf buffer which was not mapped
3541       * remember it in case we need one later
3542       */
3543      m->bbuf = b->buf;
3544     }
3545   }
3546  return code;
3547 }
3548
3549 IV
3550 PerlIOMmap_fill(PerlIO *f)
3551 {
3552  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3553  IV code = PerlIO_flush(f);
3554  if (code == 0 && !b->buf)
3555   {
3556    code = PerlIOMmap_map(f);
3557   }
3558  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3559   {
3560    code = PerlIOBuf_fill(f);
3561   }
3562  return code;
3563 }
3564
3565 IV
3566 PerlIOMmap_close(PerlIO *f)
3567 {
3568  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3569  PerlIOBuf  *b = &m->base;
3570  IV code = PerlIO_flush(f);
3571  if (m->bbuf)
3572   {
3573    b->buf  = m->bbuf;
3574    m->bbuf = NULL;
3575    b->ptr  = b->end = b->buf;
3576   }
3577  if (PerlIOBuf_close(f) != 0)
3578   code = -1;
3579  return code;
3580 }
3581
3582
3583 PerlIO_funcs PerlIO_mmap = {
3584  "mmap",
3585  sizeof(PerlIOMmap),
3586  PERLIO_K_BUFFERED,
3587  PerlIOBuf_pushed,
3588  PerlIOBase_noop_ok,
3589  PerlIOBuf_open,
3590  NULL,
3591  PerlIOBase_fileno,
3592  PerlIOBuf_read,
3593  PerlIOMmap_unread,
3594  PerlIOMmap_write,
3595  PerlIOBuf_seek,
3596  PerlIOBuf_tell,
3597  PerlIOBuf_close,
3598  PerlIOMmap_flush,
3599  PerlIOMmap_fill,
3600  PerlIOBase_eof,
3601  PerlIOBase_error,
3602  PerlIOBase_clearerr,
3603  PerlIOBase_setlinebuf,
3604  PerlIOMmap_get_base,
3605  PerlIOBuf_bufsiz,
3606  PerlIOBuf_get_ptr,
3607  PerlIOBuf_get_cnt,
3608  PerlIOBuf_set_ptrcnt,
3609 };
3610
3611 #endif /* HAS_MMAP */
3612
3613 void
3614 PerlIO_init(void)
3615 {
3616  dTHX;
3617 #ifndef WIN32
3618  call_atexit(PerlIO_cleanup_layers, NULL);
3619 #endif
3620  if (!_perlio)
3621   {
3622 #ifndef WIN32
3623    atexit(&PerlIO_cleanup);
3624 #endif
3625   }
3626 }
3627
3628 #undef PerlIO_stdin
3629 PerlIO *
3630 PerlIO_stdin(void)
3631 {
3632  if (!_perlio)
3633   {
3634    dTHX;
3635    PerlIO_stdstreams(aTHX);
3636   }
3637  return &_perlio[1];
3638 }
3639
3640 #undef PerlIO_stdout
3641 PerlIO *
3642 PerlIO_stdout(void)
3643 {
3644  if (!_perlio)
3645   {
3646    dTHX;
3647    PerlIO_stdstreams(aTHX);
3648   }
3649  return &_perlio[2];
3650 }
3651
3652 #undef PerlIO_stderr
3653 PerlIO *
3654 PerlIO_stderr(void)
3655 {
3656  if (!_perlio)
3657   {
3658    dTHX;
3659    PerlIO_stdstreams(aTHX);
3660   }
3661  return &_perlio[3];
3662 }
3663
3664 /*--------------------------------------------------------------------------------------*/
3665
3666 #undef PerlIO_getname
3667 char *
3668 PerlIO_getname(PerlIO *f, char *buf)
3669 {
3670  dTHX;
3671  char *name = NULL;
3672 #ifdef VMS
3673  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3674  if (stdio) name = fgetname(stdio, buf);
3675 #else
3676  Perl_croak(aTHX_ "Don't know how to get file name");
3677 #endif
3678  return name;
3679 }
3680
3681
3682 /*--------------------------------------------------------------------------------------*/
3683 /* Functions which can be called on any kind of PerlIO implemented
3684    in terms of above
3685 */
3686
3687 #undef PerlIO_getc
3688 int
3689 PerlIO_getc(PerlIO *f)
3690 {
3691  STDCHAR buf[1];
3692  SSize_t count = PerlIO_read(f,buf,1);
3693  if (count == 1)
3694   {
3695    return (unsigned char) buf[0];
3696   }
3697  return EOF;
3698 }
3699
3700 #undef PerlIO_ungetc
3701 int
3702 PerlIO_ungetc(PerlIO *f, int ch)
3703 {
3704  if (ch != EOF)
3705   {
3706    STDCHAR buf = ch;
3707    if (PerlIO_unread(f,&buf,1) == 1)
3708     return ch;
3709   }
3710  return EOF;
3711 }
3712
3713 #undef PerlIO_putc
3714 int
3715 PerlIO_putc(PerlIO *f, int ch)
3716 {
3717  STDCHAR buf = ch;
3718  return PerlIO_write(f,&buf,1);
3719 }
3720
3721 #undef PerlIO_puts
3722 int
3723 PerlIO_puts(PerlIO *f, const char *s)
3724 {
3725  STRLEN len = strlen(s);
3726  return PerlIO_write(f,s,len);
3727 }
3728
3729 #undef PerlIO_rewind
3730 void
3731 PerlIO_rewind(PerlIO *f)
3732 {
3733  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3734  PerlIO_clearerr(f);
3735 }
3736
3737 #undef PerlIO_vprintf
3738 int
3739 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3740 {
3741  dTHX;
3742  SV *sv = newSVpvn("",0);
3743  char *s;
3744  STRLEN len;
3745  SSize_t wrote;
3746 #ifdef NEED_VA_COPY
3747  va_list apc;
3748  Perl_va_copy(ap, apc);
3749  sv_vcatpvf(sv, fmt, &apc);
3750 #else
3751  sv_vcatpvf(sv, fmt, &ap);
3752 #endif
3753  s = SvPV(sv,len);
3754  wrote = PerlIO_write(f,s,len);
3755  SvREFCNT_dec(sv);
3756  return wrote;
3757 }
3758
3759 #undef PerlIO_printf
3760 int
3761 PerlIO_printf(PerlIO *f,const char *fmt,...)
3762 {
3763  va_list ap;
3764  int result;
3765  va_start(ap,fmt);
3766  result = PerlIO_vprintf(f,fmt,ap);
3767  va_end(ap);
3768  return result;
3769 }
3770
3771 #undef PerlIO_stdoutf
3772 int
3773 PerlIO_stdoutf(const char *fmt,...)
3774 {
3775  va_list ap;
3776  int result;
3777  va_start(ap,fmt);
3778  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3779  va_end(ap);
3780  return result;
3781 }
3782
3783 #undef PerlIO_tmpfile
3784 PerlIO *
3785 PerlIO_tmpfile(void)
3786 {
3787  /* I have no idea how portable mkstemp() is ... */
3788 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3789  dTHX;
3790  PerlIO *f = NULL;
3791  FILE *stdio = PerlSIO_tmpfile();
3792  if (stdio)
3793   {
3794    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3795    s->stdio  = stdio;
3796   }
3797  return f;
3798 #else
3799  dTHX;
3800  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3801  int fd = mkstemp(SvPVX(sv));
3802  PerlIO *f = NULL;
3803  if (fd >= 0)
3804   {
3805    f = PerlIO_fdopen(fd,"w+");
3806    if (f)
3807     {
3808      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3809     }
3810    PerlLIO_unlink(SvPVX(sv));
3811    SvREFCNT_dec(sv);
3812   }
3813  return f;
3814 #endif
3815 }
3816
3817 #undef HAS_FSETPOS
3818 #undef HAS_FGETPOS
3819
3820 #endif /* USE_SFIO */
3821 #endif /* PERLIO_IS_STDIO */
3822
3823 /*======================================================================================*/
3824 /* Now some functions in terms of above which may be needed even if
3825    we are not in true PerlIO mode
3826  */
3827
3828 #ifndef HAS_FSETPOS
3829 #undef PerlIO_setpos
3830 int
3831 PerlIO_setpos(PerlIO *f, SV *pos)
3832 {
3833  dTHX;
3834  if (SvOK(pos))
3835   {
3836    STRLEN len;
3837    Off_t *posn = (Off_t *) SvPV(pos,len);
3838    if (f && len == sizeof(Off_t))
3839     return PerlIO_seek(f,*posn,SEEK_SET);
3840   }
3841  SETERRNO(EINVAL,SS$_IVCHAN);
3842  return -1;
3843 }
3844 #else
3845 #undef PerlIO_setpos
3846 int
3847 PerlIO_setpos(PerlIO *f, SV *pos)
3848 {
3849  dTHX;
3850  if (SvOK(pos))
3851   {
3852    STRLEN len;
3853    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3854    if (f && len == sizeof(Fpos_t))
3855     {
3856 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3857      return fsetpos64(f, fpos);
3858 #else
3859      return fsetpos(f, fpos);
3860 #endif
3861     }
3862   }
3863  SETERRNO(EINVAL,SS$_IVCHAN);
3864  return -1;
3865 }
3866 #endif
3867
3868 #ifndef HAS_FGETPOS
3869 #undef PerlIO_getpos
3870 int
3871 PerlIO_getpos(PerlIO *f, SV *pos)
3872 {
3873  dTHX;
3874  Off_t posn = PerlIO_tell(f);
3875  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3876  return (posn == (Off_t)-1) ? -1 : 0;
3877 }
3878 #else
3879 #undef PerlIO_getpos
3880 int
3881 PerlIO_getpos(PerlIO *f, SV *pos)
3882 {
3883  dTHX;
3884  Fpos_t fpos;
3885  int code;
3886 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3887  code = fgetpos64(f, &fpos);
3888 #else
3889  code = fgetpos(f, &fpos);
3890 #endif
3891  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3892  return code;
3893 }
3894 #endif
3895
3896 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3897
3898 int
3899 vprintf(char *pat, char *args)
3900 {
3901     _doprnt(pat, args, stdout);
3902     return 0;           /* wrong, but perl doesn't use the return value */
3903 }
3904
3905 int
3906 vfprintf(FILE *fd, char *pat, char *args)
3907 {
3908     _doprnt(pat, args, fd);
3909     return 0;           /* wrong, but perl doesn't use the return value */
3910 }
3911
3912 #endif
3913
3914 #ifndef PerlIO_vsprintf
3915 int
3916 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3917 {
3918  int val = vsprintf(s, fmt, ap);
3919  if (n >= 0)
3920   {
3921    if (strlen(s) >= (STRLEN)n)
3922     {
3923      dTHX;
3924      (void)PerlIO_puts(Perl_error_log,
3925                        "panic: sprintf overflow - memory corrupted!\n");
3926      my_exit(1);
3927     }
3928   }
3929  return val;
3930 }
3931 #endif
3932
3933 #ifndef PerlIO_sprintf
3934 int
3935 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3936 {
3937  va_list ap;
3938  int result;
3939  va_start(ap,fmt);
3940  result = PerlIO_vsprintf(s, n, fmt, ap);
3941  va_end(ap);
3942  return result;
3943 }
3944 #endif
3945
3946
3947
3948
3949