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
  99 #ifdef PERLIO_IS_STDIO
 100
 101 void
 102 PerlIO_init(void)
 103 {
 104  /* Does nothing (yet) except force this file to be included
 105     in perl binary. That allows this file to force inclusion
 106     of other functions that may be required by loadable
 107     extensions e.g. for FileHandle::tmpfile
 108  */
 109 }
 110
 111 #undef PerlIO_tmpfile
 112 PerlIO *
 113 PerlIO_tmpfile(void)
 114 {
 115  return tmpfile();
 116 }
 117
 118 #else /* PERLIO_IS_STDIO */
 119
 120 #ifdef USE_SFIO
 121
 122 #undef HAS_FSETPOS
 123 #undef HAS_FGETPOS
 124
 125 /* This section is just to make sure these functions
 126    get pulled in from libsfio.a
 127 */
 128
 129 #undef PerlIO_tmpfile
 130 PerlIO *
 131 PerlIO_tmpfile(void)
 132 {
 133  return sftmp(0);
 134 }
 135
 136 void
 137 PerlIO_init(void)
 138 {
 139  /* Force this file to be included  in perl binary. Which allows
 140   *  this file to force inclusion  of other functions that may be
 141   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 142   */
 143
 144  /* Hack
 145   * sfio does its own 'autoflush' on stdout in common cases.
 146   * Flush results in a lot of lseek()s to regular files and
 147   * lot of small writes to pipes.
 148   */
 149  sfset(sfstdout,SF_SHARE,0);
 150 }
 151
 152 #else /* USE_SFIO */
 153 /*======================================================================================*/
 154 /* Implement all the PerlIO interface ourselves.
 155  */
 156
 157 #include "perliol.h"
 158
 159 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 160 #ifdef I_UNISTD
 161 #include <unistd.h>
 162 #endif
 163 #ifdef HAS_MMAP
 164 #include <sys/mman.h>
 165 #endif
 166
 167 #include "XSUB.h"
 168
 169 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 170
 171 void
 172 PerlIO_debug(const char *fmt,...)
 173 {
 174  dTHX;
 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  dTHX;
1166  PerlIO *f = NULL;
1167  int oflags = PerlIOUnix_oflags(mode);
1168  if (oflags != -1)
1169   {
1170    int fd = PerlLIO_open3(path,oflags,0666);
1171    if (fd >= 0)
1172     {
1173      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1174      s->fd     = fd;
1175      s->oflags = oflags;
1176      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1177     }
1178   }
1179  return f;
1180 }
1181
1182 int
1183 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1184 {
1185  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1186  int oflags = PerlIOUnix_oflags(mode);
1187  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1188   (*PerlIOBase(f)->tab->Close)(f);
1189  if (oflags != -1)
1190   {
1191    dTHX;
1192    int fd = PerlLIO_open3(path,oflags,0666);
1193    if (fd >= 0)
1194     {
1195      s->fd = fd;
1196      s->oflags = oflags;
1197      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1198      return 0;
1199     }
1200   }
1201  return -1;
1202 }
1203
1204 SSize_t
1205 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1206 {
1207  dTHX;
1208  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1209  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1210   return 0;
1211  while (1)
1212   {
1213    SSize_t len = PerlLIO_read(fd,vbuf,count);
1214    if (len >= 0 || errno != EINTR)
1215     {
1216      if (len < 0)
1217       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1218      else if (len == 0 && count != 0)
1219       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1220      return len;
1221     }
1222   }
1223 }
1224
1225 SSize_t
1226 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1227 {
1228  dTHX;
1229  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1230  while (1)
1231   {
1232    SSize_t len = PerlLIO_write(fd,vbuf,count);
1233    if (len >= 0 || errno != EINTR)
1234     {
1235      if (len < 0)
1236       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1237      return len;
1238     }
1239   }
1240 }
1241
1242 IV
1243 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1244 {
1245  dTHX;
1246  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1247  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1248  return (new == (Off_t) -1) ? -1 : 0;
1249 }
1250
1251 Off_t
1252 PerlIOUnix_tell(PerlIO *f)
1253 {
1254  dTHX;
1255  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1256 }
1257
1258 IV
1259 PerlIOUnix_close(PerlIO *f)
1260 {
1261  dTHX;
1262  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1263  int code = 0;
1264  while (PerlLIO_close(fd) != 0)
1265   {
1266    if (errno != EINTR)
1267     {
1268      code = -1;
1269      break;
1270     }
1271   }
1272  if (code == 0)
1273   {
1274    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1275   }
1276  return code;
1277 }
1278
1279 PerlIO_funcs PerlIO_unix = {
1280  "unix",
1281  sizeof(PerlIOUnix),
1282  PERLIO_K_RAW,
1283  PerlIOUnix_fileno,
1284  PerlIOUnix_fdopen,
1285  PerlIOUnix_open,
1286  PerlIOUnix_reopen,
1287  PerlIOBase_pushed,
1288  PerlIOBase_noop_ok,
1289  PerlIOUnix_read,
1290  PerlIOBase_unread,
1291  PerlIOUnix_write,
1292  PerlIOUnix_seek,
1293  PerlIOUnix_tell,
1294  PerlIOUnix_close,
1295  PerlIOBase_noop_ok,   /* flush */
1296  PerlIOBase_noop_fail, /* fill */
1297  PerlIOBase_eof,
1298  PerlIOBase_error,
1299  PerlIOBase_clearerr,
1300  PerlIOBase_setlinebuf,
1301  NULL, /* get_base */
1302  NULL, /* get_bufsiz */
1303  NULL, /* get_ptr */
1304  NULL, /* get_cnt */
1305  NULL, /* set_ptrcnt */
1306 };
1307
1308 /*--------------------------------------------------------------------------------------*/
1309 /* stdio as a layer */
1310
1311 typedef struct
1312 {
1313  struct _PerlIO base;
1314  FILE *         stdio;      /* The stream */
1315 } PerlIOStdio;
1316
1317 IV
1318 PerlIOStdio_fileno(PerlIO *f)
1319 {
1320  dTHX;
1321  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1322 }
1323
1324 const char *
1325 PerlIOStdio_mode(const char *mode,char *tmode)
1326 {
1327  const char *ret = mode;
1328  if (O_BINARY != O_TEXT)
1329   {
1330    ret = (const char *) tmode;
1331    while (*mode)
1332     {
1333      *tmode++ = *mode++;
1334     }
1335    *tmode++ = 'b';
1336    *tmode = '\0';
1337   }
1338  return ret;
1339 }
1340
1341 PerlIO *
1342 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1343 {
1344  dTHX;
1345  PerlIO *f = NULL;
1346  int init = 0;
1347  char tmode[8];
1348  if (*mode == 'I')
1349   {
1350    init = 1;
1351    mode++;
1352   }
1353  if (fd >= 0)
1354   {
1355    FILE *stdio = NULL;
1356    if (init)
1357     {
1358      switch(fd)
1359       {
1360        case 0:
1361         stdio = PerlSIO_stdin;
1362         break;
1363        case 1:
1364         stdio = PerlSIO_stdout;
1365         break;
1366        case 2:
1367         stdio = PerlSIO_stderr;
1368         break;
1369       }
1370     }
1371    else
1372     {
1373      stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1374     }
1375    if (stdio)
1376     {
1377      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1378      s->stdio  = stdio;
1379     }
1380   }
1381  return f;
1382 }
1383
1384 #undef PerlIO_importFILE
1385 PerlIO *
1386 PerlIO_importFILE(FILE *stdio, int fl)
1387 {
1388  PerlIO *f = NULL;
1389  if (stdio)
1390   {
1391    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1392    s->stdio  = stdio;
1393   }
1394  return f;
1395 }
1396
1397 PerlIO *
1398 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1399 {
1400  dTHX;
1401  PerlIO *f = NULL;
1402  FILE *stdio = PerlSIO_fopen(path,mode);
1403  if (stdio)
1404   {
1405    char tmode[8];
1406    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1407                                (mode = PerlIOStdio_mode(mode,tmode))),
1408                                PerlIOStdio);
1409    s->stdio  = stdio;
1410   }
1411  return f;
1412 }
1413
1414 int
1415 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1416 {
1417  dTHX;
1418  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1419  char tmode[8];
1420  FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1421  if (!s->stdio)
1422   return -1;
1423  s->stdio = stdio;
1424  return 0;
1425 }
1426
1427 SSize_t
1428 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1429 {
1430  dTHX;
1431  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1432  SSize_t got = 0;
1433  if (count == 1)
1434   {
1435    STDCHAR *buf = (STDCHAR *) vbuf;
1436    /* Perl is expecting PerlIO_getc() to fill the buffer
1437     * Linux's stdio does not do that for fread()
1438     */
1439    int ch = PerlSIO_fgetc(s);
1440    if (ch != EOF)
1441     {
1442      *buf = ch;
1443      got = 1;
1444     }
1445   }
1446  else
1447   got = PerlSIO_fread(vbuf,1,count,s);
1448  return got;
1449 }
1450
1451 SSize_t
1452 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1453 {
1454  dTHX;
1455  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1456  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1457  SSize_t unread = 0;
1458  while (count > 0)
1459   {
1460    int ch = *buf-- & 0xff;
1461    if (PerlSIO_ungetc(ch,s) != ch)
1462     break;
1463    unread++;
1464    count--;
1465   }
1466  return unread;
1467 }
1468
1469 SSize_t
1470 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1471 {
1472  dTHX;
1473  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1474 }
1475
1476 IV
1477 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1478 {
1479  dTHX;
1480  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1481  return PerlSIO_fseek(stdio,offset,whence);
1482 }
1483
1484 Off_t
1485 PerlIOStdio_tell(PerlIO *f)
1486 {
1487  dTHX;
1488  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1489  return PerlSIO_ftell(stdio);
1490 }
1491
1492 IV
1493 PerlIOStdio_close(PerlIO *f)
1494 {
1495  dTHX;
1496  int optval, optlen = sizeof(int);
1497  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1498  return(
1499    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1500        PerlSIO_fclose(stdio) :
1501        close(PerlIO_fileno(f)));
1502 }
1503
1504 IV
1505 PerlIOStdio_flush(PerlIO *f)
1506 {
1507  dTHX;
1508  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1509  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1510   {
1511    return PerlSIO_fflush(stdio);
1512   }
1513  else
1514   {
1515 #if 0
1516    /* FIXME: This discards ungetc() and pre-read stuff which is
1517       not right if this is just a "sync" from a layer above
1518       Suspect right design is to do _this_ but not have layer above
1519       flush this layer read-to-read
1520     */
1521    /* Not writeable - sync by attempting a seek */
1522    int err = errno;
1523    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1524     errno = err;
1525 #endif
1526   }
1527  return 0;
1528 }
1529
1530 IV
1531 PerlIOStdio_fill(PerlIO *f)
1532 {
1533  dTHX;
1534  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1535  int c;
1536  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1537  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1538   {
1539    if (PerlSIO_fflush(stdio) != 0)
1540     return EOF;
1541   }
1542  c = PerlSIO_fgetc(stdio);
1543  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1544   return EOF;
1545  return 0;
1546 }
1547
1548 IV
1549 PerlIOStdio_eof(PerlIO *f)
1550 {
1551  dTHX;
1552  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1553 }
1554
1555 IV
1556 PerlIOStdio_error(PerlIO *f)
1557 {
1558  dTHX;
1559  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1560 }
1561
1562 void
1563 PerlIOStdio_clearerr(PerlIO *f)
1564 {
1565  dTHX;
1566  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1567 }
1568
1569 void
1570 PerlIOStdio_setlinebuf(PerlIO *f)
1571 {
1572  dTHX;
1573 #ifdef HAS_SETLINEBUF
1574  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1575 #else
1576  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1577 #endif
1578 }
1579
1580 #ifdef FILE_base
1581 STDCHAR *
1582 PerlIOStdio_get_base(PerlIO *f)
1583 {
1584  dTHX;
1585  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1586  return PerlSIO_get_base(stdio);
1587 }
1588
1589 Size_t
1590 PerlIOStdio_get_bufsiz(PerlIO *f)
1591 {
1592  dTHX;
1593  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1594  return PerlSIO_get_bufsiz(stdio);
1595 }
1596 #endif
1597
1598 #ifdef USE_STDIO_PTR
1599 STDCHAR *
1600 PerlIOStdio_get_ptr(PerlIO *f)
1601 {
1602  dTHX;
1603  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1604  return PerlSIO_get_ptr(stdio);
1605 }
1606
1607 SSize_t
1608 PerlIOStdio_get_cnt(PerlIO *f)
1609 {
1610  dTHX;
1611  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1612  return PerlSIO_get_cnt(stdio);
1613 }
1614
1615 void
1616 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1617 {
1618  dTHX;
1619  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1620  if (ptr != NULL)
1621   {
1622 #ifdef STDIO_PTR_LVALUE
1623    PerlSIO_set_ptr(stdio,ptr);
1624 #ifdef STDIO_PTR_LVAL_SETS_CNT
1625    if (PerlSIO_get_cnt(stdio) != (cnt))
1626     {
1627      dTHX;
1628      assert(PerlSIO_get_cnt(stdio) == (cnt));
1629     }
1630 #endif
1631 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1632    /* Setting ptr _does_ change cnt - we are done */
1633    return;
1634 #endif
1635 #else  /* STDIO_PTR_LVALUE */
1636    PerlProc_abort();
1637 #endif /* STDIO_PTR_LVALUE */
1638   }
1639 /* Now (or only) set cnt */
1640 #ifdef STDIO_CNT_LVALUE
1641  PerlSIO_set_cnt(stdio,cnt);
1642 #else  /* STDIO_CNT_LVALUE */
1643 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1644  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1645 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1646  PerlProc_abort();
1647 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1648 #endif /* STDIO_CNT_LVALUE */
1649 }
1650
1651 #endif
1652
1653 PerlIO_funcs PerlIO_stdio = {
1654  "stdio",
1655  sizeof(PerlIOStdio),
1656  PERLIO_K_BUFFERED,
1657  PerlIOStdio_fileno,
1658  PerlIOStdio_fdopen,
1659  PerlIOStdio_open,
1660  PerlIOStdio_reopen,
1661  PerlIOBase_pushed,
1662  PerlIOBase_noop_ok,
1663  PerlIOStdio_read,
1664  PerlIOStdio_unread,
1665  PerlIOStdio_write,
1666  PerlIOStdio_seek,
1667  PerlIOStdio_tell,
1668  PerlIOStdio_close,
1669  PerlIOStdio_flush,
1670  PerlIOStdio_fill,
1671  PerlIOStdio_eof,
1672  PerlIOStdio_error,
1673  PerlIOStdio_clearerr,
1674  PerlIOStdio_setlinebuf,
1675 #ifdef FILE_base
1676  PerlIOStdio_get_base,
1677  PerlIOStdio_get_bufsiz,
1678 #else
1679  NULL,
1680  NULL,
1681 #endif
1682 #ifdef USE_STDIO_PTR
1683  PerlIOStdio_get_ptr,
1684  PerlIOStdio_get_cnt,
1685 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1686  PerlIOStdio_set_ptrcnt
1687 #else  /* STDIO_PTR_LVALUE */
1688  NULL
1689 #endif /* STDIO_PTR_LVALUE */
1690 #else  /* USE_STDIO_PTR */
1691  NULL,
1692  NULL,
1693  NULL
1694 #endif /* USE_STDIO_PTR */
1695 };
1696
1697 #undef PerlIO_exportFILE
1698 FILE *
1699 PerlIO_exportFILE(PerlIO *f, int fl)
1700 {
1701  PerlIO_flush(f);
1702  /* Should really push stdio discipline when we have them */
1703  return fdopen(PerlIO_fileno(f),"r+");
1704 }
1705
1706 #undef PerlIO_findFILE
1707 FILE *
1708 PerlIO_findFILE(PerlIO *f)
1709 {
1710  return PerlIO_exportFILE(f,0);
1711 }
1712
1713 #undef PerlIO_releaseFILE
1714 void
1715 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1716 {
1717 }
1718
1719 /*--------------------------------------------------------------------------------------*/
1720 /* perlio buffer layer */
1721
1722 IV
1723 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1724 {
1725  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1726  b->posn = PerlIO_tell(PerlIONext(f));
1727  return PerlIOBase_pushed(f,mode);
1728 }
1729
1730 PerlIO *
1731 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1732 {
1733  dTHX;
1734  PerlIO_funcs *tab = PerlIO_default_btm();
1735  int init = 0;
1736  PerlIO *f;
1737  if (*mode == 'I')
1738   {
1739    init = 1;
1740    mode++;
1741   }
1742 #if O_BINARY != O_TEXT
1743  /* do something about failing setmode()? --jhi */
1744  PerlLIO_setmode(fd, O_BINARY);
1745 #endif
1746  f = (*tab->Fdopen)(tab,fd,mode);
1747  if (f)
1748   {
1749    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1750    if (init && fd == 2)
1751     {
1752      /* Initial stderr is unbuffered */
1753      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1754     }
1755 #if 0
1756    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1757                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1758 #endif
1759   }
1760  return f;
1761 }
1762
1763 PerlIO *
1764 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1765 {
1766  PerlIO_funcs *tab = PerlIO_default_btm();
1767  PerlIO *f = (*tab->Open)(tab,path,mode);
1768  if (f)
1769   {
1770    PerlIO_push(f,self,mode);
1771   }
1772  return f;
1773 }
1774
1775 int
1776 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1777 {
1778  PerlIO *next = PerlIONext(f);
1779  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1780  if (code = 0)
1781   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1782  return code;
1783 }
1784
1785 /* This "flush" is akin to sfio's sync in that it handles files in either
1786    read or write state
1787 */
1788 IV
1789 PerlIOBuf_flush(PerlIO *f)
1790 {
1791  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1792  int code = 0;
1793  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1794   {
1795    /* write() the buffer */
1796    STDCHAR *p = b->buf;
1797    int count;
1798    PerlIO *n = PerlIONext(f);
1799    while (p < b->ptr)
1800     {
1801      count = PerlIO_write(n,p,b->ptr - p);
1802      if (count > 0)
1803       {
1804        p += count;
1805       }
1806      else if (count < 0 || PerlIO_error(n))
1807       {
1808        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1809        code = -1;
1810        break;
1811       }
1812     }
1813    b->posn += (p - b->buf);
1814   }
1815  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1816   {
1817    /* Note position change */
1818    b->posn += (b->ptr - b->buf);
1819    if (b->ptr < b->end)
1820     {
1821      /* We did not consume all of it */
1822      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1823       {
1824        b->posn = PerlIO_tell(PerlIONext(f));
1825       }
1826     }
1827   }
1828  b->ptr = b->end = b->buf;
1829  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1830  /* FIXME: Is this right for read case ? */
1831  if (PerlIO_flush(PerlIONext(f)) != 0)
1832   code = -1;
1833  return code;
1834 }
1835
1836 IV
1837 PerlIOBuf_fill(PerlIO *f)
1838 {
1839  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1840  PerlIO *n = PerlIONext(f);
1841  SSize_t avail;
1842  /* FIXME: doing the down-stream flush is a bad idea if it causes
1843     pre-read data in stdio buffer to be discarded
1844     but this is too simplistic - as it skips _our_ hosekeeping
1845     and breaks tell tests.
1846  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1847   {
1848   }
1849   */
1850  if (PerlIO_flush(f) != 0)
1851   return -1;
1852
1853  b->ptr = b->end = b->buf;
1854  if (PerlIO_fast_gets(n))
1855   {
1856    /* Layer below is also buffered
1857     * We do _NOT_ want to call its ->Read() because that will loop
1858     * till it gets what we asked for which may hang on a pipe etc.
1859     * Instead take anything it has to hand, or ask it to fill _once_.
1860     */
1861    avail  = PerlIO_get_cnt(n);
1862    if (avail <= 0)
1863     {
1864      avail = PerlIO_fill(n);
1865      if (avail == 0)
1866       avail = PerlIO_get_cnt(n);
1867      else
1868       {
1869        if (!PerlIO_error(n) && PerlIO_eof(n))
1870         avail = 0;
1871       }
1872     }
1873    if (avail > 0)
1874     {
1875      STDCHAR *ptr = PerlIO_get_ptr(n);
1876      SSize_t cnt  = avail;
1877      if (avail > b->bufsiz)
1878       avail = b->bufsiz;
1879      Copy(ptr,b->buf,avail,STDCHAR);
1880      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1881     }
1882   }
1883  else
1884   {
1885    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1886   }
1887  if (avail <= 0)
1888   {
1889    if (avail == 0)
1890     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1891    else
1892     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1893    return -1;
1894   }
1895  b->end      = b->buf+avail;
1896  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1897  return 0;
1898 }
1899
1900 SSize_t
1901 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1902 {
1903  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1904  STDCHAR *buf  = (STDCHAR *) vbuf;
1905  if (f)
1906   {
1907    if (!b->ptr)
1908     PerlIO_get_base(f);
1909    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1910     return 0;
1911    while (count > 0)
1912     {
1913      SSize_t avail = PerlIO_get_cnt(f);
1914      SSize_t take  = (count < avail) ? count : avail;
1915      if (take > 0)
1916       {
1917        STDCHAR *ptr = PerlIO_get_ptr(f);
1918        Copy(ptr,buf,take,STDCHAR);
1919        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1920        count   -= take;
1921        buf     += take;
1922       }
1923      if (count > 0  && avail <= 0)
1924       {
1925        if (PerlIO_fill(f) != 0)
1926         break;
1927       }
1928     }
1929    return (buf - (STDCHAR *) vbuf);
1930   }
1931  return 0;
1932 }
1933
1934 SSize_t
1935 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1936 {
1937  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1938  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1939  SSize_t unread = 0;
1940  SSize_t avail;
1941  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1942   PerlIO_flush(f);
1943  if (!b->buf)
1944   PerlIO_get_base(f);
1945  if (b->buf)
1946   {
1947    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1948     {
1949      avail = (b->ptr - b->buf);
1950     }
1951    else
1952     {
1953      avail = b->bufsiz;
1954      b->end = b->buf + avail;
1955      b->ptr = b->end;
1956      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1957      b->posn -= b->bufsiz;
1958     }
1959    if (avail > (SSize_t) count)
1960     avail = count;
1961    if (avail > 0)
1962     {
1963      b->ptr -= avail;
1964      buf    -= avail;
1965      if (buf != b->ptr)
1966       {
1967        Copy(buf,b->ptr,avail,STDCHAR);
1968       }
1969      count  -= avail;
1970      unread += avail;
1971      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1972     }
1973   }
1974  return unread;
1975 }
1976
1977 SSize_t
1978 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1979 {
1980  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1981  const STDCHAR *buf = (const STDCHAR *) vbuf;
1982  Size_t written = 0;
1983  if (!b->buf)
1984   PerlIO_get_base(f);
1985  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1986   return 0;
1987  while (count > 0)
1988   {
1989    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1990    if ((SSize_t) count < avail)
1991     avail = count;
1992    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1993    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1994     {
1995      while (avail > 0)
1996       {
1997        int ch = *buf++;
1998        *(b->ptr)++ = ch;
1999        count--;
2000        avail--;
2001        written++;
2002        if (ch == '\n')
2003         {
2004          PerlIO_flush(f);
2005          break;
2006         }
2007       }
2008     }
2009    else
2010     {
2011      if (avail)
2012       {
2013        Copy(buf,b->ptr,avail,STDCHAR);
2014        count   -= avail;
2015        buf     += avail;
2016        written += avail;
2017        b->ptr  += avail;
2018       }
2019     }
2020    if (b->ptr >= (b->buf + b->bufsiz))
2021     PerlIO_flush(f);
2022   }
2023  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2024   PerlIO_flush(f);
2025  return written;
2026 }
2027
2028 IV
2029 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2030 {
2031  IV code;
2032  if ((code = PerlIO_flush(f)) == 0)
2033   {
2034    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2035    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2036    code = PerlIO_seek(PerlIONext(f),offset,whence);
2037    if (code == 0)
2038     {
2039      b->posn = PerlIO_tell(PerlIONext(f));
2040     }
2041   }
2042  return code;
2043 }
2044
2045 Off_t
2046 PerlIOBuf_tell(PerlIO *f)
2047 {
2048  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2049  Off_t posn = b->posn;
2050  if (b->buf)
2051   posn += (b->ptr - b->buf);
2052  return posn;
2053 }
2054
2055 IV
2056 PerlIOBuf_close(PerlIO *f)
2057 {
2058  IV code = PerlIOBase_close(f);
2059  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2060  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2061   {
2062    Safefree(b->buf);
2063   }
2064  b->buf = NULL;
2065  b->ptr = b->end = b->buf;
2066  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2067  return code;
2068 }
2069
2070 void
2071 PerlIOBuf_setlinebuf(PerlIO *f)
2072 {
2073  if (f)
2074   {
2075    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2076   }
2077 }
2078
2079 STDCHAR *
2080 PerlIOBuf_get_ptr(PerlIO *f)
2081 {
2082  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2083  if (!b->buf)
2084   PerlIO_get_base(f);
2085  return b->ptr;
2086 }
2087
2088 SSize_t
2089 PerlIOBuf_get_cnt(PerlIO *f)
2090 {
2091  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2092  if (!b->buf)
2093   PerlIO_get_base(f);
2094  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2095   return (b->end - b->ptr);
2096  return 0;
2097 }
2098
2099 STDCHAR *
2100 PerlIOBuf_get_base(PerlIO *f)
2101 {
2102  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2103  if (!b->buf)
2104   {
2105    if (!b->bufsiz)
2106     b->bufsiz = 4096;
2107    New('B',b->buf,b->bufsiz,STDCHAR);
2108    if (!b->buf)
2109     {
2110      b->buf = (STDCHAR *)&b->oneword;
2111      b->bufsiz = sizeof(b->oneword);
2112     }
2113    b->ptr = b->buf;
2114    b->end = b->ptr;
2115   }
2116  return b->buf;
2117 }
2118
2119 Size_t
2120 PerlIOBuf_bufsiz(PerlIO *f)
2121 {
2122  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2123  if (!b->buf)
2124   PerlIO_get_base(f);
2125  return (b->end - b->buf);
2126 }
2127
2128 void
2129 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2130 {
2131  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2132  if (!b->buf)
2133   PerlIO_get_base(f);
2134  b->ptr = ptr;
2135  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2136   {
2137    dTHX;
2138    assert(PerlIO_get_cnt(f) == cnt);
2139    assert(b->ptr >= b->buf);
2140   }
2141  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2142 }
2143
2144 PerlIO_funcs PerlIO_perlio = {
2145  "perlio",
2146  sizeof(PerlIOBuf),
2147  PERLIO_K_BUFFERED,
2148  PerlIOBase_fileno,
2149  PerlIOBuf_fdopen,
2150  PerlIOBuf_open,
2151  PerlIOBuf_reopen,
2152  PerlIOBuf_pushed,
2153  PerlIOBase_noop_ok,
2154  PerlIOBuf_read,
2155  PerlIOBuf_unread,
2156  PerlIOBuf_write,
2157  PerlIOBuf_seek,
2158  PerlIOBuf_tell,
2159  PerlIOBuf_close,
2160  PerlIOBuf_flush,
2161  PerlIOBuf_fill,
2162  PerlIOBase_eof,
2163  PerlIOBase_error,
2164  PerlIOBase_clearerr,
2165  PerlIOBuf_setlinebuf,
2166  PerlIOBuf_get_base,
2167  PerlIOBuf_bufsiz,
2168  PerlIOBuf_get_ptr,
2169  PerlIOBuf_get_cnt,
2170  PerlIOBuf_set_ptrcnt,
2171 };
2172
2173 /*--------------------------------------------------------------------------------------*/
2174 /* Temp layer to hold unread chars when cannot do it any other way */
2175
2176 IV
2177 PerlIOPending_fill(PerlIO *f)
2178 {
2179  /* Should never happen */
2180  PerlIO_flush(f);
2181  return 0;
2182 }
2183
2184 IV
2185 PerlIOPending_close(PerlIO *f)
2186 {
2187  /* A tad tricky - flush pops us, then we close new top */
2188  PerlIO_flush(f);
2189  return PerlIO_close(f);
2190 }
2191
2192 IV
2193 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2194 {
2195  /* A tad tricky - flush pops us, then we seek new top */
2196  PerlIO_flush(f);
2197  return PerlIO_seek(f,offset,whence);
2198 }
2199
2200
2201 IV
2202 PerlIOPending_flush(PerlIO *f)
2203 {
2204  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2205  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2206   {
2207    Safefree(b->buf);
2208    b->buf = NULL;
2209   }
2210  PerlIO_pop(f);
2211  return 0;
2212 }
2213
2214 void
2215 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2216 {
2217  if (cnt <= 0)
2218   {
2219    PerlIO_flush(f);
2220   }
2221  else
2222   {
2223    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2224   }
2225 }
2226
2227 IV
2228 PerlIOPending_pushed(PerlIO *f,const char *mode)
2229 {
2230  IV code    = PerlIOBuf_pushed(f,mode);
2231  PerlIOl *l = PerlIOBase(f);
2232  /* Our PerlIO_fast_gets must match what we are pushed on,
2233     or sv_gets() etc. get muddled when it changes mid-string
2234     when we auto-pop.
2235   */
2236  l->flags   = (l->flags & ~PERLIO_F_FASTGETS) |
2237               (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2238  return code;
2239 }
2240
2241 SSize_t
2242 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2243 {
2244  SSize_t avail = PerlIO_get_cnt(f);
2245  SSize_t got   = 0;
2246  if (count < avail)
2247   avail = count;
2248  if (avail > 0)
2249   got = PerlIOBuf_read(f,vbuf,avail);
2250  if (got < count)
2251   got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2252  return got;
2253 }
2254
2255
2256 PerlIO_funcs PerlIO_pending = {
2257  "pending",
2258  sizeof(PerlIOBuf),
2259  PERLIO_K_BUFFERED,
2260  PerlIOBase_fileno,
2261  NULL,
2262  NULL,
2263  NULL,
2264  PerlIOPending_pushed,
2265  PerlIOBase_noop_ok,
2266  PerlIOPending_read,
2267  PerlIOBuf_unread,
2268  PerlIOBuf_write,
2269  PerlIOPending_seek,
2270  PerlIOBuf_tell,
2271  PerlIOPending_close,
2272  PerlIOPending_flush,
2273  PerlIOPending_fill,
2274  PerlIOBase_eof,
2275  PerlIOBase_error,
2276  PerlIOBase_clearerr,
2277  PerlIOBuf_setlinebuf,
2278  PerlIOBuf_get_base,
2279  PerlIOBuf_bufsiz,
2280  PerlIOBuf_get_ptr,
2281  PerlIOBuf_get_cnt,
2282  PerlIOPending_set_ptrcnt,
2283 };
2284
2285
2286
2287 /*--------------------------------------------------------------------------------------*/
2288 /* crlf - translation
2289    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2290    to hand back a line at a time and keeping a record of which nl we "lied" about.
2291    On write translate "\n" to CR,LF
2292  */
2293
2294 typedef struct
2295 {
2296  PerlIOBuf      base;         /* PerlIOBuf stuff */
2297  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2298 } PerlIOCrlf;
2299
2300 IV
2301 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2302 {
2303  IV code;
2304  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2305  code = PerlIOBuf_pushed(f,mode);
2306 #if 0
2307  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2308               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2309               PerlIOBase(f)->flags);
2310 #endif
2311  return code;
2312 }
2313
2314
2315 SSize_t
2316 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2317 {
2318  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2319  if (c->nl)
2320   {
2321    *(c->nl) = 0xd;
2322    c->nl = NULL;
2323   }
2324  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2325   return PerlIOBuf_unread(f,vbuf,count);
2326  else
2327   {
2328    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2329    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2330    SSize_t unread = 0;
2331    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2332     PerlIO_flush(f);
2333    if (!b->buf)
2334     PerlIO_get_base(f);
2335    if (b->buf)
2336     {
2337      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2338       {
2339        b->end = b->ptr = b->buf + b->bufsiz;
2340        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2341        b->posn -= b->bufsiz;
2342       }
2343      while (count > 0 && b->ptr > b->buf)
2344       {
2345        int ch = *--buf;
2346        if (ch == '\n')
2347         {
2348          if (b->ptr - 2 >= b->buf)
2349           {
2350            *--(b->ptr) = 0xa;
2351            *--(b->ptr) = 0xd;
2352            unread++;
2353            count--;
2354           }
2355          else
2356           {
2357            buf++;
2358            break;
2359           }
2360         }
2361        else
2362         {
2363          *--(b->ptr) = ch;
2364          unread++;
2365          count--;
2366         }
2367       }
2368     }
2369    return unread;
2370   }
2371 }
2372
2373 SSize_t
2374 PerlIOCrlf_get_cnt(PerlIO *f)
2375 {
2376  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2377  if (!b->buf)
2378   PerlIO_get_base(f);
2379  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2380   {
2381    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2382    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2383     {
2384      STDCHAR *nl   = b->ptr;
2385     scan:
2386      while (nl < b->end && *nl != 0xd)
2387       nl++;
2388      if (nl < b->end && *nl == 0xd)
2389       {
2390      test:
2391        if (nl+1 < b->end)
2392         {
2393          if (nl[1] == 0xa)
2394           {
2395            *nl   = '\n';
2396            c->nl = nl;
2397           }
2398          else
2399           {
2400            /* Not CR,LF but just CR */
2401            nl++;
2402            goto scan;
2403           }
2404         }
2405        else
2406         {
2407          /* Blast - found CR as last char in buffer */
2408          if (b->ptr < nl)
2409           {
2410            /* They may not care, defer work as long as possible */
2411            return (nl - b->ptr);
2412           }
2413          else
2414           {
2415            int code;
2416            dTHX;
2417            b->ptr++;               /* say we have read it as far as flush() is concerned */
2418            b->buf++;               /* Leave space an front of buffer */
2419            b->bufsiz--;            /* Buffer is thus smaller */
2420            code = PerlIO_fill(f);  /* Fetch some more */
2421            b->bufsiz++;            /* Restore size for next time */
2422            b->buf--;               /* Point at space */
2423            b->ptr = nl = b->buf;   /* Which is what we hand off */
2424            b->posn--;              /* Buffer starts here */
2425            *nl = 0xd;              /* Fill in the CR */
2426            if (code == 0)
2427             goto test;             /* fill() call worked */
2428            /* CR at EOF - just fall through */
2429           }
2430         }
2431       }
2432     }
2433    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2434   }
2435  return 0;
2436 }
2437
2438 void
2439 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2440 {
2441  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2442  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2443  IV flags = PerlIOBase(f)->flags;
2444  if (!b->buf)
2445   PerlIO_get_base(f);
2446  if (!ptr)
2447   {
2448    if (c->nl)
2449     ptr = c->nl+1;
2450    else
2451     {
2452      ptr = b->end;
2453      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2454       ptr--;
2455     }
2456    ptr -= cnt;
2457   }
2458  else
2459   {
2460    /* Test code - delete when it works ... */
2461    STDCHAR *chk;
2462    if (c->nl)
2463     chk = c->nl+1;
2464    else
2465     {
2466      chk = b->end;
2467      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2468       chk--;
2469     }
2470    chk -= cnt;
2471
2472    if (ptr != chk)
2473     {
2474      dTHX;
2475      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2476                 ptr, chk, flags, c->nl, b->end, cnt);
2477     }
2478   }
2479  if (c->nl)
2480   {
2481    if (ptr > c->nl)
2482     {
2483      /* They have taken what we lied about */
2484      *(c->nl) = 0xd;
2485      c->nl = NULL;
2486      ptr++;
2487     }
2488   }
2489  b->ptr = ptr;
2490  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2491 }
2492
2493 SSize_t
2494 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2495 {
2496  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2497   return PerlIOBuf_write(f,vbuf,count);
2498  else
2499   {
2500    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2501    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2502    const STDCHAR *ebuf = buf+count;
2503    if (!b->buf)
2504     PerlIO_get_base(f);
2505    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2506     return 0;
2507    while (buf < ebuf)
2508     {
2509      STDCHAR *eptr = b->buf+b->bufsiz;
2510      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2511      while (buf < ebuf && b->ptr < eptr)
2512       {
2513        if (*buf == '\n')
2514         {
2515          if ((b->ptr + 2) > eptr)
2516           {
2517            /* Not room for both */
2518            PerlIO_flush(f);
2519            break;
2520           }
2521          else
2522           {
2523            *(b->ptr)++ = 0xd; /* CR */
2524            *(b->ptr)++ = 0xa; /* LF */
2525            buf++;
2526            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2527             {
2528              PerlIO_flush(f);
2529              break;
2530             }
2531           }
2532         }
2533        else
2534         {
2535          int ch = *buf++;
2536          *(b->ptr)++ = ch;
2537         }
2538        if (b->ptr >= eptr)
2539         {
2540          PerlIO_flush(f);
2541          break;
2542         }
2543       }
2544     }
2545    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2546     PerlIO_flush(f);
2547    return (buf - (STDCHAR *) vbuf);
2548   }
2549 }
2550
2551 IV
2552 PerlIOCrlf_flush(PerlIO *f)
2553 {
2554  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2555  if (c->nl)
2556   {
2557    *(c->nl) = 0xd;
2558    c->nl = NULL;
2559   }
2560  return PerlIOBuf_flush(f);
2561 }
2562
2563 PerlIO_funcs PerlIO_crlf = {
2564  "crlf",
2565  sizeof(PerlIOCrlf),
2566  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2567  PerlIOBase_fileno,
2568  PerlIOBuf_fdopen,
2569  PerlIOBuf_open,
2570  PerlIOBuf_reopen,
2571  PerlIOCrlf_pushed,
2572  PerlIOBase_noop_ok,   /* popped */
2573  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2574  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2575  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2576  PerlIOBuf_seek,
2577  PerlIOBuf_tell,
2578  PerlIOBuf_close,
2579  PerlIOCrlf_flush,
2580  PerlIOBuf_fill,
2581  PerlIOBase_eof,
2582  PerlIOBase_error,
2583  PerlIOBase_clearerr,
2584  PerlIOBuf_setlinebuf,
2585  PerlIOBuf_get_base,
2586  PerlIOBuf_bufsiz,
2587  PerlIOBuf_get_ptr,
2588  PerlIOCrlf_get_cnt,
2589  PerlIOCrlf_set_ptrcnt,
2590 };
2591
2592 #ifdef HAS_MMAP
2593 /*--------------------------------------------------------------------------------------*/
2594 /* mmap as "buffer" layer */
2595
2596 typedef struct
2597 {
2598  PerlIOBuf      base;         /* PerlIOBuf stuff */
2599  Mmap_t         mptr;        /* Mapped address */
2600  Size_t         len;          /* mapped length */
2601  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2602 } PerlIOMmap;
2603
2604 static size_t page_size = 0;
2605
2606 IV
2607 PerlIOMmap_map(PerlIO *f)
2608 {
2609  dTHX;
2610  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2611  PerlIOBuf  *b = &m->base;
2612  IV flags = PerlIOBase(f)->flags;
2613  IV code  = 0;
2614  if (m->len)
2615   abort();
2616  if (flags & PERLIO_F_CANREAD)
2617   {
2618    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2619    int fd   = PerlIO_fileno(f);
2620    struct stat st;
2621    code = fstat(fd,&st);
2622    if (code == 0 && S_ISREG(st.st_mode))
2623     {
2624      SSize_t len = st.st_size - b->posn;
2625      if (len > 0)
2626       {
2627        Off_t posn;
2628        if (!page_size) {
2629 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2630            {
2631                SETERRNO(0,SS$_NORMAL);
2632 #   ifdef _SC_PAGESIZE
2633                page_size = sysconf(_SC_PAGESIZE);
2634 #   else
2635                page_size = sysconf(_SC_PAGE_SIZE);
2636 #   endif
2637                if ((long)page_size < 0) {
2638                    if (errno) {
2639                        SV *error = ERRSV;
2640                        char *msg;
2641                        STRLEN n_a;
2642                        (void)SvUPGRADE(error, SVt_PV);
2643                        msg = SvPVx(error, n_a);
2644                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2645                    }
2646                    else
2647                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2648                }
2649            }
2650 #else
2651 #   ifdef HAS_GETPAGESIZE
2652         page_size = getpagesize();
2653 #   else
2654 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2655         page_size = PAGESIZE; /* compiletime, bad */
2656 #       endif
2657 #   endif
2658 #endif
2659         if ((IV)page_size <= 0)
2660             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2661        }
2662        if (b->posn < 0)
2663         {
2664          /* This is a hack - should never happen - open should have set it ! */
2665          b->posn = PerlIO_tell(PerlIONext(f));
2666         }
2667        posn = (b->posn / page_size) * page_size;
2668        len  = st.st_size - posn;
2669        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2670        if (m->mptr && m->mptr != (Mmap_t) -1)
2671         {
2672 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2673          madvise(m->mptr, len, MADV_SEQUENTIAL);
2674 #endif
2675          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2676          b->end  = ((STDCHAR *)m->mptr) + len;
2677          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2678          b->ptr  = b->buf;
2679          m->len  = len;
2680         }
2681        else
2682         {
2683          b->buf = NULL;
2684         }
2685       }
2686      else
2687       {
2688        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2689        b->buf = NULL;
2690        b->ptr = b->end = b->ptr;
2691        code = -1;
2692       }
2693     }
2694   }
2695  return code;
2696 }
2697
2698 IV
2699 PerlIOMmap_unmap(PerlIO *f)
2700 {
2701  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2702  PerlIOBuf  *b = &m->base;
2703  IV code = 0;
2704  if (m->len)
2705   {
2706    if (b->buf)
2707     {
2708      code = munmap(m->mptr, m->len);
2709      b->buf  = NULL;
2710      m->len  = 0;
2711      m->mptr = NULL;
2712      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2713       code = -1;
2714     }
2715    b->ptr = b->end = b->buf;
2716    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2717   }
2718  return code;
2719 }
2720
2721 STDCHAR *
2722 PerlIOMmap_get_base(PerlIO *f)
2723 {
2724  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2725  PerlIOBuf  *b = &m->base;
2726  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2727   {
2728    /* Already have a readbuffer in progress */
2729    return b->buf;
2730   }
2731  if (b->buf)
2732   {
2733    /* We have a write buffer or flushed PerlIOBuf read buffer */
2734    m->bbuf = b->buf;  /* save it in case we need it again */
2735    b->buf  = NULL;    /* Clear to trigger below */
2736   }
2737  if (!b->buf)
2738   {
2739    PerlIOMmap_map(f);     /* Try and map it */
2740    if (!b->buf)
2741     {
2742      /* Map did not work - recover PerlIOBuf buffer if we have one */
2743      b->buf = m->bbuf;
2744     }
2745   }
2746  b->ptr  = b->end = b->buf;
2747  if (b->buf)
2748   return b->buf;
2749  return PerlIOBuf_get_base(f);
2750 }
2751
2752 SSize_t
2753 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2754 {
2755  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2756  PerlIOBuf  *b = &m->base;
2757  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2758   PerlIO_flush(f);
2759  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2760   {
2761    b->ptr -= count;
2762    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2763    return count;
2764   }
2765  if (m->len)
2766   {
2767    /* Loose the unwritable mapped buffer */
2768    PerlIO_flush(f);
2769    /* If flush took the "buffer" see if we have one from before */
2770    if (!b->buf && m->bbuf)
2771     b->buf = m->bbuf;
2772    if (!b->buf)
2773     {
2774      PerlIOBuf_get_base(f);
2775      m->bbuf = b->buf;
2776     }
2777   }
2778 return PerlIOBuf_unread(f,vbuf,count);
2779 }
2780
2781 SSize_t
2782 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2783 {
2784  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2785  PerlIOBuf  *b = &m->base;
2786  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2787   {
2788    /* No, or wrong sort of, buffer */
2789    if (m->len)
2790     {
2791      if (PerlIOMmap_unmap(f) != 0)
2792       return 0;
2793     }
2794    /* If unmap took the "buffer" see if we have one from before */
2795    if (!b->buf && m->bbuf)
2796     b->buf = m->bbuf;
2797    if (!b->buf)
2798     {
2799      PerlIOBuf_get_base(f);
2800      m->bbuf = b->buf;
2801     }
2802   }
2803  return PerlIOBuf_write(f,vbuf,count);
2804 }
2805
2806 IV
2807 PerlIOMmap_flush(PerlIO *f)
2808 {
2809  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2810  PerlIOBuf  *b = &m->base;
2811  IV code = PerlIOBuf_flush(f);
2812  /* Now we are "synced" at PerlIOBuf level */
2813  if (b->buf)
2814   {
2815    if (m->len)
2816     {
2817      /* Unmap the buffer */
2818      if (PerlIOMmap_unmap(f) != 0)
2819       code = -1;
2820     }
2821    else
2822     {
2823      /* We seem to have a PerlIOBuf buffer which was not mapped
2824       * remember it in case we need one later
2825       */
2826      m->bbuf = b->buf;
2827     }
2828   }
2829  return code;
2830 }
2831
2832 IV
2833 PerlIOMmap_fill(PerlIO *f)
2834 {
2835  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2836  IV code = PerlIO_flush(f);
2837  if (code == 0 && !b->buf)
2838   {
2839    code = PerlIOMmap_map(f);
2840   }
2841  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2842   {
2843    code = PerlIOBuf_fill(f);
2844   }
2845  return code;
2846 }
2847
2848 IV
2849 PerlIOMmap_close(PerlIO *f)
2850 {
2851  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2852  PerlIOBuf  *b = &m->base;
2853  IV code = PerlIO_flush(f);
2854  if (m->bbuf)
2855   {
2856    b->buf  = m->bbuf;
2857    m->bbuf = NULL;
2858    b->ptr  = b->end = b->buf;
2859   }
2860  if (PerlIOBuf_close(f) != 0)
2861   code = -1;
2862  return code;
2863 }
2864
2865
2866 PerlIO_funcs PerlIO_mmap = {
2867  "mmap",
2868  sizeof(PerlIOMmap),
2869  PERLIO_K_BUFFERED,
2870  PerlIOBase_fileno,
2871  PerlIOBuf_fdopen,
2872  PerlIOBuf_open,
2873  PerlIOBuf_reopen,
2874  PerlIOBuf_pushed,
2875  PerlIOBase_noop_ok,
2876  PerlIOBuf_read,
2877  PerlIOMmap_unread,
2878  PerlIOMmap_write,
2879  PerlIOBuf_seek,
2880  PerlIOBuf_tell,
2881  PerlIOBuf_close,
2882  PerlIOMmap_flush,
2883  PerlIOMmap_fill,
2884  PerlIOBase_eof,
2885  PerlIOBase_error,
2886  PerlIOBase_clearerr,
2887  PerlIOBuf_setlinebuf,
2888  PerlIOMmap_get_base,
2889  PerlIOBuf_bufsiz,
2890  PerlIOBuf_get_ptr,
2891  PerlIOBuf_get_cnt,
2892  PerlIOBuf_set_ptrcnt,
2893 };
2894
2895 #endif /* HAS_MMAP */
2896
2897 void
2898 PerlIO_init(void)
2899 {
2900  if (!_perlio)
2901   {
2902    atexit(&PerlIO_cleanup);
2903   }
2904 }
2905
2906 #undef PerlIO_stdin
2907 PerlIO *
2908 PerlIO_stdin(void)
2909 {
2910  if (!_perlio)
2911   PerlIO_stdstreams();
2912  return &_perlio[1];
2913 }
2914
2915 #undef PerlIO_stdout
2916 PerlIO *
2917 PerlIO_stdout(void)
2918 {
2919  if (!_perlio)
2920   PerlIO_stdstreams();
2921  return &_perlio[2];
2922 }
2923
2924 #undef PerlIO_stderr
2925 PerlIO *
2926 PerlIO_stderr(void)
2927 {
2928  if (!_perlio)
2929   PerlIO_stdstreams();
2930  return &_perlio[3];
2931 }
2932
2933 /*--------------------------------------------------------------------------------------*/
2934
2935 #undef PerlIO_getname
2936 char *
2937 PerlIO_getname(PerlIO *f, char *buf)
2938 {
2939  dTHX;
2940  Perl_croak(aTHX_ "Don't know how to get file name");
2941  return NULL;
2942 }
2943
2944
2945 /*--------------------------------------------------------------------------------------*/
2946 /* Functions which can be called on any kind of PerlIO implemented
2947    in terms of above
2948 */
2949
2950 #undef PerlIO_getc
2951 int
2952 PerlIO_getc(PerlIO *f)
2953 {
2954  STDCHAR buf[1];
2955  SSize_t count = PerlIO_read(f,buf,1);
2956  if (count == 1)
2957   {
2958    return (unsigned char) buf[0];
2959   }
2960  return EOF;
2961 }
2962
2963 #undef PerlIO_ungetc
2964 int
2965 PerlIO_ungetc(PerlIO *f, int ch)
2966 {
2967  if (ch != EOF)
2968   {
2969    STDCHAR buf = ch;
2970    if (PerlIO_unread(f,&buf,1) == 1)
2971     return ch;
2972   }
2973  return EOF;
2974 }
2975
2976 #undef PerlIO_putc
2977 int
2978 PerlIO_putc(PerlIO *f, int ch)
2979 {
2980  STDCHAR buf = ch;
2981  return PerlIO_write(f,&buf,1);
2982 }
2983
2984 #undef PerlIO_puts
2985 int
2986 PerlIO_puts(PerlIO *f, const char *s)
2987 {
2988  STRLEN len = strlen(s);
2989  return PerlIO_write(f,s,len);
2990 }
2991
2992 #undef PerlIO_rewind
2993 void
2994 PerlIO_rewind(PerlIO *f)
2995 {
2996  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2997  PerlIO_clearerr(f);
2998 }
2999
3000 #undef PerlIO_vprintf
3001 int
3002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3003 {
3004  dTHX;
3005  SV *sv = newSVpvn("",0);
3006  char *s;
3007  STRLEN len;
3008 #ifdef NEED_VA_COPY
3009  va_list apc;
3010  Perl_va_copy(ap, apc);
3011  sv_vcatpvf(sv, fmt, &apc);
3012 #else
3013  sv_vcatpvf(sv, fmt, &ap);
3014 #endif
3015  s = SvPV(sv,len);
3016  return PerlIO_write(f,s,len);
3017 }
3018
3019 #undef PerlIO_printf
3020 int
3021 PerlIO_printf(PerlIO *f,const char *fmt,...)
3022 {
3023  va_list ap;
3024  int result;
3025  va_start(ap,fmt);
3026  result = PerlIO_vprintf(f,fmt,ap);
3027  va_end(ap);
3028  return result;
3029 }
3030
3031 #undef PerlIO_stdoutf
3032 int
3033 PerlIO_stdoutf(const char *fmt,...)
3034 {
3035  va_list ap;
3036  int result;
3037  va_start(ap,fmt);
3038  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3039  va_end(ap);
3040  return result;
3041 }
3042
3043 #undef PerlIO_tmpfile
3044 PerlIO *
3045 PerlIO_tmpfile(void)
3046 {
3047  /* I have no idea how portable mkstemp() is ... */
3048 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3049  dTHX;
3050  PerlIO *f = NULL;
3051  FILE *stdio = PerlSIO_tmpfile();
3052  if (stdio)
3053   {
3054    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
3055    s->stdio  = stdio;
3056   }
3057  return f;
3058 #else
3059  dTHX;
3060  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3061  int fd = mkstemp(SvPVX(sv));
3062  PerlIO *f = NULL;
3063  if (fd >= 0)
3064   {
3065    f = PerlIO_fdopen(fd,"w+");
3066    if (f)
3067     {
3068      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3069     }
3070    PerlLIO_unlink(SvPVX(sv));
3071    SvREFCNT_dec(sv);
3072   }
3073  return f;
3074 #endif
3075 }
3076
3077 #undef HAS_FSETPOS
3078 #undef HAS_FGETPOS
3079
3080 #endif /* USE_SFIO */
3081 #endif /* PERLIO_IS_STDIO */
3082
3083 /*======================================================================================*/
3084 /* Now some functions in terms of above which may be needed even if
3085    we are not in true PerlIO mode
3086  */
3087
3088 #ifndef HAS_FSETPOS
3089 #undef PerlIO_setpos
3090 int
3091 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3092 {
3093  return PerlIO_seek(f,*pos,0);
3094 }
3095 #else
3096 #ifndef PERLIO_IS_STDIO
3097 #undef PerlIO_setpos
3098 int
3099 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3100 {
3101 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3102  return fsetpos64(f, pos);
3103 #else
3104  return fsetpos(f, pos);
3105 #endif
3106 }
3107 #endif
3108 #endif
3109
3110 #ifndef HAS_FGETPOS
3111 #undef PerlIO_getpos
3112 int
3113 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3114 {
3115  *pos = PerlIO_tell(f);
3116  return *pos == -1 ? -1 : 0;
3117 }
3118 #else
3119 #ifndef PERLIO_IS_STDIO
3120 #undef PerlIO_getpos
3121 int
3122 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3123 {
3124 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3125  return fgetpos64(f, pos);
3126 #else
3127  return fgetpos(f, pos);
3128 #endif
3129 }
3130 #endif
3131 #endif
3132
3133 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3134
3135 int
3136 vprintf(char *pat, char *args)
3137 {
3138     _doprnt(pat, args, stdout);
3139     return 0;           /* wrong, but perl doesn't use the return value */
3140 }
3141
3142 int
3143 vfprintf(FILE *fd, char *pat, char *args)
3144 {
3145     _doprnt(pat, args, fd);
3146     return 0;           /* wrong, but perl doesn't use the return value */
3147 }
3148
3149 #endif
3150
3151 #ifndef PerlIO_vsprintf
3152 int
3153 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3154 {
3155  int val = vsprintf(s, fmt, ap);
3156  if (n >= 0)
3157   {
3158    if (strlen(s) >= (STRLEN)n)
3159     {
3160      dTHX;
3161      (void)PerlIO_puts(Perl_error_log,
3162                        "panic: sprintf overflow - memory corrupted!\n");
3163      my_exit(1);
3164     }
3165   }
3166  return val;
3167 }
3168 #endif
3169
3170 #ifndef PerlIO_sprintf
3171 int
3172 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3173 {
3174  va_list ap;
3175  int result;
3176  va_start(ap,fmt);
3177  result = PerlIO_vsprintf(s, n, fmt, ap);
3178  va_end(ap);
3179  return result;
3180 }
3181 #endif
3182
3183