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