perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2000, 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 #define VOIDUSED 1
  11 #ifdef PERL_MICRO
  12 #   include "uconfig.h"
  13 #else
  14 #   include "config.h"
  15 #endif
  16
  17 #define PERLIO_NOT_STDIO 0
  18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  19 /* #define PerlIO FILE */
  20 #endif
  21 /*
  22  * This file provides those parts of PerlIO abstraction
  23  * which are not #defined in perlio.h.
  24  * Which these are depends on various Configure #ifdef's
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_PERLIO_C
  29 #include "perl.h"
  30
  31 #ifndef PERLIO_LAYERS
  32 int
  33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  34 {
  35  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  36   {
  37    return 0;
  38   }
  39  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
  40  /* NOTREACHED */
  41  return -1;
  42 }
  43
  44 int
  45 perlsio_binmode(FILE *fp, int iotype, int mode)
  46 {
  47 /* This used to be contents of do_binmode in doio.c */
  48 #ifdef DOSISH
  49 #  if defined(atarist) || defined(__MINT__)
  50     if (!fflush(fp)) {
  51         if (mode & O_BINARY)
  52             ((FILE*)fp)->_flag |= _IOBIN;
  53         else
  54             ((FILE*)fp)->_flag &= ~ _IOBIN;
  55         return 1;
  56     }
  57     return 0;
  58 #  else
  59     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  60 #    if defined(WIN32) && defined(__BORLANDC__)
  61         /* The translation mode of the stream is maintained independent
  62          * of the translation mode of the fd in the Borland RTL (heavy
  63          * digging through their runtime sources reveal).  User has to
  64          * set the mode explicitly for the stream (though they don't
  65          * document this anywhere). GSAR 97-5-24
  66          */
  67         fseek(fp,0L,0);
  68         if (mode & O_BINARY)
  69             fp->flags |= _F_BIN;
  70         else
  71             fp->flags &= ~ _F_BIN;
  72 #    endif
  73         return 1;
  74     }
  75     else
  76         return 0;
  77 #  endif
  78 #else
  79 #  if defined(USEMYBINMODE)
  80     if (my_binmode(fp, iotype, mode) != FALSE)
  81         return 1;
  82     else
  83         return 0;
  84 #  else
  85     return 1;
  86 #  endif
  87 #endif
  88 }
  89
  90 int
  91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
  92 {
  93  return perlsio_binmode(fp,iotype,mode);
  94 }
  95
  96 #endif
  97
  98 #if !defined(PERL_IMPLICIT_SYS)
  99
 100 #ifdef PERLIO_IS_STDIO
 101
 102 void
 103 PerlIO_init(void)
 104 {
 105  /* Does nothing (yet) except force this file to be included
 106     in perl binary. That allows this file to force inclusion
 107     of other functions that may be required by loadable
 108     extensions e.g. for FileHandle::tmpfile
 109  */
 110 }
 111
 112 #undef PerlIO_tmpfile
 113 PerlIO *
 114 PerlIO_tmpfile(void)
 115 {
 116  return tmpfile();
 117 }
 118
 119 #else /* PERLIO_IS_STDIO */
 120
 121 #ifdef USE_SFIO
 122
 123 #undef HAS_FSETPOS
 124 #undef HAS_FGETPOS
 125
 126 /* This section is just to make sure these functions
 127    get pulled in from libsfio.a
 128 */
 129
 130 #undef PerlIO_tmpfile
 131 PerlIO *
 132 PerlIO_tmpfile(void)
 133 {
 134  return sftmp(0);
 135 }
 136
 137 void
 138 PerlIO_init(void)
 139 {
 140  /* Force this file to be included  in perl binary. Which allows
 141   *  this file to force inclusion  of other functions that may be
 142   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 143   */
 144
 145  /* Hack
 146   * sfio does its own 'autoflush' on stdout in common cases.
 147   * Flush results in a lot of lseek()s to regular files and
 148   * lot of small writes to pipes.
 149   */
 150  sfset(sfstdout,SF_SHARE,0);
 151 }
 152
 153 #else /* USE_SFIO */
 154 /*======================================================================================*/
 155 /* Implement all the PerlIO interface ourselves.
 156  */
 157
 158 #include "perliol.h"
 159
 160 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 161 #ifdef I_UNISTD
 162 #include <unistd.h>
 163 #endif
 164 #ifdef HAS_MMAP
 165 #include <sys/mman.h>
 166 #endif
 167
 168 #include "XSUB.h"
 169
 170 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 171
 172 void
 173 PerlIO_debug(const char *fmt,...)
 174 {
 175  static int dbg = 0;
 176  va_list ap;
 177  va_start(ap,fmt);
 178  if (!dbg)
 179   {
 180    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 181    if (s && *s)
 182     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 183    else
 184     dbg = -1;
 185   }
 186  if (dbg > 0)
 187   {
 188    dTHX;
 189    SV *sv = newSVpvn("",0);
 190    char *s;
 191    STRLEN len;
 192    s = CopFILE(PL_curcop);
 193    if (!s)
 194     s = "(none)";
 195    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 196    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 197
 198    s = SvPV(sv,len);
 199    PerlLIO_write(dbg,s,len);
 200    SvREFCNT_dec(sv);
 201   }
 202  va_end(ap);
 203 }
 204
 205 /*--------------------------------------------------------------------------------------*/
 206
 207 /* Inner level routines */
 208
 209 /* Table of pointers to the PerlIO structs (malloc'ed) */
 210 PerlIO *_perlio      = NULL;
 211 #define PERLIO_TABLE_SIZE 64
 212
 213 PerlIO *
 214 PerlIO_allocate(void)
 215 {
 216  /* Find a free slot in the table, allocating new table as necessary */
 217  PerlIO **last = &_perlio;
 218  PerlIO *f;
 219  while ((f = *last))
 220   {
 221    int i;
 222    last = (PerlIO **)(f);
 223    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 224     {
 225      if (!*++f)
 226       {
 227        return f;
 228       }
 229     }
 230   }
 231  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 232  if (!f)
 233   return NULL;
 234  *last = f;
 235  return f+1;
 236 }
 237
 238 void
 239 PerlIO_cleantable(PerlIO **tablep)
 240 {
 241  PerlIO *table = *tablep;
 242  if (table)
 243   {
 244    int i;
 245    PerlIO_cleantable((PerlIO **) &(table[0]));
 246    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 247     {
 248      PerlIO *f = table+i;
 249      if (*f)
 250       {
 251        PerlIO_close(f);
 252       }
 253     }
 254    Safefree(table);
 255    *tablep = NULL;
 256   }
 257 }
 258
 259 HV *PerlIO_layer_hv;
 260 AV *PerlIO_layer_av;
 261
 262 void
 263 PerlIO_cleanup(void)
 264 {
 265  PerlIO_cleantable(&_perlio);
 266 }
 267
 268 void
 269 PerlIO_pop(PerlIO *f)
 270 {
 271  PerlIOl *l = *f;
 272  if (l)
 273   {
 274    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 275    (*l->tab->Popped)(f);
 276    *f = l->next;
 277    Safefree(l);
 278   }
 279 }
 280
 281 /*--------------------------------------------------------------------------------------*/
 282 /* XS Interface for perl code */
 283
 284 XS(XS_perlio_import)
 285 {
 286  dXSARGS;
 287  GV *gv = CvGV(cv);
 288  char *s = GvNAME(gv);
 289  STRLEN l = GvNAMELEN(gv);
 290  PerlIO_debug("%.*s\n",(int) l,s);
 291  XSRETURN_EMPTY;
 292 }
 293
 294 XS(XS_perlio_unimport)
 295 {
 296  dXSARGS;
 297  GV *gv = CvGV(cv);
 298  char *s = GvNAME(gv);
 299  STRLEN l = GvNAMELEN(gv);
 300  PerlIO_debug("%.*s\n",(int) l,s);
 301  XSRETURN_EMPTY;
 302 }
 303
 304 SV *
 305 PerlIO_find_layer(const char *name, STRLEN len)
 306 {
 307  dTHX;
 308  SV **svp;
 309  SV *sv;
 310  if (len <= 0)
 311   len = strlen(name);
 312  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 313  if (svp && (sv = *svp) && SvROK(sv))
 314   return *svp;
 315  return NULL;
 316 }
 317
 318
 319 static int
 320 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 321 {
 322  if (SvROK(sv))
 323   {
 324    IO *io = GvIOn((GV *)SvRV(sv));
 325    PerlIO *ifp = IoIFP(io);
 326    PerlIO *ofp = IoOFP(io);
 327    AV *av = (AV *) mg->mg_obj;
 328    Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
 329   }
 330  return 0;
 331 }
 332
 333 static int
 334 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 335 {
 336  if (SvROK(sv))
 337   {
 338    IO *io = GvIOn((GV *)SvRV(sv));
 339    PerlIO *ifp = IoIFP(io);
 340    PerlIO *ofp = IoOFP(io);
 341    AV *av = (AV *) mg->mg_obj;
 342    Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
 343   }
 344  return 0;
 345 }
 346
 347 static int
 348 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 349 {
 350  Perl_warn(aTHX_ "clear %"SVf,sv);
 351  return 0;
 352 }
 353
 354 static int
 355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 356 {
 357  Perl_warn(aTHX_ "free %"SVf,sv);
 358  return 0;
 359 }
 360
 361 MGVTBL perlio_vtab = {
 362  perlio_mg_get,
 363  perlio_mg_set,
 364  NULL, /* len */
 365  NULL,
 366  perlio_mg_free
 367 };
 368
 369 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 370 {
 371  dXSARGS;
 372  SV *sv    = SvRV(ST(1));
 373  AV *av    = newAV();
 374  MAGIC *mg;
 375  int count = 0;
 376  int i;
 377  sv_magic(sv, (SV *)av, '~', NULL, 0);
 378  SvRMAGICAL_off(sv);
 379  mg = mg_find(sv,'~');
 380  mg->mg_virtual = &perlio_vtab;
 381  mg_magical(sv);
 382  Perl_warn(aTHX_ "attrib %"SVf,sv);
 383  for (i=2; i < items; i++)
 384   {
 385    STRLEN len;
 386    const char *name = SvPV(ST(i),len);
 387    SV *layer  = PerlIO_find_layer(name,len);
 388    if (layer)
 389     {
 390      av_push(av,SvREFCNT_inc(layer));
 391     }
 392    else
 393     {
 394      ST(count) = ST(i);
 395      count++;
 396     }
 397   }
 398  SvREFCNT_dec(av);
 399  XSRETURN(count);
 400 }
 401
 402 void
 403 PerlIO_define_layer(PerlIO_funcs *tab)
 404 {
 405  dTHX;
 406  HV *stash = gv_stashpv("perlio::Layer", TRUE);
 407  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 408  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 409 }
 410
 411 PerlIO_funcs *
 412 PerlIO_default_layer(I32 n)
 413 {
 414  dTHX;
 415  SV **svp;
 416  SV *layer;
 417  PerlIO_funcs *tab = &PerlIO_stdio;
 418  int len;
 419  if (!PerlIO_layer_hv)
 420   {
 421    const char *s  = PerlEnv_getenv("PERLIO");
 422    newXS("perlio::import",XS_perlio_import,__FILE__);
 423    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 424 #if 0
 425    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 426 #endif
 427    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 428    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 429    PerlIO_define_layer(&PerlIO_unix);
 430    PerlIO_define_layer(&PerlIO_perlio);
 431    PerlIO_define_layer(&PerlIO_stdio);
 432    PerlIO_define_layer(&PerlIO_crlf);
 433 #ifdef HAS_MMAP
 434    PerlIO_define_layer(&PerlIO_mmap);
 435 #endif
 436    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 437    if (s)
 438     {
 439      while (*s)
 440       {
 441        while (*s && isSPACE((unsigned char)*s))
 442         s++;
 443        if (*s)
 444         {
 445          const char *e = s;
 446          SV *layer;
 447          while (*e && !isSPACE((unsigned char)*e))
 448           e++;
 449          if (*s == ':')
 450           s++;
 451          layer = PerlIO_find_layer(s,e-s);
 452          if (layer)
 453           {
 454            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 455            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 456           }
 457          else
 458           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 459          s = e;
 460         }
 461       }
 462     }
 463   }
 464  len  = av_len(PerlIO_layer_av);
 465  if (len < 1)
 466   {
 467    if (O_BINARY != O_TEXT)
 468     {
 469      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
 470     }
 471    else
 472     {
 473      if (PerlIO_stdio.Set_ptrcnt)
 474       {
 475        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 476       }
 477      else
 478       {
 479        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 480       }
 481     }
 482    len  = av_len(PerlIO_layer_av);
 483   }
 484  if (n < 0)
 485   n += len+1;
 486  svp = av_fetch(PerlIO_layer_av,n,0);
 487  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 488   {
 489    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 490   }
 491  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 492  return tab;
 493 }
 494
 495 #define PerlIO_default_top() PerlIO_default_layer(-1)
 496 #define PerlIO_default_btm() PerlIO_default_layer(0)
 497
 498 void
 499 PerlIO_stdstreams()
 500 {
 501  if (!_perlio)
 502   {
 503    PerlIO_allocate();
 504    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 505    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 506    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 507   }
 508 }
 509
 510 PerlIO *
 511 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 512 {
 513  PerlIOl *l = NULL;
 514  Newc('L',l,tab->size,char,PerlIOl);
 515  if (l)
 516   {
 517    Zero(l,tab->size,char);
 518    l->next = *f;
 519    l->tab  = tab;
 520    *f      = l;
 521    PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
 522    if ((*l->tab->Pushed)(f,mode) != 0)
 523     {
 524      PerlIO_pop(f);
 525      return NULL;
 526     }
 527   }
 528  return f;
 529 }
 530
 531 int
 532 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 533 {
 534  if (names)
 535   {
 536    const char *s = names;
 537    while (*s)
 538     {
 539      while (isSPACE(*s))
 540       s++;
 541      if (*s == ':')
 542       s++;
 543      if (*s)
 544       {
 545        const char *e = s;
 546        while (*e && *e != ':' && !isSPACE(*e))
 547         e++;
 548        if (e > s)
 549         {
 550          if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
 551           {
 552            /* Pop back to bottom layer */
 553            if (PerlIONext(f))
 554             {
 555              PerlIO_flush(f);
 556              while (PerlIONext(f))
 557               {
 558                PerlIO_pop(f);
 559               }
 560             }
 561           }
 562          else
 563           {
 564            SV *layer = PerlIO_find_layer(s,e-s);
 565            if (layer)
 566             {
 567              PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
 568              if (tab)
 569               {
 570                PerlIO *new = PerlIO_push(f,tab,mode);
 571                if (!new)
 572                 return -1;
 573               }
 574             }
 575            else
 576             Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
 577           }
 578         }
 579        s = e;
 580       }
 581     }
 582   }
 583  return 0;
 584 }
 585
 586
 587
 588 /*--------------------------------------------------------------------------------------*/
 589 /* Given the abstraction above the public API functions */
 590
 591 int
 592 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 593 {
 594  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 595               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 596  if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
 597   {
 598    PerlIO *top = f;
 599    PerlIOl *l;
 600    while (l = *top)
 601     {
 602      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 603       {
 604        PerlIO_flush(top);
 605        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 606        break;
 607       }
 608      top = PerlIONext(top);
 609     }
 610   }
 611  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 612 }
 613
 614 #undef PerlIO__close
 615 int
 616 PerlIO__close(PerlIO *f)
 617 {
 618  return (*PerlIOBase(f)->tab->Close)(f);
 619 }
 620
 621
 622 #undef PerlIO_close
 623 int
 624 PerlIO_close(PerlIO *f)
 625 {
 626  int code = (*PerlIOBase(f)->tab->Close)(f);
 627  while (*f)
 628   {
 629    PerlIO_pop(f);
 630   }
 631  return code;
 632 }
 633
 634 #undef PerlIO_fileno
 635 int
 636 PerlIO_fileno(PerlIO *f)
 637 {
 638  return (*PerlIOBase(f)->tab->Fileno)(f);
 639 }
 640
 641
 642
 643 #undef PerlIO_fdopen
 644 PerlIO *
 645 PerlIO_fdopen(int fd, const char *mode)
 646 {
 647  PerlIO_funcs *tab = PerlIO_default_top();
 648  if (!_perlio)
 649   PerlIO_stdstreams();
 650  return (*tab->Fdopen)(tab,fd,mode);
 651 }
 652
 653 #undef PerlIO_open
 654 PerlIO *
 655 PerlIO_open(const char *path, const char *mode)
 656 {
 657  PerlIO_funcs *tab = PerlIO_default_top();
 658  if (!_perlio)
 659   PerlIO_stdstreams();
 660  return (*tab->Open)(tab,path,mode);
 661 }
 662
 663 #undef PerlIO_reopen
 664 PerlIO *
 665 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 666 {
 667  if (f)
 668   {
 669    PerlIO_flush(f);
 670    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 671     {
 672      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 673       return f;
 674     }
 675    return NULL;
 676   }
 677  else
 678   return PerlIO_open(path,mode);
 679 }
 680
 681 #undef PerlIO_read
 682 SSize_t
 683 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 684 {
 685  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 686 }
 687
 688 #undef PerlIO_unread
 689 SSize_t
 690 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 691 {
 692  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 693 }
 694
 695 #undef PerlIO_write
 696 SSize_t
 697 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 698 {
 699  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 700 }
 701
 702 #undef PerlIO_seek
 703 int
 704 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 705 {
 706  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 707 }
 708
 709 #undef PerlIO_tell
 710 Off_t
 711 PerlIO_tell(PerlIO *f)
 712 {
 713  return (*PerlIOBase(f)->tab->Tell)(f);
 714 }
 715
 716 #undef PerlIO_flush
 717 int
 718 PerlIO_flush(PerlIO *f)
 719 {
 720  if (f)
 721   {
 722    return (*PerlIOBase(f)->tab->Flush)(f);
 723   }
 724  else
 725   {
 726    PerlIO **table = &_perlio;
 727    int code = 0;
 728    while ((f = *table))
 729     {
 730      int i;
 731      table = (PerlIO **)(f++);
 732      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 733       {
 734        if (*f && PerlIO_flush(f) != 0)
 735         code = -1;
 736        f++;
 737       }
 738     }
 739    return code;
 740   }
 741 }
 742
 743 #undef PerlIO_fill
 744 int
 745 PerlIO_fill(PerlIO *f)
 746 {
 747  return (*PerlIOBase(f)->tab->Fill)(f);
 748 }
 749
 750 #undef PerlIO_isutf8
 751 int
 752 PerlIO_isutf8(PerlIO *f)
 753 {
 754  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 755 }
 756
 757 #undef PerlIO_eof
 758 int
 759 PerlIO_eof(PerlIO *f)
 760 {
 761  return (*PerlIOBase(f)->tab->Eof)(f);
 762 }
 763
 764 #undef PerlIO_error
 765 int
 766 PerlIO_error(PerlIO *f)
 767 {
 768  return (*PerlIOBase(f)->tab->Error)(f);
 769 }
 770
 771 #undef PerlIO_clearerr
 772 void
 773 PerlIO_clearerr(PerlIO *f)
 774 {
 775  if (f && *f)
 776   (*PerlIOBase(f)->tab->Clearerr)(f);
 777 }
 778
 779 #undef PerlIO_setlinebuf
 780 void
 781 PerlIO_setlinebuf(PerlIO *f)
 782 {
 783  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 784 }
 785
 786 #undef PerlIO_has_base
 787 int
 788 PerlIO_has_base(PerlIO *f)
 789 {
 790  if (f && *f)
 791   {
 792    return (PerlIOBase(f)->tab->Get_base != NULL);
 793   }
 794  return 0;
 795 }
 796
 797 #undef PerlIO_fast_gets
 798 int
 799 PerlIO_fast_gets(PerlIO *f)
 800 {
 801  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
 802   {
 803    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 804    return (tab->Set_ptrcnt != NULL);
 805   }
 806  return 0;
 807 }
 808
 809 #undef PerlIO_has_cntptr
 810 int
 811 PerlIO_has_cntptr(PerlIO *f)
 812 {
 813  if (f && *f)
 814   {
 815    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 816    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 817   }
 818  return 0;
 819 }
 820
 821 #undef PerlIO_canset_cnt
 822 int
 823 PerlIO_canset_cnt(PerlIO *f)
 824 {
 825  if (f && *f)
 826   {
 827    PerlIOl *l = PerlIOBase(f);
 828    return (l->tab->Set_ptrcnt != NULL);
 829   }
 830  return 0;
 831 }
 832
 833 #undef PerlIO_get_base
 834 STDCHAR *
 835 PerlIO_get_base(PerlIO *f)
 836 {
 837  return (*PerlIOBase(f)->tab->Get_base)(f);
 838 }
 839
 840 #undef PerlIO_get_bufsiz
 841 int
 842 PerlIO_get_bufsiz(PerlIO *f)
 843 {
 844  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 845 }
 846
 847 #undef PerlIO_get_ptr
 848 STDCHAR *
 849 PerlIO_get_ptr(PerlIO *f)
 850 {
 851  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 852  if (tab->Get_ptr == NULL)
 853   return NULL;
 854  return (*tab->Get_ptr)(f);
 855 }
 856
 857 #undef PerlIO_get_cnt
 858 int
 859 PerlIO_get_cnt(PerlIO *f)
 860 {
 861  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 862  if (tab->Get_cnt == NULL)
 863   return 0;
 864  return (*tab->Get_cnt)(f);
 865 }
 866
 867 #undef PerlIO_set_cnt
 868 void
 869 PerlIO_set_cnt(PerlIO *f,int cnt)
 870 {
 871  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 872 }
 873
 874 #undef PerlIO_set_ptrcnt
 875 void
 876 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 877 {
 878  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 879  if (tab->Set_ptrcnt == NULL)
 880   {
 881    dTHX;
 882    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
 883   }
 884  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 885 }
 886
 887 /*--------------------------------------------------------------------------------------*/
 888 /* "Methods" of the "base class" */
 889
 890 IV
 891 PerlIOBase_fileno(PerlIO *f)
 892 {
 893  return PerlIO_fileno(PerlIONext(f));
 894 }
 895
 896 char *
 897 PerlIO_modestr(PerlIO *f,char *buf)
 898 {
 899  char *s = buf;
 900  IV flags = PerlIOBase(f)->flags;
 901  if (flags & PERLIO_F_CANREAD)
 902   *s++ = 'r';
 903  if (flags & PERLIO_F_CANWRITE)
 904   *s++ = 'w';
 905  if (flags & PERLIO_F_CRLF)
 906   *s++ = 't';
 907  else
 908   *s++ = 'b';
 909  *s = '\0';
 910  return buf;
 911 }
 912
 913 IV
 914 PerlIOBase_pushed(PerlIO *f, const char *mode)
 915 {
 916  PerlIOl *l = PerlIOBase(f);
 917  const char *omode = mode;
 918  char temp[8];
 919  PerlIO_funcs *tab = PerlIOBase(f)->tab;
 920  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 921                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 922  if (tab->Set_ptrcnt != NULL)
 923   l->flags |= PERLIO_F_FASTGETS;
 924  if (mode)
 925   {
 926    switch (*mode++)
 927     {
 928      case 'r':
 929       l->flags |= PERLIO_F_CANREAD;
 930       break;
 931      case 'a':
 932       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 933       break;
 934      case 'w':
 935       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 936       break;
 937      default:
 938       errno = EINVAL;
 939       return -1;
 940     }
 941    while (*mode)
 942     {
 943      switch (*mode++)
 944       {
 945        case '+':
 946         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 947         break;
 948        case 'b':
 949         l->flags &= ~PERLIO_F_CRLF;
 950         break;
 951        case 't':
 952         l->flags |= PERLIO_F_CRLF;
 953         break;
 954       default:
 955        errno = EINVAL;
 956        return -1;
 957       }
 958     }
 959   }
 960  else
 961   {
 962    if (l->next)
 963     {
 964      l->flags |= l->next->flags &
 965                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 966     }
 967   }
 968 #if 0
 969  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
 970               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
 971               l->flags,PerlIO_modestr(f,temp));
 972 #endif
 973  return 0;
 974 }
 975
 976 IV
 977 PerlIOBase_popped(PerlIO *f)
 978 {
 979  return 0;
 980 }
 981
 982 extern PerlIO_funcs PerlIO_pending;
 983
 984 SSize_t
 985 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 986 {
 987 #if 0
 988  Off_t old = PerlIO_tell(f);
 989  if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 990   {
 991    Off_t new = PerlIO_tell(f);
 992    return old - new;
 993   }
 994  else
 995   {
 996    return 0;
 997   }
 998 #else
 999  PerlIO_push(f,&PerlIO_pending,"r");
1000  return PerlIOBuf_unread(f,vbuf,count);
1001 #endif
1002 }
1003
1004 IV
1005 PerlIOBase_noop_ok(PerlIO *f)
1006 {
1007  return 0;
1008 }
1009
1010 IV
1011 PerlIOBase_noop_fail(PerlIO *f)
1012 {
1013  return -1;
1014 }
1015
1016 IV
1017 PerlIOBase_close(PerlIO *f)
1018 {
1019  IV code = 0;
1020  PerlIO *n = PerlIONext(f);
1021  if (PerlIO_flush(f) != 0)
1022   code = -1;
1023  if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1024   code = -1;
1025  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1026  return code;
1027 }
1028
1029 IV
1030 PerlIOBase_eof(PerlIO *f)
1031 {
1032  if (f && *f)
1033   {
1034    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1035   }
1036  return 1;
1037 }
1038
1039 IV
1040 PerlIOBase_error(PerlIO *f)
1041 {
1042  if (f && *f)
1043   {
1044    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1045   }
1046  return 1;
1047 }
1048
1049 void
1050 PerlIOBase_clearerr(PerlIO *f)
1051 {
1052  if (f && *f)
1053   {
1054    PerlIO *n = PerlIONext(f);
1055    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1056    if (n)
1057     PerlIO_clearerr(n);
1058   }
1059 }
1060
1061 void
1062 PerlIOBase_setlinebuf(PerlIO *f)
1063 {
1064
1065 }
1066
1067 /*--------------------------------------------------------------------------------------*/
1068 /* Bottom-most level for UNIX-like case */
1069
1070 typedef struct
1071 {
1072  struct _PerlIO base;       /* The generic part */
1073  int            fd;         /* UNIX like file descriptor */
1074  int            oflags;     /* open/fcntl flags */
1075 } PerlIOUnix;
1076
1077 int
1078 PerlIOUnix_oflags(const char *mode)
1079 {
1080  int oflags = -1;
1081  switch(*mode)
1082   {
1083    case 'r':
1084     oflags = O_RDONLY;
1085     if (*++mode == '+')
1086      {
1087       oflags = O_RDWR;
1088       mode++;
1089      }
1090     break;
1091
1092    case 'w':
1093     oflags = O_CREAT|O_TRUNC;
1094     if (*++mode == '+')
1095      {
1096       oflags |= O_RDWR;
1097       mode++;
1098      }
1099     else
1100      oflags |= O_WRONLY;
1101     break;
1102
1103    case 'a':
1104     oflags = O_CREAT|O_APPEND;
1105     if (*++mode == '+')
1106      {
1107       oflags |= O_RDWR;
1108       mode++;
1109      }
1110     else
1111      oflags |= O_WRONLY;
1112     break;
1113   }
1114  if (*mode == 'b')
1115   {
1116    oflags |=  O_BINARY;
1117    oflags &= ~O_TEXT;
1118    mode++;
1119   }
1120  else if (*mode == 't')
1121   {
1122    oflags |=  O_TEXT;
1123    oflags &= ~O_BINARY;
1124    mode++;
1125   }
1126  /* Always open in binary mode */
1127  oflags |= O_BINARY;
1128  if (*mode || oflags == -1)
1129   {
1130    errno = EINVAL;
1131    oflags = -1;
1132   }
1133  return oflags;
1134 }
1135
1136 IV
1137 PerlIOUnix_fileno(PerlIO *f)
1138 {
1139  return PerlIOSelf(f,PerlIOUnix)->fd;
1140 }
1141
1142 PerlIO *
1143 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1144 {
1145  PerlIO *f = NULL;
1146  if (*mode == 'I')
1147   mode++;
1148  if (fd >= 0)
1149   {
1150    int oflags = PerlIOUnix_oflags(mode);
1151    if (oflags != -1)
1152     {
1153      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1154      s->fd     = fd;
1155      s->oflags = oflags;
1156      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1157     }
1158   }
1159  return f;
1160 }
1161
1162 PerlIO *
1163 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1164 {
1165  PerlIO *f = NULL;
1166  int oflags = PerlIOUnix_oflags(mode);
1167  if (oflags != -1)
1168   {
1169    int fd = PerlLIO_open3(path,oflags,0666);
1170    if (fd >= 0)
1171     {
1172      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1173      s->fd     = fd;
1174      s->oflags = oflags;
1175      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1176     }
1177   }
1178  return f;
1179 }
1180
1181 int
1182 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1183 {
1184  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1185  int oflags = PerlIOUnix_oflags(mode);
1186  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1187   (*PerlIOBase(f)->tab->Close)(f);
1188  if (oflags != -1)
1189   {
1190    int fd = PerlLIO_open3(path,oflags,0666);
1191    if (fd >= 0)
1192     {
1193      s->fd = fd;
1194      s->oflags = oflags;
1195      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1196      return 0;
1197     }
1198   }
1199  return -1;
1200 }
1201
1202 SSize_t
1203 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1204 {
1205  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1206  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1207   return 0;
1208  while (1)
1209   {
1210    SSize_t len = PerlLIO_read(fd,vbuf,count);
1211    if (len >= 0 || errno != EINTR)
1212     {
1213      if (len < 0)
1214       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1215      else if (len == 0 && count != 0)
1216       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1217      return len;
1218     }
1219   }
1220 }
1221
1222 SSize_t
1223 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1224 {
1225  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1226  while (1)
1227   {
1228    SSize_t len = PerlLIO_write(fd,vbuf,count);
1229    if (len >= 0 || errno != EINTR)
1230     {
1231      if (len < 0)
1232       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1233      return len;
1234     }
1235   }
1236 }
1237
1238 IV
1239 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1240 {
1241  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1242  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1243  return (new == (Off_t) -1) ? -1 : 0;
1244 }
1245
1246 Off_t
1247 PerlIOUnix_tell(PerlIO *f)
1248 {
1249  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1250 }
1251
1252 IV
1253 PerlIOUnix_close(PerlIO *f)
1254 {
1255  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1256  int code = 0;
1257  while (PerlLIO_close(fd) != 0)
1258   {
1259    if (errno != EINTR)
1260     {
1261      code = -1;
1262      break;
1263     }
1264   }
1265  if (code == 0)
1266   {
1267    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1268   }
1269  return code;
1270 }
1271
1272 PerlIO_funcs PerlIO_unix = {
1273  "unix",
1274  sizeof(PerlIOUnix),
1275  PERLIO_K_RAW,
1276  PerlIOUnix_fileno,
1277  PerlIOUnix_fdopen,
1278  PerlIOUnix_open,
1279  PerlIOUnix_reopen,
1280  PerlIOBase_pushed,
1281  PerlIOBase_noop_ok,
1282  PerlIOUnix_read,
1283  PerlIOBase_unread,
1284  PerlIOUnix_write,
1285  PerlIOUnix_seek,
1286  PerlIOUnix_tell,
1287  PerlIOUnix_close,
1288  PerlIOBase_noop_ok,   /* flush */
1289  PerlIOBase_noop_fail, /* fill */
1290  PerlIOBase_eof,
1291  PerlIOBase_error,
1292  PerlIOBase_clearerr,
1293  PerlIOBase_setlinebuf,
1294  NULL, /* get_base */
1295  NULL, /* get_bufsiz */
1296  NULL, /* get_ptr */
1297  NULL, /* get_cnt */
1298  NULL, /* set_ptrcnt */
1299 };
1300
1301 /*--------------------------------------------------------------------------------------*/
1302 /* stdio as a layer */
1303
1304 typedef struct
1305 {
1306  struct _PerlIO base;
1307  FILE *         stdio;      /* The stream */
1308 } PerlIOStdio;
1309
1310 IV
1311 PerlIOStdio_fileno(PerlIO *f)
1312 {
1313  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1314 }
1315
1316 const char *
1317 PerlIOStdio_mode(const char *mode,char *tmode)
1318 {
1319  const char *ret = mode;
1320  if (O_BINARY != O_TEXT)
1321   {
1322    ret = (const char *) tmode;
1323    while (*mode)
1324     {
1325      *tmode++ = *mode++;
1326     }
1327    *tmode++ = 'b';
1328    *tmode = '\0';
1329   }
1330  return ret;
1331 }
1332
1333 PerlIO *
1334 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1335 {
1336  PerlIO *f = NULL;
1337  int init = 0;
1338  char tmode[8];
1339  if (*mode == 'I')
1340   {
1341    init = 1;
1342    mode++;
1343   }
1344  if (fd >= 0)
1345   {
1346    FILE *stdio = NULL;
1347    if (init)
1348     {
1349      switch(fd)
1350       {
1351        case 0:
1352         stdio = PerlSIO_stdin;
1353         break;
1354        case 1:
1355         stdio = PerlSIO_stdout;
1356         break;
1357        case 2:
1358         stdio = PerlSIO_stderr;
1359         break;
1360       }
1361     }
1362    else
1363     {
1364      stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1365     }
1366    if (stdio)
1367     {
1368      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1369      s->stdio  = stdio;
1370     }
1371   }
1372  return f;
1373 }
1374
1375 #undef PerlIO_importFILE
1376 PerlIO *
1377 PerlIO_importFILE(FILE *stdio, int fl)
1378 {
1379  PerlIO *f = NULL;
1380  if (stdio)
1381   {
1382    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1383    s->stdio  = stdio;
1384   }
1385  return f;
1386 }
1387
1388 PerlIO *
1389 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1390 {
1391  PerlIO *f = NULL;
1392  FILE *stdio = PerlSIO_fopen(path,mode);
1393  if (stdio)
1394   {
1395    char tmode[8];
1396    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1397                                (mode = PerlIOStdio_mode(mode,tmode))),
1398                                PerlIOStdio);
1399    s->stdio  = stdio;
1400   }
1401  return f;
1402 }
1403
1404 int
1405 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1406 {
1407  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1408  char tmode[8];
1409  FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1410  if (!s->stdio)
1411   return -1;
1412  s->stdio = stdio;
1413  return 0;
1414 }
1415
1416 SSize_t
1417 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1418 {
1419  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1420  SSize_t got = 0;
1421  if (count == 1)
1422   {
1423    STDCHAR *buf = (STDCHAR *) vbuf;
1424    /* Perl is expecting PerlIO_getc() to fill the buffer
1425     * Linux's stdio does not do that for fread()
1426     */
1427    int ch = PerlSIO_fgetc(s);
1428    if (ch != EOF)
1429     {
1430      *buf = ch;
1431      got = 1;
1432     }
1433   }
1434  else
1435   got = PerlSIO_fread(vbuf,1,count,s);
1436  return got;
1437 }
1438
1439 SSize_t
1440 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1441 {
1442  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1443  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1444  SSize_t unread = 0;
1445  while (count > 0)
1446   {
1447    int ch = *buf-- & 0xff;
1448    if (PerlSIO_ungetc(ch,s) != ch)
1449     break;
1450    unread++;
1451    count--;
1452   }
1453  return unread;
1454 }
1455
1456 SSize_t
1457 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1458 {
1459  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1460 }
1461
1462 IV
1463 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1464 {
1465  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466  return PerlSIO_fseek(stdio,offset,whence);
1467 }
1468
1469 Off_t
1470 PerlIOStdio_tell(PerlIO *f)
1471 {
1472  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473  return PerlSIO_ftell(stdio);
1474 }
1475
1476 IV
1477 PerlIOStdio_close(PerlIO *f)
1478 {
1479  int optval, optlen = sizeof(int);
1480  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1481  return(
1482    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1483        PerlSIO_fclose(stdio) :
1484        close(PerlIO_fileno(f)));
1485 }
1486
1487 IV
1488 PerlIOStdio_flush(PerlIO *f)
1489 {
1490  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1491  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1492   {
1493    return PerlSIO_fflush(stdio);
1494   }
1495  else
1496   {
1497 #if 0
1498    /* FIXME: This discards ungetc() and pre-read stuff which is
1499       not right if this is just a "sync" from a layer above
1500       Suspect right design is to do _this_ but not have layer above
1501       flush this layer read-to-read
1502     */
1503    /* Not writeable - sync by attempting a seek */
1504    int err = errno;
1505    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1506     errno = err;
1507 #endif
1508   }
1509  return 0;
1510 }
1511
1512 IV
1513 PerlIOStdio_fill(PerlIO *f)
1514 {
1515  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1516  int c;
1517  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1518  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1519   {
1520    if (PerlSIO_fflush(stdio) != 0)
1521     return EOF;
1522   }
1523  c = PerlSIO_fgetc(stdio);
1524  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1525   return EOF;
1526  return 0;
1527 }
1528
1529 IV
1530 PerlIOStdio_eof(PerlIO *f)
1531 {
1532  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1533 }
1534
1535 IV
1536 PerlIOStdio_error(PerlIO *f)
1537 {
1538  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1539 }
1540
1541 void
1542 PerlIOStdio_clearerr(PerlIO *f)
1543 {
1544  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1545 }
1546
1547 void
1548 PerlIOStdio_setlinebuf(PerlIO *f)
1549 {
1550 #ifdef HAS_SETLINEBUF
1551  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1552 #else
1553  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1554 #endif
1555 }
1556
1557 #ifdef FILE_base
1558 STDCHAR *
1559 PerlIOStdio_get_base(PerlIO *f)
1560 {
1561  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1562  return PerlSIO_get_base(stdio);
1563 }
1564
1565 Size_t
1566 PerlIOStdio_get_bufsiz(PerlIO *f)
1567 {
1568  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1569  return PerlSIO_get_bufsiz(stdio);
1570 }
1571 #endif
1572
1573 #ifdef USE_STDIO_PTR
1574 STDCHAR *
1575 PerlIOStdio_get_ptr(PerlIO *f)
1576 {
1577  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1578  return PerlSIO_get_ptr(stdio);
1579 }
1580
1581 SSize_t
1582 PerlIOStdio_get_cnt(PerlIO *f)
1583 {
1584  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1585  return PerlSIO_get_cnt(stdio);
1586 }
1587
1588 void
1589 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1590 {
1591  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1592  if (ptr != NULL)
1593   {
1594 #ifdef STDIO_PTR_LVALUE
1595    PerlSIO_set_ptr(stdio,ptr);
1596 #ifdef STDIO_PTR_LVAL_SETS_CNT
1597    if (PerlSIO_get_cnt(stdio) != (cnt))
1598     {
1599      dTHX;
1600      assert(PerlSIO_get_cnt(stdio) == (cnt));
1601     }
1602 #endif
1603 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1604    /* Setting ptr _does_ change cnt - we are done */
1605    return;
1606 #endif
1607 #else  /* STDIO_PTR_LVALUE */
1608    PerlProc_abort();
1609 #endif /* STDIO_PTR_LVALUE */
1610   }
1611 /* Now (or only) set cnt */
1612 #ifdef STDIO_CNT_LVALUE
1613  PerlSIO_set_cnt(stdio,cnt);
1614 #else  /* STDIO_CNT_LVALUE */
1615 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1616  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1617 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1618  PerlProc_abort();
1619 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1620 #endif /* STDIO_CNT_LVALUE */
1621 }
1622
1623 #endif
1624
1625 PerlIO_funcs PerlIO_stdio = {
1626  "stdio",
1627  sizeof(PerlIOStdio),
1628  PERLIO_K_BUFFERED,
1629  PerlIOStdio_fileno,
1630  PerlIOStdio_fdopen,
1631  PerlIOStdio_open,
1632  PerlIOStdio_reopen,
1633  PerlIOBase_pushed,
1634  PerlIOBase_noop_ok,
1635  PerlIOStdio_read,
1636  PerlIOStdio_unread,
1637  PerlIOStdio_write,
1638  PerlIOStdio_seek,
1639  PerlIOStdio_tell,
1640  PerlIOStdio_close,
1641  PerlIOStdio_flush,
1642  PerlIOStdio_fill,
1643  PerlIOStdio_eof,
1644  PerlIOStdio_error,
1645  PerlIOStdio_clearerr,
1646  PerlIOStdio_setlinebuf,
1647 #ifdef FILE_base
1648  PerlIOStdio_get_base,
1649  PerlIOStdio_get_bufsiz,
1650 #else
1651  NULL,
1652  NULL,
1653 #endif
1654 #ifdef USE_STDIO_PTR
1655  PerlIOStdio_get_ptr,
1656  PerlIOStdio_get_cnt,
1657 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1658  PerlIOStdio_set_ptrcnt
1659 #else  /* STDIO_PTR_LVALUE */
1660  NULL
1661 #endif /* STDIO_PTR_LVALUE */
1662 #else  /* USE_STDIO_PTR */
1663  NULL,
1664  NULL,
1665  NULL
1666 #endif /* USE_STDIO_PTR */
1667 };
1668
1669 #undef PerlIO_exportFILE
1670 FILE *
1671 PerlIO_exportFILE(PerlIO *f, int fl)
1672 {
1673  PerlIO_flush(f);
1674  /* Should really push stdio discipline when we have them */
1675  return fdopen(PerlIO_fileno(f),"r+");
1676 }
1677
1678 #undef PerlIO_findFILE
1679 FILE *
1680 PerlIO_findFILE(PerlIO *f)
1681 {
1682  return PerlIO_exportFILE(f,0);
1683 }
1684
1685 #undef PerlIO_releaseFILE
1686 void
1687 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1688 {
1689 }
1690
1691 /*--------------------------------------------------------------------------------------*/
1692 /* perlio buffer layer */
1693
1694 IV
1695 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1696 {
1697  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1698  b->posn = PerlIO_tell(PerlIONext(f));
1699  return PerlIOBase_pushed(f,mode);
1700 }
1701
1702 PerlIO *
1703 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1704 {
1705  PerlIO_funcs *tab = PerlIO_default_btm();
1706  int init = 0;
1707  PerlIO *f;
1708  if (*mode == 'I')
1709   {
1710    init = 1;
1711    mode++;
1712   }
1713 #if O_BINARY != O_TEXT
1714  /* do something about failing setmode()? --jhi */
1715  PerlLIO_setmode(fd, O_BINARY);
1716 #endif
1717  f = (*tab->Fdopen)(tab,fd,mode);
1718  if (f)
1719   {
1720    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1721    if (init && fd == 2)
1722     {
1723      /* Initial stderr is unbuffered */
1724      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1725     }
1726 #if 0
1727    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1728                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1729 #endif
1730   }
1731  return f;
1732 }
1733
1734 PerlIO *
1735 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1736 {
1737  PerlIO_funcs *tab = PerlIO_default_btm();
1738  PerlIO *f = (*tab->Open)(tab,path,mode);
1739  if (f)
1740   {
1741    PerlIO_push(f,self,mode);
1742   }
1743  return f;
1744 }
1745
1746 int
1747 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1748 {
1749  PerlIO *next = PerlIONext(f);
1750  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1751  if (code = 0)
1752   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1753  return code;
1754 }
1755
1756 /* This "flush" is akin to sfio's sync in that it handles files in either
1757    read or write state
1758 */
1759 IV
1760 PerlIOBuf_flush(PerlIO *f)
1761 {
1762  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1763  int code = 0;
1764  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1765   {
1766    /* write() the buffer */
1767    STDCHAR *p = b->buf;
1768    int count;
1769    PerlIO *n = PerlIONext(f);
1770    while (p < b->ptr)
1771     {
1772      count = PerlIO_write(n,p,b->ptr - p);
1773      if (count > 0)
1774       {
1775        p += count;
1776       }
1777      else if (count < 0 || PerlIO_error(n))
1778       {
1779        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1780        code = -1;
1781        break;
1782       }
1783     }
1784    b->posn += (p - b->buf);
1785   }
1786  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1787   {
1788    /* Note position change */
1789    b->posn += (b->ptr - b->buf);
1790    if (b->ptr < b->end)
1791     {
1792      /* We did not consume all of it */
1793      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1794       {
1795        b->posn = PerlIO_tell(PerlIONext(f));
1796       }
1797     }
1798   }
1799  b->ptr = b->end = b->buf;
1800  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1801  /* FIXME: Is this right for read case ? */
1802  if (PerlIO_flush(PerlIONext(f)) != 0)
1803   code = -1;
1804  return code;
1805 }
1806
1807 IV
1808 PerlIOBuf_fill(PerlIO *f)
1809 {
1810  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1811  PerlIO *n = PerlIONext(f);
1812  SSize_t avail;
1813  /* FIXME: doing the down-stream flush is a bad idea if it causes
1814     pre-read data in stdio buffer to be discarded
1815     but this is too simplistic - as it skips _our_ hosekeeping
1816     and breaks tell tests.
1817  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1818   {
1819   }
1820   */
1821  if (PerlIO_flush(f) != 0)
1822   return -1;
1823
1824  b->ptr = b->end = b->buf;
1825  if (PerlIO_fast_gets(n))
1826   {
1827    /* Layer below is also buffered
1828     * We do _NOT_ want to call its ->Read() because that will loop
1829     * till it gets what we asked for which may hang on a pipe etc.
1830     * Instead take anything it has to hand, or ask it to fill _once_.
1831     */
1832    avail  = PerlIO_get_cnt(n);
1833    if (avail <= 0)
1834     {
1835      avail = PerlIO_fill(n);
1836      if (avail == 0)
1837       avail = PerlIO_get_cnt(n);
1838      else
1839       {
1840        if (!PerlIO_error(n) && PerlIO_eof(n))
1841         avail = 0;
1842       }
1843     }
1844    if (avail > 0)
1845     {
1846      STDCHAR *ptr = PerlIO_get_ptr(n);
1847      SSize_t cnt  = avail;
1848      if (avail > b->bufsiz)
1849       avail = b->bufsiz;
1850      Copy(ptr,b->buf,avail,STDCHAR);
1851      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1852     }
1853   }
1854  else
1855   {
1856    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1857   }
1858  if (avail <= 0)
1859   {
1860    if (avail == 0)
1861     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1862    else
1863     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1864    return -1;
1865   }
1866  b->end      = b->buf+avail;
1867  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1868  return 0;
1869 }
1870
1871 SSize_t
1872 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1873 {
1874  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1875  STDCHAR *buf  = (STDCHAR *) vbuf;
1876  if (f)
1877   {
1878    if (!b->ptr)
1879     PerlIO_get_base(f);
1880    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1881     return 0;
1882    while (count > 0)
1883     {
1884      SSize_t avail = PerlIO_get_cnt(f);
1885      SSize_t take  = (count < avail) ? count : avail;
1886      if (take > 0)
1887       {
1888        STDCHAR *ptr = PerlIO_get_ptr(f);
1889        Copy(ptr,buf,take,STDCHAR);
1890        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1891        count   -= take;
1892        buf     += take;
1893       }
1894      if (count > 0  && avail <= 0)
1895       {
1896        if (PerlIO_fill(f) != 0)
1897         break;
1898       }
1899     }
1900    return (buf - (STDCHAR *) vbuf);
1901   }
1902  return 0;
1903 }
1904
1905 SSize_t
1906 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1907 {
1908  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1909  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1910  SSize_t unread = 0;
1911  SSize_t avail;
1912  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1913   PerlIO_flush(f);
1914  if (!b->buf)
1915   PerlIO_get_base(f);
1916  if (b->buf)
1917   {
1918    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1919     {
1920      avail = (b->ptr - b->buf);
1921     }
1922    else
1923     {
1924      avail = b->bufsiz;
1925      b->end = b->buf + avail;
1926      b->ptr = b->end;
1927      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1928      b->posn -= b->bufsiz;
1929     }
1930    if (avail > (SSize_t) count)
1931     avail = count;
1932    if (avail > 0)
1933     {
1934      b->ptr -= avail;
1935      buf    -= avail;
1936      if (buf != b->ptr)
1937       {
1938        Copy(buf,b->ptr,avail,STDCHAR);
1939       }
1940      count  -= avail;
1941      unread += avail;
1942      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1943     }
1944   }
1945  return unread;
1946 }
1947
1948 SSize_t
1949 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1950 {
1951  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1952  const STDCHAR *buf = (const STDCHAR *) vbuf;
1953  Size_t written = 0;
1954  if (!b->buf)
1955   PerlIO_get_base(f);
1956  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1957   return 0;
1958  while (count > 0)
1959   {
1960    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1961    if ((SSize_t) count < avail)
1962     avail = count;
1963    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1964    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1965     {
1966      while (avail > 0)
1967       {
1968        int ch = *buf++;
1969        *(b->ptr)++ = ch;
1970        count--;
1971        avail--;
1972        written++;
1973        if (ch == '\n')
1974         {
1975          PerlIO_flush(f);
1976          break;
1977         }
1978       }
1979     }
1980    else
1981     {
1982      if (avail)
1983       {
1984        Copy(buf,b->ptr,avail,STDCHAR);
1985        count   -= avail;
1986        buf     += avail;
1987        written += avail;
1988        b->ptr  += avail;
1989       }
1990     }
1991    if (b->ptr >= (b->buf + b->bufsiz))
1992     PerlIO_flush(f);
1993   }
1994  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1995   PerlIO_flush(f);
1996  return written;
1997 }
1998
1999 IV
2000 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2001 {
2002  IV code;
2003  if ((code = PerlIO_flush(f)) == 0)
2004   {
2005    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2006    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2007    code = PerlIO_seek(PerlIONext(f),offset,whence);
2008    if (code == 0)
2009     {
2010      b->posn = PerlIO_tell(PerlIONext(f));
2011     }
2012   }
2013  return code;
2014 }
2015
2016 Off_t
2017 PerlIOBuf_tell(PerlIO *f)
2018 {
2019  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2020  Off_t posn = b->posn;
2021  if (b->buf)
2022   posn += (b->ptr - b->buf);
2023  return posn;
2024 }
2025
2026 IV
2027 PerlIOBuf_close(PerlIO *f)
2028 {
2029  IV code = PerlIOBase_close(f);
2030  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2031  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2032   {
2033    Safefree(b->buf);
2034   }
2035  b->buf = NULL;
2036  b->ptr = b->end = b->buf;
2037  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2038  return code;
2039 }
2040
2041 void
2042 PerlIOBuf_setlinebuf(PerlIO *f)
2043 {
2044  if (f)
2045   {
2046    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2047   }
2048 }
2049
2050 STDCHAR *
2051 PerlIOBuf_get_ptr(PerlIO *f)
2052 {
2053  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2054  if (!b->buf)
2055   PerlIO_get_base(f);
2056  return b->ptr;
2057 }
2058
2059 SSize_t
2060 PerlIOBuf_get_cnt(PerlIO *f)
2061 {
2062  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2063  if (!b->buf)
2064   PerlIO_get_base(f);
2065  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2066   return (b->end - b->ptr);
2067  return 0;
2068 }
2069
2070 STDCHAR *
2071 PerlIOBuf_get_base(PerlIO *f)
2072 {
2073  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2074  if (!b->buf)
2075   {
2076    if (!b->bufsiz)
2077     b->bufsiz = 4096;
2078    New('B',b->buf,b->bufsiz,STDCHAR);
2079    if (!b->buf)
2080     {
2081      b->buf = (STDCHAR *)&b->oneword;
2082      b->bufsiz = sizeof(b->oneword);
2083     }
2084    b->ptr = b->buf;
2085    b->end = b->ptr;
2086   }
2087  return b->buf;
2088 }
2089
2090 Size_t
2091 PerlIOBuf_bufsiz(PerlIO *f)
2092 {
2093  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2094  if (!b->buf)
2095   PerlIO_get_base(f);
2096  return (b->end - b->buf);
2097 }
2098
2099 void
2100 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2101 {
2102  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2103  if (!b->buf)
2104   PerlIO_get_base(f);
2105  b->ptr = ptr;
2106  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2107   {
2108    dTHX;
2109    assert(PerlIO_get_cnt(f) == cnt);
2110    assert(b->ptr >= b->buf);
2111   }
2112  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2113 }
2114
2115 PerlIO_funcs PerlIO_perlio = {
2116  "perlio",
2117  sizeof(PerlIOBuf),
2118  PERLIO_K_BUFFERED,
2119  PerlIOBase_fileno,
2120  PerlIOBuf_fdopen,
2121  PerlIOBuf_open,
2122  PerlIOBuf_reopen,
2123  PerlIOBuf_pushed,
2124  PerlIOBase_noop_ok,
2125  PerlIOBuf_read,
2126  PerlIOBuf_unread,
2127  PerlIOBuf_write,
2128  PerlIOBuf_seek,
2129  PerlIOBuf_tell,
2130  PerlIOBuf_close,
2131  PerlIOBuf_flush,
2132  PerlIOBuf_fill,
2133  PerlIOBase_eof,
2134  PerlIOBase_error,
2135  PerlIOBase_clearerr,
2136  PerlIOBuf_setlinebuf,
2137  PerlIOBuf_get_base,
2138  PerlIOBuf_bufsiz,
2139  PerlIOBuf_get_ptr,
2140  PerlIOBuf_get_cnt,
2141  PerlIOBuf_set_ptrcnt,
2142 };
2143
2144 /*--------------------------------------------------------------------------------------*/
2145 /* Temp layer to hold unread chars when cannot do it any other way */
2146
2147 IV
2148 PerlIOPending_fill(PerlIO *f)
2149 {
2150  /* Should never happen */
2151  PerlIO_flush(f);
2152  return 0;
2153 }
2154
2155 IV
2156 PerlIOPending_close(PerlIO *f)
2157 {
2158  /* A tad tricky - flush pops us, then we close new top */
2159  PerlIO_flush(f);
2160  return PerlIO_close(f);
2161 }
2162
2163 IV
2164 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2165 {
2166  /* A tad tricky - flush pops us, then we seek new top */
2167  PerlIO_flush(f);
2168  return PerlIO_seek(f,offset,whence);
2169 }
2170
2171
2172 IV
2173 PerlIOPending_flush(PerlIO *f)
2174 {
2175  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2176  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2177   {
2178    Safefree(b->buf);
2179    b->buf = NULL;
2180   }
2181  PerlIO_pop(f);
2182  return 0;
2183 }
2184
2185 void
2186 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2187 {
2188  if (cnt <= 0)
2189   {
2190    PerlIO_flush(f);
2191   }
2192  else
2193   {
2194    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2195   }
2196 }
2197
2198 IV
2199 PerlIOPending_pushed(PerlIO *f,const char *mode)
2200 {
2201  IV code    = PerlIOBuf_pushed(f,mode);
2202  PerlIOl *l = PerlIOBase(f);
2203  /* Our PerlIO_fast_gets must match what we are pushed on,
2204     or sv_gets() etc. get muddled when it changes mid-string
2205     when we auto-pop.
2206   */
2207  l->flags   = (l->flags & ~PERLIO_F_FASTGETS) |
2208               (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2209  return code;
2210 }
2211
2212 SSize_t
2213 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2214 {
2215  SSize_t avail = PerlIO_get_cnt(f);
2216  SSize_t got   = 0;
2217  if (count < avail)
2218   avail = count;
2219  if (avail > 0)
2220   got = PerlIOBuf_read(f,vbuf,avail);
2221  if (got < count)
2222   got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2223  return got;
2224 }
2225
2226
2227 PerlIO_funcs PerlIO_pending = {
2228  "pending",
2229  sizeof(PerlIOBuf),
2230  PERLIO_K_BUFFERED,
2231  PerlIOBase_fileno,
2232  NULL,
2233  NULL,
2234  NULL,
2235  PerlIOPending_pushed,
2236  PerlIOBase_noop_ok,
2237  PerlIOPending_read,
2238  PerlIOBuf_unread,
2239  PerlIOBuf_write,
2240  PerlIOPending_seek,
2241  PerlIOBuf_tell,
2242  PerlIOPending_close,
2243  PerlIOPending_flush,
2244  PerlIOPending_fill,
2245  PerlIOBase_eof,
2246  PerlIOBase_error,
2247  PerlIOBase_clearerr,
2248  PerlIOBuf_setlinebuf,
2249  PerlIOBuf_get_base,
2250  PerlIOBuf_bufsiz,
2251  PerlIOBuf_get_ptr,
2252  PerlIOBuf_get_cnt,
2253  PerlIOPending_set_ptrcnt,
2254 };
2255
2256
2257
2258 /*--------------------------------------------------------------------------------------*/
2259 /* crlf - translation
2260    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2261    to hand back a line at a time and keeping a record of which nl we "lied" about.
2262    On write translate "\n" to CR,LF
2263  */
2264
2265 typedef struct
2266 {
2267  PerlIOBuf      base;         /* PerlIOBuf stuff */
2268  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2269 } PerlIOCrlf;
2270
2271 IV
2272 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2273 {
2274  IV code;
2275  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2276  code = PerlIOBuf_pushed(f,mode);
2277 #if 0
2278  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2279               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2280               PerlIOBase(f)->flags);
2281 #endif
2282  return code;
2283 }
2284
2285
2286 SSize_t
2287 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2288 {
2289  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2290  if (c->nl)
2291   {
2292    *(c->nl) = 0xd;
2293    c->nl = NULL;
2294   }
2295  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2296   return PerlIOBuf_unread(f,vbuf,count);
2297  else
2298   {
2299    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2300    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2301    SSize_t unread = 0;
2302    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2303     PerlIO_flush(f);
2304    if (!b->buf)
2305     PerlIO_get_base(f);
2306    if (b->buf)
2307     {
2308      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2309       {
2310        b->end = b->ptr = b->buf + b->bufsiz;
2311        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2312        b->posn -= b->bufsiz;
2313       }
2314      while (count > 0 && b->ptr > b->buf)
2315       {
2316        int ch = *--buf;
2317        if (ch == '\n')
2318         {
2319          if (b->ptr - 2 >= b->buf)
2320           {
2321            *--(b->ptr) = 0xa;
2322            *--(b->ptr) = 0xd;
2323            unread++;
2324            count--;
2325           }
2326          else
2327           {
2328            buf++;
2329            break;
2330           }
2331         }
2332        else
2333         {
2334          *--(b->ptr) = ch;
2335          unread++;
2336          count--;
2337         }
2338       }
2339     }
2340    return unread;
2341   }
2342 }
2343
2344 SSize_t
2345 PerlIOCrlf_get_cnt(PerlIO *f)
2346 {
2347  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2348  if (!b->buf)
2349   PerlIO_get_base(f);
2350  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2351   {
2352    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2353    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2354     {
2355      STDCHAR *nl   = b->ptr;
2356     scan:
2357      while (nl < b->end && *nl != 0xd)
2358       nl++;
2359      if (nl < b->end && *nl == 0xd)
2360       {
2361      test:
2362        if (nl+1 < b->end)
2363         {
2364          if (nl[1] == 0xa)
2365           {
2366            *nl   = '\n';
2367            c->nl = nl;
2368           }
2369          else
2370           {
2371            /* Not CR,LF but just CR */
2372            nl++;
2373            goto scan;
2374           }
2375         }
2376        else
2377         {
2378          /* Blast - found CR as last char in buffer */
2379          if (b->ptr < nl)
2380           {
2381            /* They may not care, defer work as long as possible */
2382            return (nl - b->ptr);
2383           }
2384          else
2385           {
2386            int code;
2387            dTHX;
2388            b->ptr++;               /* say we have read it as far as flush() is concerned */
2389            b->buf++;               /* Leave space an front of buffer */
2390            b->bufsiz--;            /* Buffer is thus smaller */
2391            code = PerlIO_fill(f);  /* Fetch some more */
2392            b->bufsiz++;            /* Restore size for next time */
2393            b->buf--;               /* Point at space */
2394            b->ptr = nl = b->buf;   /* Which is what we hand off */
2395            b->posn--;              /* Buffer starts here */
2396            *nl = 0xd;              /* Fill in the CR */
2397            if (code == 0)
2398             goto test;             /* fill() call worked */
2399            /* CR at EOF - just fall through */
2400           }
2401         }
2402       }
2403     }
2404    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2405   }
2406  return 0;
2407 }
2408
2409 void
2410 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2411 {
2412  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2413  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2414  IV flags = PerlIOBase(f)->flags;
2415  if (!b->buf)
2416   PerlIO_get_base(f);
2417  if (!ptr)
2418   {
2419    if (c->nl)
2420     ptr = c->nl+1;
2421    else
2422     {
2423      ptr = b->end;
2424      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2425       ptr--;
2426     }
2427    ptr -= cnt;
2428   }
2429  else
2430   {
2431    /* Test code - delete when it works ... */
2432    STDCHAR *chk;
2433    if (c->nl)
2434     chk = c->nl+1;
2435    else
2436     {
2437      chk = b->end;
2438      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2439       chk--;
2440     }
2441    chk -= cnt;
2442
2443    if (ptr != chk)
2444     {
2445      dTHX;
2446      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2447                 ptr, chk, flags, c->nl, b->end, cnt);
2448     }
2449   }
2450  if (c->nl)
2451   {
2452    if (ptr > c->nl)
2453     {
2454      /* They have taken what we lied about */
2455      *(c->nl) = 0xd;
2456      c->nl = NULL;
2457      ptr++;
2458     }
2459   }
2460  b->ptr = ptr;
2461  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2462 }
2463
2464 SSize_t
2465 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2466 {
2467  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2468   return PerlIOBuf_write(f,vbuf,count);
2469  else
2470   {
2471    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2472    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2473    const STDCHAR *ebuf = buf+count;
2474    if (!b->buf)
2475     PerlIO_get_base(f);
2476    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2477     return 0;
2478    while (buf < ebuf)
2479     {
2480      STDCHAR *eptr = b->buf+b->bufsiz;
2481      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2482      while (buf < ebuf && b->ptr < eptr)
2483       {
2484        if (*buf == '\n')
2485         {
2486          if ((b->ptr + 2) > eptr)
2487           {
2488            /* Not room for both */
2489            PerlIO_flush(f);
2490            break;
2491           }
2492          else
2493           {
2494            *(b->ptr)++ = 0xd; /* CR */
2495            *(b->ptr)++ = 0xa; /* LF */
2496            buf++;
2497            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2498             {
2499              PerlIO_flush(f);
2500              break;
2501             }
2502           }
2503         }
2504        else
2505         {
2506          int ch = *buf++;
2507          *(b->ptr)++ = ch;
2508         }
2509        if (b->ptr >= eptr)
2510         {
2511          PerlIO_flush(f);
2512          break;
2513         }
2514       }
2515     }
2516    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2517     PerlIO_flush(f);
2518    return (buf - (STDCHAR *) vbuf);
2519   }
2520 }
2521
2522 IV
2523 PerlIOCrlf_flush(PerlIO *f)
2524 {
2525  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2526  if (c->nl)
2527   {
2528    *(c->nl) = 0xd;
2529    c->nl = NULL;
2530   }
2531  return PerlIOBuf_flush(f);
2532 }
2533
2534 PerlIO_funcs PerlIO_crlf = {
2535  "crlf",
2536  sizeof(PerlIOCrlf),
2537  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2538  PerlIOBase_fileno,
2539  PerlIOBuf_fdopen,
2540  PerlIOBuf_open,
2541  PerlIOBuf_reopen,
2542  PerlIOCrlf_pushed,
2543  PerlIOBase_noop_ok,   /* popped */
2544  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2545  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2546  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2547  PerlIOBuf_seek,
2548  PerlIOBuf_tell,
2549  PerlIOBuf_close,
2550  PerlIOCrlf_flush,
2551  PerlIOBuf_fill,
2552  PerlIOBase_eof,
2553  PerlIOBase_error,
2554  PerlIOBase_clearerr,
2555  PerlIOBuf_setlinebuf,
2556  PerlIOBuf_get_base,
2557  PerlIOBuf_bufsiz,
2558  PerlIOBuf_get_ptr,
2559  PerlIOCrlf_get_cnt,
2560  PerlIOCrlf_set_ptrcnt,
2561 };
2562
2563 #ifdef HAS_MMAP
2564 /*--------------------------------------------------------------------------------------*/
2565 /* mmap as "buffer" layer */
2566
2567 typedef struct
2568 {
2569  PerlIOBuf      base;         /* PerlIOBuf stuff */
2570  Mmap_t         mptr;        /* Mapped address */
2571  Size_t         len;          /* mapped length */
2572  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2573 } PerlIOMmap;
2574
2575 static size_t page_size = 0;
2576
2577 IV
2578 PerlIOMmap_map(PerlIO *f)
2579 {
2580  dTHX;
2581  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2582  PerlIOBuf  *b = &m->base;
2583  IV flags = PerlIOBase(f)->flags;
2584  IV code  = 0;
2585  if (m->len)
2586   abort();
2587  if (flags & PERLIO_F_CANREAD)
2588   {
2589    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2590    int fd   = PerlIO_fileno(f);
2591    struct stat st;
2592    code = fstat(fd,&st);
2593    if (code == 0 && S_ISREG(st.st_mode))
2594     {
2595      SSize_t len = st.st_size - b->posn;
2596      if (len > 0)
2597       {
2598        Off_t posn;
2599        if (!page_size) {
2600 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2601            {
2602                SETERRNO(0,SS$_NORMAL);
2603 #   ifdef _SC_PAGESIZE
2604                page_size = sysconf(_SC_PAGESIZE);
2605 #   else
2606                page_size = sysconf(_SC_PAGE_SIZE);
2607 #   endif
2608                if ((long)page_size < 0) {
2609                    if (errno) {
2610                        SV *error = ERRSV;
2611                        char *msg;
2612                        STRLEN n_a;
2613                        (void)SvUPGRADE(error, SVt_PV);
2614                        msg = SvPVx(error, n_a);
2615                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2616                    }
2617                    else
2618                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2619                }
2620            }
2621 #else
2622 #   ifdef HAS_GETPAGESIZE
2623         page_size = getpagesize();
2624 #   else
2625 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2626         page_size = PAGESIZE; /* compiletime, bad */
2627 #       endif
2628 #   endif
2629 #endif
2630         if ((IV)page_size <= 0)
2631             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2632        }
2633        if (b->posn < 0)
2634         {
2635          /* This is a hack - should never happen - open should have set it ! */
2636          b->posn = PerlIO_tell(PerlIONext(f));
2637         }
2638        posn = (b->posn / page_size) * page_size;
2639        len  = st.st_size - posn;
2640        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2641        if (m->mptr && m->mptr != (Mmap_t) -1)
2642         {
2643 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2644          madvise(m->mptr, len, MADV_SEQUENTIAL);
2645 #endif
2646          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2647          b->end  = ((STDCHAR *)m->mptr) + len;
2648          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2649          b->ptr  = b->buf;
2650          m->len  = len;
2651         }
2652        else
2653         {
2654          b->buf = NULL;
2655         }
2656       }
2657      else
2658       {
2659        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2660        b->buf = NULL;
2661        b->ptr = b->end = b->ptr;
2662        code = -1;
2663       }
2664     }
2665   }
2666  return code;
2667 }
2668
2669 IV
2670 PerlIOMmap_unmap(PerlIO *f)
2671 {
2672  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2673  PerlIOBuf  *b = &m->base;
2674  IV code = 0;
2675  if (m->len)
2676   {
2677    if (b->buf)
2678     {
2679      code = munmap(m->mptr, m->len);
2680      b->buf  = NULL;
2681      m->len  = 0;
2682      m->mptr = NULL;
2683      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2684       code = -1;
2685     }
2686    b->ptr = b->end = b->buf;
2687    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2688   }
2689  return code;
2690 }
2691
2692 STDCHAR *
2693 PerlIOMmap_get_base(PerlIO *f)
2694 {
2695  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2696  PerlIOBuf  *b = &m->base;
2697  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2698   {
2699    /* Already have a readbuffer in progress */
2700    return b->buf;
2701   }
2702  if (b->buf)
2703   {
2704    /* We have a write buffer or flushed PerlIOBuf read buffer */
2705    m->bbuf = b->buf;  /* save it in case we need it again */
2706    b->buf  = NULL;    /* Clear to trigger below */
2707   }
2708  if (!b->buf)
2709   {
2710    PerlIOMmap_map(f);     /* Try and map it */
2711    if (!b->buf)
2712     {
2713      /* Map did not work - recover PerlIOBuf buffer if we have one */
2714      b->buf = m->bbuf;
2715     }
2716   }
2717  b->ptr  = b->end = b->buf;
2718  if (b->buf)
2719   return b->buf;
2720  return PerlIOBuf_get_base(f);
2721 }
2722
2723 SSize_t
2724 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2725 {
2726  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2727  PerlIOBuf  *b = &m->base;
2728  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2729   PerlIO_flush(f);
2730  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2731   {
2732    b->ptr -= count;
2733    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2734    return count;
2735   }
2736  if (m->len)
2737   {
2738    /* Loose the unwritable mapped buffer */
2739    PerlIO_flush(f);
2740    /* If flush took the "buffer" see if we have one from before */
2741    if (!b->buf && m->bbuf)
2742     b->buf = m->bbuf;
2743    if (!b->buf)
2744     {
2745      PerlIOBuf_get_base(f);
2746      m->bbuf = b->buf;
2747     }
2748   }
2749 return PerlIOBuf_unread(f,vbuf,count);
2750 }
2751
2752 SSize_t
2753 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2754 {
2755  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2756  PerlIOBuf  *b = &m->base;
2757  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2758   {
2759    /* No, or wrong sort of, buffer */
2760    if (m->len)
2761     {
2762      if (PerlIOMmap_unmap(f) != 0)
2763       return 0;
2764     }
2765    /* If unmap took the "buffer" see if we have one from before */
2766    if (!b->buf && m->bbuf)
2767     b->buf = m->bbuf;
2768    if (!b->buf)
2769     {
2770      PerlIOBuf_get_base(f);
2771      m->bbuf = b->buf;
2772     }
2773   }
2774  return PerlIOBuf_write(f,vbuf,count);
2775 }
2776
2777 IV
2778 PerlIOMmap_flush(PerlIO *f)
2779 {
2780  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2781  PerlIOBuf  *b = &m->base;
2782  IV code = PerlIOBuf_flush(f);
2783  /* Now we are "synced" at PerlIOBuf level */
2784  if (b->buf)
2785   {
2786    if (m->len)
2787     {
2788      /* Unmap the buffer */
2789      if (PerlIOMmap_unmap(f) != 0)
2790       code = -1;
2791     }
2792    else
2793     {
2794      /* We seem to have a PerlIOBuf buffer which was not mapped
2795       * remember it in case we need one later
2796       */
2797      m->bbuf = b->buf;
2798     }
2799   }
2800  return code;
2801 }
2802
2803 IV
2804 PerlIOMmap_fill(PerlIO *f)
2805 {
2806  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2807  IV code = PerlIO_flush(f);
2808  if (code == 0 && !b->buf)
2809   {
2810    code = PerlIOMmap_map(f);
2811   }
2812  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2813   {
2814    code = PerlIOBuf_fill(f);
2815   }
2816  return code;
2817 }
2818
2819 IV
2820 PerlIOMmap_close(PerlIO *f)
2821 {
2822  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2823  PerlIOBuf  *b = &m->base;
2824  IV code = PerlIO_flush(f);
2825  if (m->bbuf)
2826   {
2827    b->buf  = m->bbuf;
2828    m->bbuf = NULL;
2829    b->ptr  = b->end = b->buf;
2830   }
2831  if (PerlIOBuf_close(f) != 0)
2832   code = -1;
2833  return code;
2834 }
2835
2836
2837 PerlIO_funcs PerlIO_mmap = {
2838  "mmap",
2839  sizeof(PerlIOMmap),
2840  PERLIO_K_BUFFERED,
2841  PerlIOBase_fileno,
2842  PerlIOBuf_fdopen,
2843  PerlIOBuf_open,
2844  PerlIOBuf_reopen,
2845  PerlIOBuf_pushed,
2846  PerlIOBase_noop_ok,
2847  PerlIOBuf_read,
2848  PerlIOMmap_unread,
2849  PerlIOMmap_write,
2850  PerlIOBuf_seek,
2851  PerlIOBuf_tell,
2852  PerlIOBuf_close,
2853  PerlIOMmap_flush,
2854  PerlIOMmap_fill,
2855  PerlIOBase_eof,
2856  PerlIOBase_error,
2857  PerlIOBase_clearerr,
2858  PerlIOBuf_setlinebuf,
2859  PerlIOMmap_get_base,
2860  PerlIOBuf_bufsiz,
2861  PerlIOBuf_get_ptr,
2862  PerlIOBuf_get_cnt,
2863  PerlIOBuf_set_ptrcnt,
2864 };
2865
2866 #endif /* HAS_MMAP */
2867
2868 void
2869 PerlIO_init(void)
2870 {
2871  if (!_perlio)
2872   {
2873    atexit(&PerlIO_cleanup);
2874   }
2875 }
2876
2877 #undef PerlIO_stdin
2878 PerlIO *
2879 PerlIO_stdin(void)
2880 {
2881  if (!_perlio)
2882   PerlIO_stdstreams();
2883  return &_perlio[1];
2884 }
2885
2886 #undef PerlIO_stdout
2887 PerlIO *
2888 PerlIO_stdout(void)
2889 {
2890  if (!_perlio)
2891   PerlIO_stdstreams();
2892  return &_perlio[2];
2893 }
2894
2895 #undef PerlIO_stderr
2896 PerlIO *
2897 PerlIO_stderr(void)
2898 {
2899  if (!_perlio)
2900   PerlIO_stdstreams();
2901  return &_perlio[3];
2902 }
2903
2904 /*--------------------------------------------------------------------------------------*/
2905
2906 #undef PerlIO_getname
2907 char *
2908 PerlIO_getname(PerlIO *f, char *buf)
2909 {
2910  dTHX;
2911  Perl_croak(aTHX_ "Don't know how to get file name");
2912  return NULL;
2913 }
2914
2915
2916 /*--------------------------------------------------------------------------------------*/
2917 /* Functions which can be called on any kind of PerlIO implemented
2918    in terms of above
2919 */
2920
2921 #undef PerlIO_getc
2922 int
2923 PerlIO_getc(PerlIO *f)
2924 {
2925  STDCHAR buf[1];
2926  SSize_t count = PerlIO_read(f,buf,1);
2927  if (count == 1)
2928   {
2929    return (unsigned char) buf[0];
2930   }
2931  return EOF;
2932 }
2933
2934 #undef PerlIO_ungetc
2935 int
2936 PerlIO_ungetc(PerlIO *f, int ch)
2937 {
2938  if (ch != EOF)
2939   {
2940    STDCHAR buf = ch;
2941    if (PerlIO_unread(f,&buf,1) == 1)
2942     return ch;
2943   }
2944  return EOF;
2945 }
2946
2947 #undef PerlIO_putc
2948 int
2949 PerlIO_putc(PerlIO *f, int ch)
2950 {
2951  STDCHAR buf = ch;
2952  return PerlIO_write(f,&buf,1);
2953 }
2954
2955 #undef PerlIO_puts
2956 int
2957 PerlIO_puts(PerlIO *f, const char *s)
2958 {
2959  STRLEN len = strlen(s);
2960  return PerlIO_write(f,s,len);
2961 }
2962
2963 #undef PerlIO_rewind
2964 void
2965 PerlIO_rewind(PerlIO *f)
2966 {
2967  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2968  PerlIO_clearerr(f);
2969 }
2970
2971 #undef PerlIO_vprintf
2972 int
2973 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2974 {
2975  dTHX;
2976  SV *sv = newSVpvn("",0);
2977  char *s;
2978  STRLEN len;
2979 #ifdef NEED_VA_COPY
2980  va_list apc;
2981  Perl_va_copy(ap, apc);
2982  sv_vcatpvf(sv, fmt, &apc);
2983 #else
2984  sv_vcatpvf(sv, fmt, &ap);
2985 #endif
2986  s = SvPV(sv,len);
2987  return PerlIO_write(f,s,len);
2988 }
2989
2990 #undef PerlIO_printf
2991 int
2992 PerlIO_printf(PerlIO *f,const char *fmt,...)
2993 {
2994  va_list ap;
2995  int result;
2996  va_start(ap,fmt);
2997  result = PerlIO_vprintf(f,fmt,ap);
2998  va_end(ap);
2999  return result;
3000 }
3001
3002 #undef PerlIO_stdoutf
3003 int
3004 PerlIO_stdoutf(const char *fmt,...)
3005 {
3006  va_list ap;
3007  int result;
3008  va_start(ap,fmt);
3009  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3010  va_end(ap);
3011  return result;
3012 }
3013
3014 #undef PerlIO_tmpfile
3015 PerlIO *
3016 PerlIO_tmpfile(void)
3017 {
3018  /* I have no idea how portable mkstemp() is ... */
3019 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3020  PerlIO *f = NULL;
3021  FILE *stdio = PerlSIO_tmpfile();
3022  if (stdio)
3023   {
3024    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3025    s->stdio  = stdio;
3026   }
3027  return f;
3028 #else
3029  dTHX;
3030  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3031  int fd = mkstemp(SvPVX(sv));
3032  PerlIO *f = NULL;
3033  if (fd >= 0)
3034   {
3035    f = PerlIO_fdopen(fd,"w+");
3036    if (f)
3037     {
3038      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3039     }
3040    PerlLIO_unlink(SvPVX(sv));
3041    SvREFCNT_dec(sv);
3042   }
3043  return f;
3044 #endif
3045 }
3046
3047 #undef HAS_FSETPOS
3048 #undef HAS_FGETPOS
3049
3050 #endif /* USE_SFIO */
3051 #endif /* PERLIO_IS_STDIO */
3052
3053 /*======================================================================================*/
3054 /* Now some functions in terms of above which may be needed even if
3055    we are not in true PerlIO mode
3056  */
3057
3058 #ifndef HAS_FSETPOS
3059 #undef PerlIO_setpos
3060 int
3061 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3062 {
3063  return PerlIO_seek(f,*pos,0);
3064 }
3065 #else
3066 #ifndef PERLIO_IS_STDIO
3067 #undef PerlIO_setpos
3068 int
3069 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3070 {
3071 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3072  return fsetpos64(f, pos);
3073 #else
3074  return fsetpos(f, pos);
3075 #endif
3076 }
3077 #endif
3078 #endif
3079
3080 #ifndef HAS_FGETPOS
3081 #undef PerlIO_getpos
3082 int
3083 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3084 {
3085  *pos = PerlIO_tell(f);
3086  return *pos == -1 ? -1 : 0;
3087 }
3088 #else
3089 #ifndef PERLIO_IS_STDIO
3090 #undef PerlIO_getpos
3091 int
3092 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3093 {
3094 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3095  return fgetpos64(f, pos);
3096 #else
3097  return fgetpos(f, pos);
3098 #endif
3099 }
3100 #endif
3101 #endif
3102
3103 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3104
3105 int
3106 vprintf(char *pat, char *args)
3107 {
3108     _doprnt(pat, args, stdout);
3109     return 0;           /* wrong, but perl doesn't use the return value */
3110 }
3111
3112 int
3113 vfprintf(FILE *fd, char *pat, char *args)
3114 {
3115     _doprnt(pat, args, fd);
3116     return 0;           /* wrong, but perl doesn't use the return value */
3117 }
3118
3119 #endif
3120
3121 #ifndef PerlIO_vsprintf
3122 int
3123 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3124 {
3125  int val = vsprintf(s, fmt, ap);
3126  if (n >= 0)
3127   {
3128    if (strlen(s) >= (STRLEN)n)
3129     {
3130      dTHX;
3131      (void)PerlIO_puts(Perl_error_log,
3132                        "panic: sprintf overflow - memory corrupted!\n");
3133      my_exit(1);
3134     }
3135   }
3136  return val;
3137 }
3138 #endif
3139
3140 #ifndef PerlIO_sprintf
3141 int
3142 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3143 {
3144  va_list ap;
3145  int result;
3146  va_start(ap,fmt);
3147  result = PerlIO_vsprintf(s, n, fmt, ap);
3148  va_end(ap);
3149  return result;
3150 }
3151 #endif
3152
3153 #endif /* !PERL_IMPLICIT_SYS */
3154