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