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 iperlsys.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 #endif
  44
  45 #if !defined(PERL_IMPLICIT_SYS)
  46
  47 #ifdef PERLIO_IS_STDIO
  48
  49 void
  50 PerlIO_init(void)
  51 {
  52  /* Does nothing (yet) except force this file to be included
  53     in perl binary. That allows this file to force inclusion
  54     of other functions that may be required by loadable
  55     extensions e.g. for FileHandle::tmpfile
  56  */
  57 }
  58
  59 #undef PerlIO_tmpfile
  60 PerlIO *
  61 PerlIO_tmpfile(void)
  62 {
  63  return tmpfile();
  64 }
  65
  66 #else /* PERLIO_IS_STDIO */
  67
  68 #ifdef USE_SFIO
  69
  70 #undef HAS_FSETPOS
  71 #undef HAS_FGETPOS
  72
  73 /* This section is just to make sure these functions
  74    get pulled in from libsfio.a
  75 */
  76
  77 #undef PerlIO_tmpfile
  78 PerlIO *
  79 PerlIO_tmpfile(void)
  80 {
  81  return sftmp(0);
  82 }
  83
  84 void
  85 PerlIO_init(void)
  86 {
  87  /* Force this file to be included  in perl binary. Which allows
  88   *  this file to force inclusion  of other functions that may be
  89   *  required by loadable  extensions e.g. for FileHandle::tmpfile
  90   */
  91
  92  /* Hack
  93   * sfio does its own 'autoflush' on stdout in common cases.
  94   * Flush results in a lot of lseek()s to regular files and
  95   * lot of small writes to pipes.
  96   */
  97  sfset(sfstdout,SF_SHARE,0);
  98 }
  99
 100 #else /* USE_SFIO */
 101 /*======================================================================================*/
 102 /* Implement all the PerlIO interface ourselves.
 103  */
 104
 105 #include "perliol.h"
 106
 107 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 108 #ifdef I_UNISTD
 109 #include <unistd.h>
 110 #endif
 111 #ifdef HAS_MMAP
 112 #include <sys/mman.h>
 113 #endif
 114
 115 #include "XSUB.h"
 116
 117 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
 118
 119 void
 120 PerlIO_debug(char *fmt,...)
 121 {
 122  static int dbg = 0;
 123  if (!dbg)
 124   {
 125    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 126    if (s && *s)
 127     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 128    else
 129     dbg = -1;
 130   }
 131  if (dbg > 0)
 132   {
 133    dTHX;
 134    va_list ap;
 135    SV *sv = newSVpvn("",0);
 136    char *s;
 137    STRLEN len;
 138    va_start(ap,fmt);
 139    s = CopFILE(PL_curcop);
 140    if (!s)
 141     s = "(none)";
 142    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 143    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 144
 145    s = SvPV(sv,len);
 146    PerlLIO_write(dbg,s,len);
 147    va_end(ap);
 148    SvREFCNT_dec(sv);
 149   }
 150 }
 151
 152 /*--------------------------------------------------------------------------------------*/
 153
 154 /* Inner level routines */
 155
 156 /* Table of pointers to the PerlIO structs (malloc'ed) */
 157 PerlIO *_perlio      = NULL;
 158 #define PERLIO_TABLE_SIZE 64
 159
 160 PerlIO *
 161 PerlIO_allocate(void)
 162 {
 163  /* Find a free slot in the table, allocating new table as necessary */
 164  PerlIO **last = &_perlio;
 165  PerlIO *f;
 166  while ((f = *last))
 167   {
 168    int i;
 169    last = (PerlIO **)(f);
 170    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 171     {
 172      if (!*++f)
 173       {
 174        return f;
 175       }
 176     }
 177   }
 178  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 179  if (!f)
 180   return NULL;
 181  *last = f;
 182  return f+1;
 183 }
 184
 185 void
 186 PerlIO_cleantable(PerlIO **tablep)
 187 {
 188  PerlIO *table = *tablep;
 189  if (table)
 190   {
 191    int i;
 192    PerlIO_cleantable((PerlIO **) &(table[0]));
 193    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 194     {
 195      PerlIO *f = table+i;
 196      if (*f)
 197       PerlIO_close(f);
 198     }
 199    Safefree(table);
 200    *tablep = NULL;
 201   }
 202 }
 203
 204 HV *PerlIO_layer_hv;
 205 AV *PerlIO_layer_av;
 206
 207 void
 208 PerlIO_cleanup(void)
 209 {
 210  PerlIO_cleantable(&_perlio);
 211 }
 212
 213 void
 214 PerlIO_pop(PerlIO *f)
 215 {
 216  PerlIOl *l = *f;
 217  if (l)
 218   {
 219    (*l->tab->Popped)(f);
 220    *f = l->next;
 221    Safefree(l);
 222   }
 223 }
 224
 225 /*--------------------------------------------------------------------------------------*/
 226 /* XS Interface for perl code */
 227
 228 XS(XS_perlio_import)
 229 {
 230  dXSARGS;
 231  GV *gv = CvGV(cv);
 232  char *s = GvNAME(gv);
 233  STRLEN l = GvNAMELEN(gv);
 234  PerlIO_debug("%.*s\n",(int) l,s);
 235  XSRETURN_EMPTY;
 236 }
 237
 238 XS(XS_perlio_unimport)
 239 {
 240  dXSARGS;
 241  GV *gv = CvGV(cv);
 242  char *s = GvNAME(gv);
 243  STRLEN l = GvNAMELEN(gv);
 244  PerlIO_debug("%.*s\n",(int) l,s);
 245  XSRETURN_EMPTY;
 246 }
 247
 248 SV *
 249 PerlIO_find_layer(const char *name, STRLEN len)
 250 {
 251  dTHX;
 252  SV **svp;
 253  SV *sv;
 254  if (len <= 0)
 255   len = strlen(name);
 256  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 257  if (svp && (sv = *svp) && SvROK(sv))
 258   return *svp;
 259  return NULL;
 260 }
 261
 262
 263 static int
 264 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 265 {
 266  if (SvROK(sv))
 267   {
 268    IO *io = GvIOn((GV *)SvRV(sv));
 269    PerlIO *ifp = IoIFP(io);
 270    PerlIO *ofp = IoOFP(io);
 271    AV *av = (AV *) mg->mg_obj;
 272    Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
 273   }
 274  return 0;
 275 }
 276
 277 static int
 278 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 279 {
 280  if (SvROK(sv))
 281   {
 282    IO *io = GvIOn((GV *)SvRV(sv));
 283    PerlIO *ifp = IoIFP(io);
 284    PerlIO *ofp = IoOFP(io);
 285    AV *av = (AV *) mg->mg_obj;
 286    Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
 287   }
 288  return 0;
 289 }
 290
 291 static int
 292 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 293 {
 294  Perl_warn(aTHX_ "clear %_",sv);
 295  return 0;
 296 }
 297
 298 static int
 299 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 300 {
 301  Perl_warn(aTHX_ "free %_",sv);
 302  return 0;
 303 }
 304
 305 MGVTBL perlio_vtab = {
 306  perlio_mg_get,
 307  perlio_mg_set,
 308  NULL, /* len */
 309  NULL,
 310  perlio_mg_free
 311 };
 312
 313 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 314 {
 315  dXSARGS;
 316  SV *sv    = SvRV(ST(1));
 317  AV *av    = newAV();
 318  MAGIC *mg;
 319  int count = 0;
 320  int i;
 321  sv_magic(sv, (SV *)av, '~', NULL, 0);
 322  SvRMAGICAL_off(sv);
 323  mg = mg_find(sv,'~');
 324  mg->mg_virtual = &perlio_vtab;
 325  mg_magical(sv);
 326  Perl_warn(aTHX_ "attrib %_",sv);
 327  for (i=2; i < items; i++)
 328   {
 329    STRLEN len;
 330    const char *name = SvPV(ST(i),len);
 331    SV *layer  = PerlIO_find_layer(name,len);
 332    if (layer)
 333     {
 334      av_push(av,SvREFCNT_inc(layer));
 335     }
 336    else
 337     {
 338      ST(count) = ST(i);
 339      count++;
 340     }
 341   }
 342  SvREFCNT_dec(av);
 343  XSRETURN(count);
 344 }
 345
 346 void
 347 PerlIO_define_layer(PerlIO_funcs *tab)
 348 {
 349  dTHX;
 350  HV *stash = gv_stashpv("perlio::Layer", TRUE);
 351  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 352  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 353 }
 354
 355 PerlIO_funcs *
 356 PerlIO_default_layer(I32 n)
 357 {
 358  dTHX;
 359  SV **svp;
 360  SV *layer;
 361  PerlIO_funcs *tab = &PerlIO_stdio;
 362  int len;
 363  if (!PerlIO_layer_hv)
 364   {
 365    const char *s  = PerlEnv_getenv("PERLIO");
 366    newXS("perlio::import",XS_perlio_import,__FILE__);
 367    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 368 #if 0
 369    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 370 #endif
 371    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 372    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 373    PerlIO_define_layer(&PerlIO_unix);
 374    PerlIO_define_layer(&PerlIO_perlio);
 375    PerlIO_define_layer(&PerlIO_stdio);
 376 #ifdef HAS_MMAP
 377    PerlIO_define_layer(&PerlIO_mmap);
 378 #endif
 379    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 380    if (s)
 381     {
 382      while (*s)
 383       {
 384        while (*s && isSPACE((unsigned char)*s))
 385         s++;
 386        if (*s)
 387         {
 388          const char *e = s;
 389          SV *layer;
 390          while (*e && !isSPACE((unsigned char)*e))
 391           e++;
 392          if (*s == ':')
 393           s++;
 394          layer = PerlIO_find_layer(s,e-s);
 395          if (layer)
 396           {
 397            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 398            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 399           }
 400          else
 401           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 402          s = e;
 403         }
 404       }
 405     }
 406   }
 407  len  = av_len(PerlIO_layer_av);
 408  if (len < 1)
 409   {
 410    if (PerlIO_stdio.Set_ptrcnt)
 411     {
 412      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 413     }
 414    else
 415     {
 416      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 417     }
 418    len  = av_len(PerlIO_layer_av);
 419   }
 420  if (n < 0)
 421   n += len+1;
 422  svp = av_fetch(PerlIO_layer_av,n,0);
 423  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 424   {
 425    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 426   }
 427  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 428  return tab;
 429 }
 430
 431 int
 432 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 433 {
 434  if (names)
 435   {
 436    const char *s = names;
 437    while (*s)
 438     {
 439      while (isSPACE(*s))
 440       s++;
 441      if (*s == ':')
 442       s++;
 443      if (*s)
 444       {
 445        const char *e = s;
 446        while (*e && *e != ':' && !isSPACE(*e))
 447         e++;
 448        if (e > s)
 449         {
 450          SV *layer = PerlIO_find_layer(s,e-s);
 451          if (layer)
 452           {
 453            PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 454            if (tab)
 455             {
 456              PerlIO *new = PerlIO_push(f,tab,mode);
 457              if (!new)
 458               return -1;
 459             }
 460           }
 461          else
 462           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 463         }
 464        s = e;
 465       }
 466     }
 467   }
 468  return 0;
 469 }
 470
 471 #define PerlIO_default_top() PerlIO_default_layer(-1)
 472 #define PerlIO_default_btm() PerlIO_default_layer(0)
 473
 474 void
 475 PerlIO_stdstreams()
 476 {
 477  if (!_perlio)
 478   {
 479    PerlIO_allocate();
 480    PerlIO_fdopen(0,"Ir");
 481    PerlIO_fdopen(1,"Iw");
 482    PerlIO_fdopen(2,"Iw");
 483   }
 484 }
 485
 486 PerlIO *
 487 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 488 {
 489  PerlIOl *l = NULL;
 490  Newc('L',l,tab->size,char,PerlIOl);
 491  if (l)
 492   {
 493    Zero(l,tab->size,char);
 494    l->next = *f;
 495    l->tab  = tab;
 496    *f      = l;
 497    if ((*l->tab->Pushed)(f,mode) != 0)
 498     {
 499      PerlIO_pop(f);
 500      return NULL;
 501     }
 502   }
 503  return f;
 504 }
 505
 506 /*--------------------------------------------------------------------------------------*/
 507 /* Given the abstraction above the public API functions */
 508
 509 #undef PerlIO_close
 510 int
 511 PerlIO_close(PerlIO *f)
 512 {
 513  int code = (*PerlIOBase(f)->tab->Close)(f);
 514  while (*f)
 515   {
 516    PerlIO_pop(f);
 517   }
 518  return code;
 519 }
 520
 521 #undef PerlIO_fileno
 522 int
 523 PerlIO_fileno(PerlIO *f)
 524 {
 525  return (*PerlIOBase(f)->tab->Fileno)(f);
 526 }
 527
 528
 529
 530 #undef PerlIO_fdopen
 531 PerlIO *
 532 PerlIO_fdopen(int fd, const char *mode)
 533 {
 534  PerlIO_funcs *tab = PerlIO_default_top();
 535  if (!_perlio)
 536   PerlIO_stdstreams();
 537  return (*tab->Fdopen)(tab,fd,mode);
 538 }
 539
 540 #undef PerlIO_open
 541 PerlIO *
 542 PerlIO_open(const char *path, const char *mode)
 543 {
 544  PerlIO_funcs *tab = PerlIO_default_top();
 545  if (!_perlio)
 546   PerlIO_stdstreams();
 547  return (*tab->Open)(tab,path,mode);
 548 }
 549
 550 #undef PerlIO_reopen
 551 PerlIO *
 552 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 553 {
 554  if (f)
 555   {
 556    PerlIO_flush(f);
 557    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 558     {
 559      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 560       return f;
 561     }
 562    return NULL;
 563   }
 564  else
 565   return PerlIO_open(path,mode);
 566 }
 567
 568 #undef PerlIO_read
 569 SSize_t
 570 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 571 {
 572  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 573 }
 574
 575 #undef PerlIO_unread
 576 SSize_t
 577 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 578 {
 579  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 580 }
 581
 582 #undef PerlIO_write
 583 SSize_t
 584 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 585 {
 586  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 587 }
 588
 589 #undef PerlIO_seek
 590 int
 591 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 592 {
 593  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 594 }
 595
 596 #undef PerlIO_tell
 597 Off_t
 598 PerlIO_tell(PerlIO *f)
 599 {
 600  return (*PerlIOBase(f)->tab->Tell)(f);
 601 }
 602
 603 #undef PerlIO_flush
 604 int
 605 PerlIO_flush(PerlIO *f)
 606 {
 607  if (f)
 608   {
 609    return (*PerlIOBase(f)->tab->Flush)(f);
 610   }
 611  else
 612   {
 613    PerlIO **table = &_perlio;
 614    int code = 0;
 615    while ((f = *table))
 616     {
 617      int i;
 618      table = (PerlIO **)(f++);
 619      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 620       {
 621        if (*f && PerlIO_flush(f) != 0)
 622         code = -1;
 623        f++;
 624       }
 625     }
 626    return code;
 627   }
 628 }
 629
 630 #undef PerlIO_fill
 631 int
 632 PerlIO_fill(PerlIO *f)
 633 {
 634  return (*PerlIOBase(f)->tab->Fill)(f);
 635 }
 636
 637 #undef PerlIO_isutf8
 638 int
 639 PerlIO_isutf8(PerlIO *f)
 640 {
 641  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 642 }
 643
 644 #undef PerlIO_eof
 645 int
 646 PerlIO_eof(PerlIO *f)
 647 {
 648  return (*PerlIOBase(f)->tab->Eof)(f);
 649 }
 650
 651 #undef PerlIO_error
 652 int
 653 PerlIO_error(PerlIO *f)
 654 {
 655  return (*PerlIOBase(f)->tab->Error)(f);
 656 }
 657
 658 #undef PerlIO_clearerr
 659 void
 660 PerlIO_clearerr(PerlIO *f)
 661 {
 662  (*PerlIOBase(f)->tab->Clearerr)(f);
 663 }
 664
 665 #undef PerlIO_setlinebuf
 666 void
 667 PerlIO_setlinebuf(PerlIO *f)
 668 {
 669  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 670 }
 671
 672 #undef PerlIO_has_base
 673 int
 674 PerlIO_has_base(PerlIO *f)
 675 {
 676  if (f && *f)
 677   {
 678    return (PerlIOBase(f)->tab->Get_base != NULL);
 679   }
 680  return 0;
 681 }
 682
 683 #undef PerlIO_fast_gets
 684 int
 685 PerlIO_fast_gets(PerlIO *f)
 686 {
 687  if (f && *f)
 688   {
 689    PerlIOl *l = PerlIOBase(f);
 690    return (l->tab->Set_ptrcnt != NULL);
 691   }
 692  return 0;
 693 }
 694
 695 #undef PerlIO_has_cntptr
 696 int
 697 PerlIO_has_cntptr(PerlIO *f)
 698 {
 699  if (f && *f)
 700   {
 701    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 702    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 703   }
 704  return 0;
 705 }
 706
 707 #undef PerlIO_canset_cnt
 708 int
 709 PerlIO_canset_cnt(PerlIO *f)
 710 {
 711  if (f && *f)
 712   {
 713    PerlIOl *l = PerlIOBase(f);
 714    return (l->tab->Set_ptrcnt != NULL);
 715   }
 716  return 0;
 717 }
 718
 719 #undef PerlIO_get_base
 720 STDCHAR *
 721 PerlIO_get_base(PerlIO *f)
 722 {
 723  return (*PerlIOBase(f)->tab->Get_base)(f);
 724 }
 725
 726 #undef PerlIO_get_bufsiz
 727 int
 728 PerlIO_get_bufsiz(PerlIO *f)
 729 {
 730  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 731 }
 732
 733 #undef PerlIO_get_ptr
 734 STDCHAR *
 735 PerlIO_get_ptr(PerlIO *f)
 736 {
 737  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 738 }
 739
 740 #undef PerlIO_get_cnt
 741 int
 742 PerlIO_get_cnt(PerlIO *f)
 743 {
 744  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 745 }
 746
 747 #undef PerlIO_set_cnt
 748 void
 749 PerlIO_set_cnt(PerlIO *f,int cnt)
 750 {
 751  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 752 }
 753
 754 #undef PerlIO_set_ptrcnt
 755 void
 756 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 757 {
 758  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 759 }
 760
 761 /*--------------------------------------------------------------------------------------*/
 762 /* "Methods" of the "base class" */
 763
 764 IV
 765 PerlIOBase_fileno(PerlIO *f)
 766 {
 767  return PerlIO_fileno(PerlIONext(f));
 768 }
 769
 770 IV
 771 PerlIOBase_pushed(PerlIO *f, const char *mode)
 772 {
 773  PerlIOl *l = PerlIOBase(f);
 774  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 775                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 776  if (mode)
 777   {
 778    switch (*mode++)
 779     {
 780      case 'r':
 781       l->flags = PERLIO_F_CANREAD;
 782       break;
 783      case 'a':
 784       l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 785       break;
 786      case 'w':
 787       l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 788       break;
 789      default:
 790       errno = EINVAL;
 791       return -1;
 792     }
 793    while (*mode)
 794     {
 795      switch (*mode++)
 796       {
 797        case '+':
 798         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 799         break;
 800        case 'b':
 801         l->flags |= PERLIO_F_BINARY;
 802         break;
 803       default:
 804        errno = EINVAL;
 805        return -1;
 806       }
 807     }
 808   }
 809  else
 810   {
 811    if (l->next)
 812     {
 813      l->flags |= l->next->flags &
 814                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 815                    PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 816     }
 817   }
 818  return 0;
 819 }
 820
 821 IV
 822 PerlIOBase_popped(PerlIO *f)
 823 {
 824  return 0;
 825 }
 826
 827 SSize_t
 828 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 829 {
 830  Off_t old = PerlIO_tell(f);
 831  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 832   {
 833    Off_t new = PerlIO_tell(f);
 834    return old - new;
 835   }
 836  return 0;
 837 }
 838
 839 IV
 840 PerlIOBase_noop_ok(PerlIO *f)
 841 {
 842  return 0;
 843 }
 844
 845 IV
 846 PerlIOBase_noop_fail(PerlIO *f)
 847 {
 848  return -1;
 849 }
 850
 851 IV
 852 PerlIOBase_close(PerlIO *f)
 853 {
 854  IV code = 0;
 855  if (PerlIO_flush(f) != 0)
 856   code = -1;
 857  if (PerlIO_close(PerlIONext(f)) != 0)
 858   code = -1;
 859  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 860  return code;
 861 }
 862
 863 IV
 864 PerlIOBase_eof(PerlIO *f)
 865 {
 866  if (f && *f)
 867   {
 868    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
 869   }
 870  return 1;
 871 }
 872
 873 IV
 874 PerlIOBase_error(PerlIO *f)
 875 {
 876  if (f && *f)
 877   {
 878    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
 879   }
 880  return 1;
 881 }
 882
 883 void
 884 PerlIOBase_clearerr(PerlIO *f)
 885 {
 886  if (f && *f)
 887   {
 888    PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
 889   }
 890 }
 891
 892 void
 893 PerlIOBase_setlinebuf(PerlIO *f)
 894 {
 895
 896 }
 897
 898 /*--------------------------------------------------------------------------------------*/
 899 /* Bottom-most level for UNIX-like case */
 900
 901 typedef struct
 902 {
 903  struct _PerlIO base;       /* The generic part */
 904  int            fd;         /* UNIX like file descriptor */
 905  int            oflags;     /* open/fcntl flags */
 906 } PerlIOUnix;
 907
 908 int
 909 PerlIOUnix_oflags(const char *mode)
 910 {
 911  int oflags = -1;
 912  switch(*mode)
 913   {
 914    case 'r':
 915     oflags = O_RDONLY;
 916     if (*++mode == '+')
 917      {
 918       oflags = O_RDWR;
 919       mode++;
 920      }
 921     break;
 922
 923    case 'w':
 924     oflags = O_CREAT|O_TRUNC;
 925     if (*++mode == '+')
 926      {
 927       oflags |= O_RDWR;
 928       mode++;
 929      }
 930     else
 931      oflags |= O_WRONLY;
 932     break;
 933
 934    case 'a':
 935     oflags = O_CREAT|O_APPEND;
 936     if (*++mode == '+')
 937      {
 938       oflags |= O_RDWR;
 939       mode++;
 940      }
 941     else
 942      oflags |= O_WRONLY;
 943     break;
 944   }
 945  if (*mode || oflags == -1)
 946   {
 947    errno = EINVAL;
 948    oflags = -1;
 949   }
 950  return oflags;
 951 }
 952
 953 IV
 954 PerlIOUnix_fileno(PerlIO *f)
 955 {
 956  return PerlIOSelf(f,PerlIOUnix)->fd;
 957 }
 958
 959 PerlIO *
 960 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 961 {
 962  PerlIO *f = NULL;
 963  if (*mode == 'I')
 964   mode++;
 965  if (fd >= 0)
 966   {
 967    int oflags = PerlIOUnix_oflags(mode);
 968    if (oflags != -1)
 969     {
 970      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 971      s->fd     = fd;
 972      s->oflags = oflags;
 973      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 974     }
 975   }
 976  return f;
 977 }
 978
 979 PerlIO *
 980 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
 981 {
 982  PerlIO *f = NULL;
 983  int oflags = PerlIOUnix_oflags(mode);
 984  if (oflags != -1)
 985   {
 986    int fd = PerlLIO_open3(path,oflags,0666);
 987    if (fd >= 0)
 988     {
 989      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 990      s->fd     = fd;
 991      s->oflags = oflags;
 992      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 993     }
 994   }
 995  return f;
 996 }
 997
 998 int
 999 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1000 {
1001  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1002  int oflags = PerlIOUnix_oflags(mode);
1003  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1004   (*PerlIOBase(f)->tab->Close)(f);
1005  if (oflags != -1)
1006   {
1007    int fd = PerlLIO_open3(path,oflags,0666);
1008    if (fd >= 0)
1009     {
1010      s->fd = fd;
1011      s->oflags = oflags;
1012      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1013      return 0;
1014     }
1015   }
1016  return -1;
1017 }
1018
1019 SSize_t
1020 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1021 {
1022  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1023  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1024   return 0;
1025  while (1)
1026   {
1027    SSize_t len = PerlLIO_read(fd,vbuf,count);
1028    if (len >= 0 || errno != EINTR)
1029     {
1030      if (len < 0)
1031       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1032      else if (len == 0 && count != 0)
1033       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1034      return len;
1035     }
1036   }
1037 }
1038
1039 SSize_t
1040 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1041 {
1042  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1043  while (1)
1044   {
1045    SSize_t len = PerlLIO_write(fd,vbuf,count);
1046    if (len >= 0 || errno != EINTR)
1047     {
1048      if (len < 0)
1049       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1050      return len;
1051     }
1052   }
1053 }
1054
1055 IV
1056 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1057 {
1058  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1059  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1060  return (new == (Off_t) -1) ? -1 : 0;
1061 }
1062
1063 Off_t
1064 PerlIOUnix_tell(PerlIO *f)
1065 {
1066  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1067 }
1068
1069 IV
1070 PerlIOUnix_close(PerlIO *f)
1071 {
1072  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1073  int code = 0;
1074  while (PerlLIO_close(fd) != 0)
1075   {
1076    if (errno != EINTR)
1077     {
1078      code = -1;
1079      break;
1080     }
1081   }
1082  if (code == 0)
1083   {
1084    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1085   }
1086  return code;
1087 }
1088
1089 PerlIO_funcs PerlIO_unix = {
1090  "unix",
1091  sizeof(PerlIOUnix),
1092  0,
1093  PerlIOUnix_fileno,
1094  PerlIOUnix_fdopen,
1095  PerlIOUnix_open,
1096  PerlIOUnix_reopen,
1097  PerlIOBase_pushed,
1098  PerlIOBase_noop_ok,
1099  PerlIOUnix_read,
1100  PerlIOBase_unread,
1101  PerlIOUnix_write,
1102  PerlIOUnix_seek,
1103  PerlIOUnix_tell,
1104  PerlIOUnix_close,
1105  PerlIOBase_noop_ok,   /* flush */
1106  PerlIOBase_noop_fail, /* fill */
1107  PerlIOBase_eof,
1108  PerlIOBase_error,
1109  PerlIOBase_clearerr,
1110  PerlIOBase_setlinebuf,
1111  NULL, /* get_base */
1112  NULL, /* get_bufsiz */
1113  NULL, /* get_ptr */
1114  NULL, /* get_cnt */
1115  NULL, /* set_ptrcnt */
1116 };
1117
1118 /*--------------------------------------------------------------------------------------*/
1119 /* stdio as a layer */
1120
1121 typedef struct
1122 {
1123  struct _PerlIO base;
1124  FILE *         stdio;      /* The stream */
1125 } PerlIOStdio;
1126
1127 IV
1128 PerlIOStdio_fileno(PerlIO *f)
1129 {
1130  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1131 }
1132
1133
1134 PerlIO *
1135 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1136 {
1137  PerlIO *f = NULL;
1138  int init = 0;
1139  if (*mode == 'I')
1140   {
1141    init = 1;
1142    mode++;
1143   }
1144  if (fd >= 0)
1145   {
1146    FILE *stdio = NULL;
1147    if (init)
1148     {
1149      switch(fd)
1150       {
1151        case 0:
1152         stdio = stdin;
1153         break;
1154        case 1:
1155         stdio = stdout;
1156         break;
1157        case 2:
1158         stdio = stderr;
1159         break;
1160       }
1161     }
1162    else
1163     stdio = fdopen(fd,mode);
1164    if (stdio)
1165     {
1166      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1167      s->stdio  = stdio;
1168     }
1169   }
1170  return f;
1171 }
1172
1173 #undef PerlIO_importFILE
1174 PerlIO *
1175 PerlIO_importFILE(FILE *stdio, int fl)
1176 {
1177  PerlIO *f = NULL;
1178  if (stdio)
1179   {
1180    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1181    s->stdio  = stdio;
1182   }
1183  return f;
1184 }
1185
1186 PerlIO *
1187 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1188 {
1189  PerlIO *f = NULL;
1190  FILE *stdio = fopen(path,mode);
1191  if (stdio)
1192   {
1193    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1194    s->stdio  = stdio;
1195   }
1196  return f;
1197 }
1198
1199 int
1200 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1201 {
1202  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1203  FILE *stdio = freopen(path,mode,s->stdio);
1204  if (!s->stdio)
1205   return -1;
1206  s->stdio = stdio;
1207  return 0;
1208 }
1209
1210 SSize_t
1211 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1212 {
1213  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1214  SSize_t got = 0;
1215  if (count == 1)
1216   {
1217    STDCHAR *buf = (STDCHAR *) vbuf;
1218    /* Perl is expecting PerlIO_getc() to fill the buffer
1219     * Linux's stdio does not do that for fread()
1220     */
1221    int ch = fgetc(s);
1222    if (ch != EOF)
1223     {
1224      *buf = ch;
1225      got = 1;
1226     }
1227   }
1228  else
1229   got = fread(vbuf,1,count,s);
1230  return got;
1231 }
1232
1233 SSize_t
1234 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1235 {
1236  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1237  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1238  SSize_t unread = 0;
1239  while (count > 0)
1240   {
1241    int ch = *buf-- & 0xff;
1242    if (ungetc(ch,s) != ch)
1243     break;
1244    unread++;
1245    count--;
1246   }
1247  return unread;
1248 }
1249
1250 SSize_t
1251 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1252 {
1253  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1254 }
1255
1256 IV
1257 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1258 {
1259  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1260  return fseek(stdio,offset,whence);
1261 }
1262
1263 Off_t
1264 PerlIOStdio_tell(PerlIO *f)
1265 {
1266  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1267  return ftell(stdio);
1268 }
1269
1270 IV
1271 PerlIOStdio_close(PerlIO *f)
1272 {
1273  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1274 }
1275
1276 IV
1277 PerlIOStdio_flush(PerlIO *f)
1278 {
1279  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280  return fflush(stdio);
1281 }
1282
1283 IV
1284 PerlIOStdio_fill(PerlIO *f)
1285 {
1286  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1287  int c;
1288  if (fflush(stdio) != 0)
1289   return EOF;
1290  c = fgetc(stdio);
1291  if (c == EOF || ungetc(c,stdio) != c)
1292   return EOF;
1293  return 0;
1294 }
1295
1296 IV
1297 PerlIOStdio_eof(PerlIO *f)
1298 {
1299  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1300 }
1301
1302 IV
1303 PerlIOStdio_error(PerlIO *f)
1304 {
1305  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1306 }
1307
1308 void
1309 PerlIOStdio_clearerr(PerlIO *f)
1310 {
1311  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1312 }
1313
1314 void
1315 PerlIOStdio_setlinebuf(PerlIO *f)
1316 {
1317 #ifdef HAS_SETLINEBUF
1318  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1319 #else
1320  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1321 #endif
1322 }
1323
1324 #ifdef FILE_base
1325 STDCHAR *
1326 PerlIOStdio_get_base(PerlIO *f)
1327 {
1328  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1329  return FILE_base(stdio);
1330 }
1331
1332 Size_t
1333 PerlIOStdio_get_bufsiz(PerlIO *f)
1334 {
1335  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1336  return FILE_bufsiz(stdio);
1337 }
1338 #endif
1339
1340 #ifdef USE_STDIO_PTR
1341 STDCHAR *
1342 PerlIOStdio_get_ptr(PerlIO *f)
1343 {
1344  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1345  return FILE_ptr(stdio);
1346 }
1347
1348 SSize_t
1349 PerlIOStdio_get_cnt(PerlIO *f)
1350 {
1351  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1352  return FILE_cnt(stdio);
1353 }
1354
1355 void
1356 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1357 {
1358  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1359  if (ptr != NULL)
1360   {
1361 #ifdef STDIO_PTR_LVALUE
1362    FILE_ptr(stdio) = ptr;
1363 #ifdef STDIO_PTR_LVAL_SETS_CNT
1364    if (FILE_cnt(stdio) != (cnt))
1365     {
1366      dTHX;
1367      assert(FILE_cnt(stdio) == (cnt));
1368     }
1369 #endif
1370 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1371    /* Setting ptr _does_ change cnt - we are done */
1372    return;
1373 #endif
1374 #else  /* STDIO_PTR_LVALUE */
1375    abort();
1376 #endif /* STDIO_PTR_LVALUE */
1377   }
1378 /* Now (or only) set cnt */
1379 #ifdef STDIO_CNT_LVALUE
1380  FILE_cnt(stdio) = cnt;
1381 #else  /* STDIO_CNT_LVALUE */
1382 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1383  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1384 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1385  abort();
1386 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1387 #endif /* STDIO_CNT_LVALUE */
1388 }
1389
1390 #endif
1391
1392 PerlIO_funcs PerlIO_stdio = {
1393  "stdio",
1394  sizeof(PerlIOStdio),
1395  0,
1396  PerlIOStdio_fileno,
1397  PerlIOStdio_fdopen,
1398  PerlIOStdio_open,
1399  PerlIOStdio_reopen,
1400  PerlIOBase_pushed,
1401  PerlIOBase_noop_ok,
1402  PerlIOStdio_read,
1403  PerlIOStdio_unread,
1404  PerlIOStdio_write,
1405  PerlIOStdio_seek,
1406  PerlIOStdio_tell,
1407  PerlIOStdio_close,
1408  PerlIOStdio_flush,
1409  PerlIOStdio_fill,
1410  PerlIOStdio_eof,
1411  PerlIOStdio_error,
1412  PerlIOStdio_clearerr,
1413  PerlIOStdio_setlinebuf,
1414 #ifdef FILE_base
1415  PerlIOStdio_get_base,
1416  PerlIOStdio_get_bufsiz,
1417 #else
1418  NULL,
1419  NULL,
1420 #endif
1421 #ifdef USE_STDIO_PTR
1422  PerlIOStdio_get_ptr,
1423  PerlIOStdio_get_cnt,
1424 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1425  PerlIOStdio_set_ptrcnt
1426 #else  /* STDIO_PTR_LVALUE */
1427  NULL
1428 #endif /* STDIO_PTR_LVALUE */
1429 #else  /* USE_STDIO_PTR */
1430  NULL,
1431  NULL,
1432  NULL
1433 #endif /* USE_STDIO_PTR */
1434 };
1435
1436 #undef PerlIO_exportFILE
1437 FILE *
1438 PerlIO_exportFILE(PerlIO *f, int fl)
1439 {
1440  PerlIO_flush(f);
1441  /* Should really push stdio discipline when we have them */
1442  return fdopen(PerlIO_fileno(f),"r+");
1443 }
1444
1445 #undef PerlIO_findFILE
1446 FILE *
1447 PerlIO_findFILE(PerlIO *f)
1448 {
1449  return PerlIO_exportFILE(f,0);
1450 }
1451
1452 #undef PerlIO_releaseFILE
1453 void
1454 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1455 {
1456 }
1457
1458 /*--------------------------------------------------------------------------------------*/
1459 /* perlio buffer layer */
1460
1461 PerlIO *
1462 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1463 {
1464  PerlIO_funcs *tab = PerlIO_default_btm();
1465  int init = 0;
1466  PerlIO *f;
1467  if (*mode == 'I')
1468   {
1469    init = 1;
1470    mode++;
1471   }
1472  f = (*tab->Fdopen)(tab,fd,mode);
1473  if (f)
1474   {
1475    /* Initial stderr is unbuffered */
1476    if (!init || fd != 2)
1477     {
1478      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1479      b->posn = PerlIO_tell(PerlIONext(f));
1480     }
1481   }
1482  return f;
1483 }
1484
1485 PerlIO *
1486 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1487 {
1488  PerlIO_funcs *tab = PerlIO_default_btm();
1489  PerlIO *f = (*tab->Open)(tab,path,mode);
1490  if (f)
1491   {
1492    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1493    b->posn = PerlIO_tell(PerlIONext(f));
1494   }
1495  return f;
1496 }
1497
1498 int
1499 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1500 {
1501  PerlIO *next = PerlIONext(f);
1502  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1503  if (code = 0)
1504   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1505  if (code == 0)
1506   {
1507    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1508    b->posn = PerlIO_tell(PerlIONext(f));
1509   }
1510  return code;
1511 }
1512
1513 /* This "flush" is akin to sfio's sync in that it handles files in either
1514    read or write state
1515 */
1516 IV
1517 PerlIOBuf_flush(PerlIO *f)
1518 {
1519  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1520  int code = 0;
1521  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1522   {
1523    /* write() the buffer */
1524    STDCHAR *p = b->buf;
1525    int count;
1526    while (p < b->ptr)
1527     {
1528      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1529      if (count > 0)
1530       {
1531        p += count;
1532       }
1533      else if (count < 0)
1534       {
1535        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1536        code = -1;
1537        break;
1538       }
1539     }
1540    b->posn += (p - b->buf);
1541   }
1542  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1543   {
1544    /* Note position change */
1545    b->posn += (b->ptr - b->buf);
1546    if (b->ptr < b->end)
1547     {
1548      /* We did not consume all of it */
1549      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1550       {
1551        b->posn = PerlIO_tell(PerlIONext(f));
1552       }
1553     }
1554   }
1555  b->ptr = b->end = b->buf;
1556  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1557  if (PerlIO_flush(PerlIONext(f)) != 0)
1558   code = -1;
1559  return code;
1560 }
1561
1562 IV
1563 PerlIOBuf_fill(PerlIO *f)
1564 {
1565  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1566  SSize_t avail;
1567  if (PerlIO_flush(f) != 0)
1568   return -1;
1569  b->ptr = b->end = b->buf;
1570  avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1571  if (avail <= 0)
1572   {
1573    if (avail == 0)
1574     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1575    else
1576     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1577    return -1;
1578   }
1579  b->end      = b->buf+avail;
1580  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1581  return 0;
1582 }
1583
1584 SSize_t
1585 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1586 {
1587  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1588  STDCHAR *buf = (STDCHAR *) vbuf;
1589  if (f)
1590   {
1591    Size_t got = 0;
1592    if (!b->ptr)
1593     PerlIO_get_base(f);
1594    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1595     return 0;
1596    while (count > 0)
1597     {
1598      SSize_t avail = (b->end - b->ptr);
1599      if ((SSize_t) count < avail)
1600       avail = count;
1601      if (avail > 0)
1602       {
1603        Copy(b->ptr,buf,avail,char);
1604        got     += avail;
1605        b->ptr  += avail;
1606        count   -= avail;
1607        buf     += avail;
1608       }
1609      if (count && (b->ptr >= b->end))
1610       {
1611        if (PerlIO_fill(f) != 0)
1612         break;
1613       }
1614     }
1615    return got;
1616   }
1617  return 0;
1618 }
1619
1620 SSize_t
1621 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1622 {
1623  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1624  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1625  SSize_t unread = 0;
1626  SSize_t avail;
1627  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1628   PerlIO_flush(f);
1629  if (!b->buf)
1630   PerlIO_get_base(f);
1631  if (b->buf)
1632   {
1633    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1634     {
1635      avail = (b->ptr - b->buf);
1636      if (avail > (SSize_t) count)
1637       avail = count;
1638      b->ptr -= avail;
1639     }
1640    else
1641     {
1642      avail = b->bufsiz;
1643      if (avail > (SSize_t) count)
1644       avail = count;
1645      b->end = b->ptr + avail;
1646     }
1647    if (avail > 0)
1648     {
1649      buf    -= avail;
1650      if (buf != b->ptr)
1651       {
1652        Copy(buf,b->ptr,avail,char);
1653       }
1654      count  -= avail;
1655      unread += avail;
1656      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1657     }
1658   }
1659  return unread;
1660 }
1661
1662 SSize_t
1663 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1664 {
1665  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1666  const STDCHAR *buf = (const STDCHAR *) vbuf;
1667  Size_t written = 0;
1668  if (!b->buf)
1669   PerlIO_get_base(f);
1670  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1671   return 0;
1672  while (count > 0)
1673   {
1674    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1675    if ((SSize_t) count < avail)
1676     avail = count;
1677    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1678    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1679     {
1680      while (avail > 0)
1681       {
1682        int ch = *buf++;
1683        *(b->ptr)++ = ch;
1684        count--;
1685        avail--;
1686        written++;
1687        if (ch == '\n')
1688         {
1689          PerlIO_flush(f);
1690          break;
1691         }
1692       }
1693     }
1694    else
1695     {
1696      if (avail)
1697       {
1698        Copy(buf,b->ptr,avail,char);
1699        count   -= avail;
1700        buf     += avail;
1701        written += avail;
1702        b->ptr  += avail;
1703       }
1704     }
1705    if (b->ptr >= (b->buf + b->bufsiz))
1706     PerlIO_flush(f);
1707   }
1708  return written;
1709 }
1710
1711 IV
1712 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1713 {
1714  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1715  int code = PerlIO_flush(f);
1716  if (code == 0)
1717   {
1718    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1719    code = PerlIO_seek(PerlIONext(f),offset,whence);
1720    if (code == 0)
1721     {
1722      b->posn = PerlIO_tell(PerlIONext(f));
1723     }
1724   }
1725  return code;
1726 }
1727
1728 Off_t
1729 PerlIOBuf_tell(PerlIO *f)
1730 {
1731  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1732  Off_t posn = b->posn;
1733  if (b->buf)
1734   posn += (b->ptr - b->buf);
1735  return posn;
1736 }
1737
1738 IV
1739 PerlIOBuf_close(PerlIO *f)
1740 {
1741  IV code = PerlIOBase_close(f);
1742  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1743  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1744   {
1745    Safefree(b->buf);
1746   }
1747  b->buf = NULL;
1748  b->ptr = b->end = b->buf;
1749  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1750  return code;
1751 }
1752
1753 void
1754 PerlIOBuf_setlinebuf(PerlIO *f)
1755 {
1756  if (f)
1757   {
1758    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1759   }
1760 }
1761
1762 STDCHAR *
1763 PerlIOBuf_get_ptr(PerlIO *f)
1764 {
1765  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1766  if (!b->buf)
1767   PerlIO_get_base(f);
1768  return b->ptr;
1769 }
1770
1771 SSize_t
1772 PerlIOBuf_get_cnt(PerlIO *f)
1773 {
1774  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1775  if (!b->buf)
1776   PerlIO_get_base(f);
1777  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1778   return (b->end - b->ptr);
1779  return 0;
1780 }
1781
1782 STDCHAR *
1783 PerlIOBuf_get_base(PerlIO *f)
1784 {
1785  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1786  if (!b->buf)
1787   {
1788    if (!b->bufsiz)
1789     b->bufsiz = 4096;
1790    New('B',b->buf,b->bufsiz,STDCHAR);
1791    if (!b->buf)
1792     {
1793      b->buf = (STDCHAR *)&b->oneword;
1794      b->bufsiz = sizeof(b->oneword);
1795     }
1796    b->ptr = b->buf;
1797    b->end = b->ptr;
1798   }
1799  return b->buf;
1800 }
1801
1802 Size_t
1803 PerlIOBuf_bufsiz(PerlIO *f)
1804 {
1805  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1806  if (!b->buf)
1807   PerlIO_get_base(f);
1808  return (b->end - b->buf);
1809 }
1810
1811 void
1812 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1813 {
1814  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1815  if (!b->buf)
1816   PerlIO_get_base(f);
1817  b->ptr = ptr;
1818  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1819   {
1820    dTHX;
1821    assert(PerlIO_get_cnt(f) == cnt);
1822    assert(b->ptr >= b->buf);
1823   }
1824  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1825 }
1826
1827 PerlIO_funcs PerlIO_perlio = {
1828  "perlio",
1829  sizeof(PerlIOBuf),
1830  0,
1831  PerlIOBase_fileno,
1832  PerlIOBuf_fdopen,
1833  PerlIOBuf_open,
1834  PerlIOBuf_reopen,
1835  PerlIOBase_pushed,
1836  PerlIOBase_noop_ok,
1837  PerlIOBuf_read,
1838  PerlIOBuf_unread,
1839  PerlIOBuf_write,
1840  PerlIOBuf_seek,
1841  PerlIOBuf_tell,
1842  PerlIOBuf_close,
1843  PerlIOBuf_flush,
1844  PerlIOBuf_fill,
1845  PerlIOBase_eof,
1846  PerlIOBase_error,
1847  PerlIOBase_clearerr,
1848  PerlIOBuf_setlinebuf,
1849  PerlIOBuf_get_base,
1850  PerlIOBuf_bufsiz,
1851  PerlIOBuf_get_ptr,
1852  PerlIOBuf_get_cnt,
1853  PerlIOBuf_set_ptrcnt,
1854 };
1855
1856 #ifdef HAS_MMAP
1857 /*--------------------------------------------------------------------------------------*/
1858 /* mmap as "buffer" layer */
1859
1860 typedef struct
1861 {
1862  PerlIOBuf      base;         /* PerlIOBuf stuff */
1863  Mmap_t         mptr;        /* Mapped address */
1864  Size_t         len;          /* mapped length */
1865  STDCHAR        *bbuf;        /* malloced buffer if map fails */
1866
1867 } PerlIOMmap;
1868
1869 static size_t page_size = 0;
1870
1871 IV
1872 PerlIOMmap_map(PerlIO *f)
1873 {
1874  dTHX;
1875  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1876  PerlIOBuf  *b = &m->base;
1877  IV flags = PerlIOBase(f)->flags;
1878  IV code  = 0;
1879  if (m->len)
1880   abort();
1881  if (flags & PERLIO_F_CANREAD)
1882   {
1883    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1884    int fd   = PerlIO_fileno(f);
1885    struct stat st;
1886    code = fstat(fd,&st);
1887    if (code == 0 && S_ISREG(st.st_mode))
1888     {
1889      SSize_t len = st.st_size - b->posn;
1890      if (len > 0)
1891       {
1892        Off_t posn;
1893        if (!page_size) {
1894 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1895            {
1896                SETERRNO(0,SS$_NORMAL);
1897 #   ifdef _SC_PAGESIZE
1898                page_size = sysconf(_SC_PAGESIZE);
1899 #   else
1900                page_size = sysconf(_SC_PAGE_SIZE);
1901 #   endif
1902                if ((long)page_size < 0) {
1903                    if (errno) {
1904                        SV *error = ERRSV;
1905                        char *msg;
1906                        STRLEN n_a;
1907                        (void)SvUPGRADE(error, SVt_PV);
1908                        msg = SvPVx(error, n_a);
1909                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1910                    }
1911                    else
1912                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1913                }
1914            }
1915 #else
1916 #   ifdef HAS_GETPAGESIZE
1917         page_size = getpagesize();
1918 #   else
1919 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
1920         page_size = PAGESIZE; /* compiletime, bad */
1921 #       endif
1922 #   endif
1923 #endif
1924         if ((IV)page_size <= 0)
1925             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1926        }
1927        if (b->posn < 0)
1928         {
1929          /* This is a hack - should never happen - open should have set it ! */
1930          b->posn = PerlIO_tell(PerlIONext(f));
1931         }
1932        posn = (b->posn / page_size) * page_size;
1933        len  = st.st_size - posn;
1934        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1935        if (m->mptr && m->mptr != (Mmap_t) -1)
1936         {
1937 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1938          madvise(m->mptr, len, MADV_SEQUENTIAL);
1939 #endif
1940          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1941          b->end  = ((STDCHAR *)m->mptr) + len;
1942          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
1943          b->ptr  = b->buf;
1944          m->len  = len;
1945         }
1946        else
1947         {
1948          b->buf = NULL;
1949         }
1950       }
1951      else
1952       {
1953        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1954        b->buf = NULL;
1955        b->ptr = b->end = b->ptr;
1956        code = -1;
1957       }
1958     }
1959   }
1960  return code;
1961 }
1962
1963 IV
1964 PerlIOMmap_unmap(PerlIO *f)
1965 {
1966  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1967  PerlIOBuf  *b = &m->base;
1968  IV code = 0;
1969  if (m->len)
1970   {
1971    if (b->buf)
1972     {
1973      code = munmap(m->mptr, m->len);
1974      b->buf  = NULL;
1975      m->len  = 0;
1976      m->mptr = NULL;
1977      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1978       code = -1;
1979     }
1980    b->ptr = b->end = b->buf;
1981    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1982   }
1983  return code;
1984 }
1985
1986 STDCHAR *
1987 PerlIOMmap_get_base(PerlIO *f)
1988 {
1989  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1990  PerlIOBuf  *b = &m->base;
1991  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1992   {
1993    /* Already have a readbuffer in progress */
1994    return b->buf;
1995   }
1996  if (b->buf)
1997   {
1998    /* We have a write buffer or flushed PerlIOBuf read buffer */
1999    m->bbuf = b->buf;  /* save it in case we need it again */
2000    b->buf  = NULL;    /* Clear to trigger below */
2001   }
2002  if (!b->buf)
2003   {
2004    PerlIOMmap_map(f);     /* Try and map it */
2005    if (!b->buf)
2006     {
2007      /* Map did not work - recover PerlIOBuf buffer if we have one */
2008      b->buf = m->bbuf;
2009     }
2010   }
2011  b->ptr  = b->end = b->buf;
2012  if (b->buf)
2013   return b->buf;
2014  return PerlIOBuf_get_base(f);
2015 }
2016
2017 SSize_t
2018 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2019 {
2020  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2021  PerlIOBuf  *b = &m->base;
2022  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2023   PerlIO_flush(f);
2024  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2025   {
2026    b->ptr -= count;
2027    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2028    return count;
2029   }
2030  if (m->len)
2031   {
2032    /* Loose the unwritable mapped buffer */
2033    PerlIO_flush(f);
2034    /* If flush took the "buffer" see if we have one from before */
2035    if (!b->buf && m->bbuf)
2036     b->buf = m->bbuf;
2037    if (!b->buf)
2038     {
2039      PerlIOBuf_get_base(f);
2040      m->bbuf = b->buf;
2041     }
2042   }
2043  return PerlIOBuf_unread(f,vbuf,count);
2044 }
2045
2046 SSize_t
2047 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2048 {
2049  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2050  PerlIOBuf  *b = &m->base;
2051  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2052   {
2053    /* No, or wrong sort of, buffer */
2054    if (m->len)
2055     {
2056      if (PerlIOMmap_unmap(f) != 0)
2057       return 0;
2058     }
2059    /* If unmap took the "buffer" see if we have one from before */
2060    if (!b->buf && m->bbuf)
2061     b->buf = m->bbuf;
2062    if (!b->buf)
2063     {
2064      PerlIOBuf_get_base(f);
2065      m->bbuf = b->buf;
2066     }
2067   }
2068  return PerlIOBuf_write(f,vbuf,count);
2069 }
2070
2071 IV
2072 PerlIOMmap_flush(PerlIO *f)
2073 {
2074  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2075  PerlIOBuf  *b = &m->base;
2076  IV code = PerlIOBuf_flush(f);
2077  /* Now we are "synced" at PerlIOBuf level */
2078  if (b->buf)
2079   {
2080    if (m->len)
2081     {
2082      /* Unmap the buffer */
2083      if (PerlIOMmap_unmap(f) != 0)
2084       code = -1;
2085     }
2086    else
2087     {
2088      /* We seem to have a PerlIOBuf buffer which was not mapped
2089       * remember it in case we need one later
2090       */
2091      m->bbuf = b->buf;
2092     }
2093   }
2094  return code;
2095 }
2096
2097 IV
2098 PerlIOMmap_fill(PerlIO *f)
2099 {
2100  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2101  IV code = PerlIO_flush(f);
2102  if (code == 0 && !b->buf)
2103   {
2104    code = PerlIOMmap_map(f);
2105   }
2106  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2107   {
2108    code = PerlIOBuf_fill(f);
2109   }
2110  return code;
2111 }
2112
2113 IV
2114 PerlIOMmap_close(PerlIO *f)
2115 {
2116  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2117  PerlIOBuf  *b = &m->base;
2118  IV code = PerlIO_flush(f);
2119  if (m->bbuf)
2120   {
2121    b->buf  = m->bbuf;
2122    m->bbuf = NULL;
2123    b->ptr  = b->end = b->buf;
2124   }
2125  if (PerlIOBuf_close(f) != 0)
2126   code = -1;
2127  return code;
2128 }
2129
2130
2131 PerlIO_funcs PerlIO_mmap = {
2132  "mmap",
2133  sizeof(PerlIOMmap),
2134  0,
2135  PerlIOBase_fileno,
2136  PerlIOBuf_fdopen,
2137  PerlIOBuf_open,
2138  PerlIOBuf_reopen,
2139  PerlIOBase_pushed,
2140  PerlIOBase_noop_ok,
2141  PerlIOBuf_read,
2142  PerlIOMmap_unread,
2143  PerlIOMmap_write,
2144  PerlIOBuf_seek,
2145  PerlIOBuf_tell,
2146  PerlIOBuf_close,
2147  PerlIOMmap_flush,
2148  PerlIOMmap_fill,
2149  PerlIOBase_eof,
2150  PerlIOBase_error,
2151  PerlIOBase_clearerr,
2152  PerlIOBuf_setlinebuf,
2153  PerlIOMmap_get_base,
2154  PerlIOBuf_bufsiz,
2155  PerlIOBuf_get_ptr,
2156  PerlIOBuf_get_cnt,
2157  PerlIOBuf_set_ptrcnt,
2158 };
2159
2160 #endif /* HAS_MMAP */
2161
2162 void
2163 PerlIO_init(void)
2164 {
2165  if (!_perlio)
2166   {
2167    atexit(&PerlIO_cleanup);
2168   }
2169 }
2170
2171 #undef PerlIO_stdin
2172 PerlIO *
2173 PerlIO_stdin(void)
2174 {
2175  if (!_perlio)
2176   PerlIO_stdstreams();
2177  return &_perlio[1];
2178 }
2179
2180 #undef PerlIO_stdout
2181 PerlIO *
2182 PerlIO_stdout(void)
2183 {
2184  if (!_perlio)
2185   PerlIO_stdstreams();
2186  return &_perlio[2];
2187 }
2188
2189 #undef PerlIO_stderr
2190 PerlIO *
2191 PerlIO_stderr(void)
2192 {
2193  if (!_perlio)
2194   PerlIO_stdstreams();
2195  return &_perlio[3];
2196 }
2197
2198 /*--------------------------------------------------------------------------------------*/
2199
2200 #undef PerlIO_getname
2201 char *
2202 PerlIO_getname(PerlIO *f, char *buf)
2203 {
2204  dTHX;
2205  Perl_croak(aTHX_ "Don't know how to get file name");
2206  return NULL;
2207 }
2208
2209
2210 /*--------------------------------------------------------------------------------------*/
2211 /* Functions which can be called on any kind of PerlIO implemented
2212    in terms of above
2213 */
2214
2215 #undef PerlIO_getc
2216 int
2217 PerlIO_getc(PerlIO *f)
2218 {
2219  STDCHAR buf[1];
2220  SSize_t count = PerlIO_read(f,buf,1);
2221  if (count == 1)
2222   {
2223    return (unsigned char) buf[0];
2224   }
2225  return EOF;
2226 }
2227
2228 #undef PerlIO_ungetc
2229 int
2230 PerlIO_ungetc(PerlIO *f, int ch)
2231 {
2232  if (ch != EOF)
2233   {
2234    STDCHAR buf = ch;
2235    if (PerlIO_unread(f,&buf,1) == 1)
2236     return ch;
2237   }
2238  return EOF;
2239 }
2240
2241 #undef PerlIO_putc
2242 int
2243 PerlIO_putc(PerlIO *f, int ch)
2244 {
2245  STDCHAR buf = ch;
2246  return PerlIO_write(f,&buf,1);
2247 }
2248
2249 #undef PerlIO_puts
2250 int
2251 PerlIO_puts(PerlIO *f, const char *s)
2252 {
2253  STRLEN len = strlen(s);
2254  return PerlIO_write(f,s,len);
2255 }
2256
2257 #undef PerlIO_rewind
2258 void
2259 PerlIO_rewind(PerlIO *f)
2260 {
2261  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2262  PerlIO_clearerr(f);
2263 }
2264
2265 #undef PerlIO_vprintf
2266 int
2267 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2268 {
2269  dTHX;
2270  SV *sv = newSVpvn("",0);
2271  char *s;
2272  STRLEN len;
2273  sv_vcatpvf(sv, fmt, &ap);
2274  s = SvPV(sv,len);
2275  return PerlIO_write(f,s,len);
2276 }
2277
2278 #undef PerlIO_printf
2279 int
2280 PerlIO_printf(PerlIO *f,const char *fmt,...)
2281 {
2282  va_list ap;
2283  int result;
2284  va_start(ap,fmt);
2285  result = PerlIO_vprintf(f,fmt,ap);
2286  va_end(ap);
2287  return result;
2288 }
2289
2290 #undef PerlIO_stdoutf
2291 int
2292 PerlIO_stdoutf(const char *fmt,...)
2293 {
2294  va_list ap;
2295  int result;
2296  va_start(ap,fmt);
2297  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2298  va_end(ap);
2299  return result;
2300 }
2301
2302 #undef PerlIO_tmpfile
2303 PerlIO *
2304 PerlIO_tmpfile(void)
2305 {
2306  dTHX;
2307  /* I have no idea how portable mkstemp() is ... */
2308  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2309  int fd = mkstemp(SvPVX(sv));
2310  PerlIO *f = NULL;
2311  if (fd >= 0)
2312   {
2313    f = PerlIO_fdopen(fd,"w+");
2314    if (f)
2315     {
2316      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2317     }
2318    PerlLIO_unlink(SvPVX(sv));
2319    SvREFCNT_dec(sv);
2320   }
2321  return f;
2322 }
2323
2324 #undef HAS_FSETPOS
2325 #undef HAS_FGETPOS
2326
2327 #endif /* USE_SFIO */
2328 #endif /* PERLIO_IS_STDIO */
2329
2330 /*======================================================================================*/
2331 /* Now some functions in terms of above which may be needed even if
2332    we are not in true PerlIO mode
2333  */
2334
2335 #ifndef HAS_FSETPOS
2336 #undef PerlIO_setpos
2337 int
2338 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2339 {
2340  return PerlIO_seek(f,*pos,0);
2341 }
2342 #else
2343 #ifndef PERLIO_IS_STDIO
2344 #undef PerlIO_setpos
2345 int
2346 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2347 {
2348 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2349  return fsetpos64(f, pos);
2350 #else
2351  return fsetpos(f, pos);
2352 #endif
2353 }
2354 #endif
2355 #endif
2356
2357 #ifndef HAS_FGETPOS
2358 #undef PerlIO_getpos
2359 int
2360 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2361 {
2362  *pos = PerlIO_tell(f);
2363  return *pos == -1 ? -1 : 0;
2364 }
2365 #else
2366 #ifndef PERLIO_IS_STDIO
2367 #undef PerlIO_getpos
2368 int
2369 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2370 {
2371 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2372  return fgetpos64(f, pos);
2373 #else
2374  return fgetpos(f, pos);
2375 #endif
2376 }
2377 #endif
2378 #endif
2379
2380 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2381
2382 int
2383 vprintf(char *pat, char *args)
2384 {
2385     _doprnt(pat, args, stdout);
2386     return 0;           /* wrong, but perl doesn't use the return value */
2387 }
2388
2389 int
2390 vfprintf(FILE *fd, char *pat, char *args)
2391 {
2392     _doprnt(pat, args, fd);
2393     return 0;           /* wrong, but perl doesn't use the return value */
2394 }
2395
2396 #endif
2397
2398 #ifndef PerlIO_vsprintf
2399 int
2400 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2401 {
2402  int val = vsprintf(s, fmt, ap);
2403  if (n >= 0)
2404   {
2405    if (strlen(s) >= (STRLEN)n)
2406     {
2407      dTHX;
2408      (void)PerlIO_puts(Perl_error_log,
2409                        "panic: sprintf overflow - memory corrupted!\n");
2410      my_exit(1);
2411     }
2412   }
2413  return val;
2414 }
2415 #endif
2416
2417 #ifndef PerlIO_sprintf
2418 int
2419 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2420 {
2421  va_list ap;
2422  int result;
2423  va_start(ap,fmt);
2424  result = PerlIO_vsprintf(s, n, fmt, ap);
2425  va_end(ap);
2426  return result;
2427 }
2428 #endif
2429
2430 #endif /* !PERL_IMPLICIT_SYS */
2431