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 #if !defined(PERL_IMPLICIT_SYS)
  32
  33 #ifdef PERLIO_IS_STDIO
  34
  35 void
  36 PerlIO_init(void)
  37 {
  38  /* Does nothing (yet) except force this file to be included
  39     in perl binary. That allows this file to force inclusion
  40     of other functions that may be required by loadable
  41     extensions e.g. for FileHandle::tmpfile
  42  */
  43 }
  44
  45 #undef PerlIO_tmpfile
  46 PerlIO *
  47 PerlIO_tmpfile(void)
  48 {
  49  return tmpfile();
  50 }
  51
  52 #else /* PERLIO_IS_STDIO */
  53
  54 #ifdef USE_SFIO
  55
  56 #undef HAS_FSETPOS
  57 #undef HAS_FGETPOS
  58
  59 /* This section is just to make sure these functions
  60    get pulled in from libsfio.a
  61 */
  62
  63 #undef PerlIO_tmpfile
  64 PerlIO *
  65 PerlIO_tmpfile(void)
  66 {
  67  return sftmp(0);
  68 }
  69
  70 void
  71 PerlIO_init(void)
  72 {
  73  /* Force this file to be included  in perl binary. Which allows
  74   *  this file to force inclusion  of other functions that may be
  75   *  required by loadable  extensions e.g. for FileHandle::tmpfile
  76   */
  77
  78  /* Hack
  79   * sfio does its own 'autoflush' on stdout in common cases.
  80   * Flush results in a lot of lseek()s to regular files and
  81   * lot of small writes to pipes.
  82   */
  83  sfset(sfstdout,SF_SHARE,0);
  84 }
  85
  86 #else /* USE_SFIO */
  87 /*======================================================================================*/
  88 /* Implement all the PerlIO interface ourselves.
  89  */
  90
  91 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
  92 #ifdef I_UNISTD
  93 #include <unistd.h>
  94 #endif
  95
  96 #undef printf
  97 void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
  98
  99 void
 100 PerlIO_debug(char *fmt,...)
 101 {
 102  static int dbg = 0;
 103  if (!dbg)
 104   {
 105    char *s = getenv("PERLIO_DEBUG");
 106    if (s && *s)
 107     dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 108    else
 109     dbg = -1;
 110   }
 111  if (dbg > 0)
 112   {
 113    dTHX;
 114    va_list ap;
 115    SV *sv = newSVpvn("",0);
 116    char *s;
 117    STRLEN len;
 118    va_start(ap,fmt);
 119    s = CopFILE(PL_curcop);
 120    if (!s)
 121     s = "(none)";
 122    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 123    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 124
 125    s = SvPV(sv,len);
 126    write(dbg,s,len);
 127    va_end(ap);
 128    SvREFCNT_dec(sv);
 129   }
 130 }
 131
 132 /*--------------------------------------------------------------------------------------*/
 133
 134 typedef struct
 135 {
 136  char *         name;
 137  Size_t         size;
 138  IV             kind;
 139  IV             (*Fileno)(PerlIO *f);
 140  PerlIO *       (*Fdopen)(int fd, const char *mode);
 141  PerlIO *       (*Open)(const char *path, const char *mode);
 142  int            (*Reopen)(const char *path, const char *mode, PerlIO *f);
 143  /* Unix-like functions - cf sfio line disciplines */
 144  SSize_t        (*Read)(PerlIO *f, void *vbuf, Size_t count);
 145  SSize_t        (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
 146  SSize_t        (*Write)(PerlIO *f, const void *vbuf, Size_t count);
 147  IV             (*Seek)(PerlIO *f, Off_t offset, int whence);
 148  Off_t          (*Tell)(PerlIO *f);
 149  IV             (*Close)(PerlIO *f);
 150  /* Stdio-like buffered IO functions */
 151  IV             (*Flush)(PerlIO *f);
 152  IV             (*Eof)(PerlIO *f);
 153  IV             (*Error)(PerlIO *f);
 154  void           (*Clearerr)(PerlIO *f);
 155  void           (*Setlinebuf)(PerlIO *f);
 156  /* Perl's snooping functions */
 157  STDCHAR *      (*Get_base)(PerlIO *f);
 158  Size_t         (*Get_bufsiz)(PerlIO *f);
 159  STDCHAR *      (*Get_ptr)(PerlIO *f);
 160  SSize_t        (*Get_cnt)(PerlIO *f);
 161  void           (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
 162 } PerlIO_funcs;
 163
 164
 165 struct _PerlIO
 166 {
 167  PerlIOl *      next;       /* Lower layer */
 168  PerlIO_funcs * tab;        /* Functions for this layer */
 169  IV             flags;      /* Various flags for state */
 170 };
 171
 172 /*--------------------------------------------------------------------------------------*/
 173
 174 /* Flag values */
 175 #define PERLIO_F_EOF            0x0010000
 176 #define PERLIO_F_CANWRITE       0x0020000
 177 #define PERLIO_F_CANREAD        0x0040000
 178 #define PERLIO_F_ERROR          0x0080000
 179 #define PERLIO_F_TRUNCATE       0x0100000
 180 #define PERLIO_F_APPEND         0x0200000
 181 #define PERLIO_F_BINARY         0x0400000
 182 #define PERLIO_F_TEMP           0x0800000
 183 #define PERLIO_F_LINEBUF        0x0100000
 184 #define PERLIO_F_WRBUF          0x2000000
 185 #define PERLIO_F_RDBUF          0x4000000
 186 #define PERLIO_F_OPEN           0x8000000
 187
 188 #define PerlIOBase(f)      (*(f))
 189 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
 190 #define PerlIONext(f)      (&(PerlIOBase(f)->next))
 191
 192 /*--------------------------------------------------------------------------------------*/
 193 /* Inner level routines */
 194
 195 /* Table of pointers to the PerlIO structs (malloc'ed) */
 196 PerlIO *_perlio      = NULL;
 197 #define PERLIO_TABLE_SIZE 64
 198
 199 PerlIO *
 200 PerlIO_allocate(void)
 201 {
 202  /* Find a free slot in the table, growing table as necessary */
 203  PerlIO **last = &_perlio;
 204  PerlIO *f;
 205  while ((f = *last))
 206   {
 207    int i;
 208    last = (PerlIO **)(f);
 209    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 210     {
 211      if (!*++f)
 212       {
 213        return f;
 214       }
 215     }
 216   }
 217  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 218  if (!f)
 219   return NULL;
 220  *last = f;
 221  return f+1;
 222 }
 223
 224 void
 225 PerlIO_cleantable(PerlIO **tablep)
 226 {
 227  PerlIO *table = *tablep;
 228  if (table)
 229   {
 230    int i;
 231    PerlIO_cleantable((PerlIO **) &(table[0]));
 232    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 233     {
 234      PerlIO *f = table+i;
 235      if (*f)
 236       PerlIO_close(f);
 237     }
 238    Safefree(table);
 239    *tablep = NULL;
 240   }
 241 }
 242
 243 void
 244 PerlIO_cleanup(void)
 245 {
 246  PerlIO_cleantable(&_perlio);
 247 }
 248
 249 void
 250 PerlIO_pop(PerlIO *f)
 251 {
 252  PerlIOl *l = *f;
 253  if (l)
 254   {
 255    *f = l->next;
 256    Safefree(l);
 257   }
 258 }
 259
 260 #undef PerlIO_close
 261 int
 262 PerlIO_close(PerlIO *f)
 263 {
 264  int code = (*PerlIOBase(f)->tab->Close)(f);
 265  while (*f)
 266   {
 267    PerlIO_pop(f);
 268   }
 269  return code;
 270 }
 271
 272
 273 /*--------------------------------------------------------------------------------------*/
 274 /* Given the abstraction above the public API functions */
 275
 276 #undef PerlIO_fileno
 277 int
 278 PerlIO_fileno(PerlIO *f)
 279 {
 280  return (*PerlIOBase(f)->tab->Fileno)(f);
 281 }
 282
 283 extern PerlIO_funcs PerlIO_unix;
 284 extern PerlIO_funcs PerlIO_stdio;
 285 extern PerlIO_funcs PerlIO_perlio;
 286
 287 #define PerlIO_default_top() &PerlIO_stdio
 288 #define PerlIO_default_btm() &PerlIO_unix
 289
 290 #undef PerlIO_fdopen
 291 PerlIO *
 292 PerlIO_fdopen(int fd, const char *mode)
 293 {
 294  PerlIO_funcs *tab = PerlIO_default_top();
 295  return (*tab->Fdopen)(fd,mode);
 296 }
 297
 298 #undef PerlIO_open
 299 PerlIO *
 300 PerlIO_open(const char *path, const char *mode)
 301 {
 302  PerlIO_funcs *tab = PerlIO_default_top();
 303  return (*tab->Open)(path,mode);
 304 }
 305
 306 IV
 307 PerlIOBase_init(PerlIO *f, const char *mode)
 308 {
 309  PerlIOl *l = PerlIOBase(f);
 310  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 311                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 312  if (mode)
 313   {
 314    switch (*mode++)
 315     {
 316      case 'r':
 317       l->flags = PERLIO_F_CANREAD;
 318       break;
 319      case 'a':
 320       l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 321       break;
 322      case 'w':
 323       l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 324       break;
 325      default:
 326       errno = EINVAL;
 327       return -1;
 328     }
 329    while (*mode)
 330     {
 331      switch (*mode++)
 332       {
 333        case '+':
 334         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 335         break;
 336        case 'b':
 337         l->flags |= PERLIO_F_BINARY;
 338         break;
 339       default:
 340        errno = EINVAL;
 341        return -1;
 342       }
 343     }
 344   }
 345  else
 346   {
 347    if (l->next)
 348     {
 349      l->flags |= l->next->flags &
 350                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 351                    PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 352     }
 353   }
 354  return 0;
 355 }
 356
 357 #undef PerlIO_reopen
 358 PerlIO *
 359 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 360 {
 361  if (f)
 362   {
 363    PerlIO_flush(f);
 364    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 365     {
 366      PerlIOBase_init(f,mode);
 367      return f;
 368     }
 369    return NULL;
 370   }
 371  else
 372   return PerlIO_open(path,mode);
 373 }
 374
 375 #undef PerlIO_read
 376 SSize_t
 377 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 378 {
 379  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 380 }
 381
 382 #undef PerlIO_ungetc
 383 int
 384 PerlIO_ungetc(PerlIO *f, int ch)
 385 {
 386  STDCHAR buf = ch;
 387  if ((*PerlIOBase(f)->tab->Unread)(f,&buf,1) == 1)
 388   return ch;
 389  return -1;
 390 }
 391
 392 #undef PerlIO_write
 393 SSize_t
 394 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 395 {
 396  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 397 }
 398
 399 #undef PerlIO_seek
 400 int
 401 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 402 {
 403  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 404 }
 405
 406 #undef PerlIO_tell
 407 Off_t
 408 PerlIO_tell(PerlIO *f)
 409 {
 410  return (*PerlIOBase(f)->tab->Tell)(f);
 411 }
 412
 413 #undef PerlIO_flush
 414 int
 415 PerlIO_flush(PerlIO *f)
 416 {
 417  if (f)
 418   {
 419    return (*PerlIOBase(f)->tab->Flush)(f);
 420   }
 421  else
 422   {
 423    PerlIO **table = &_perlio;
 424    int code = 0;
 425    while ((f = *table))
 426     {
 427      int i;
 428      table = (PerlIO **)(f++);
 429      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 430       {
 431        if (*f && PerlIO_flush(f) != 0)
 432         code = -1;
 433        f++;
 434       }
 435     }
 436    return code;
 437   }
 438 }
 439
 440 #undef PerlIO_eof
 441 int
 442 PerlIO_eof(PerlIO *f)
 443 {
 444  return (*PerlIOBase(f)->tab->Eof)(f);
 445 }
 446
 447 #undef PerlIO_error
 448 int
 449 PerlIO_error(PerlIO *f)
 450 {
 451  return (*PerlIOBase(f)->tab->Error)(f);
 452 }
 453
 454 #undef PerlIO_clearerr
 455 void
 456 PerlIO_clearerr(PerlIO *f)
 457 {
 458  (*PerlIOBase(f)->tab->Clearerr)(f);
 459 }
 460
 461 #undef PerlIO_setlinebuf
 462 void
 463 PerlIO_setlinebuf(PerlIO *f)
 464 {
 465  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 466 }
 467
 468 #undef PerlIO_has_base
 469 int
 470 PerlIO_has_base(PerlIO *f)
 471 {
 472  if (f && *f)
 473   {
 474    return (PerlIOBase(f)->tab->Get_base != NULL);
 475   }
 476  return 0;
 477 }
 478
 479 #undef PerlIO_fast_gets
 480 int
 481 PerlIO_fast_gets(PerlIO *f)
 482 {
 483  if (f && *f)
 484   {
 485    PerlIOl *l = PerlIOBase(f);
 486    return (l->tab->Set_ptrcnt != NULL);
 487   }
 488  return 0;
 489 }
 490
 491 #undef PerlIO_has_cntptr
 492 int
 493 PerlIO_has_cntptr(PerlIO *f)
 494 {
 495  if (f && *f)
 496   {
 497    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 498    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 499   }
 500  return 0;
 501 }
 502
 503 #undef PerlIO_canset_cnt
 504 int
 505 PerlIO_canset_cnt(PerlIO *f)
 506 {
 507  if (f && *f)
 508   {
 509    PerlIOl *l = PerlIOBase(f);
 510    return (l->tab->Set_ptrcnt != NULL);
 511   }
 512  return 0;
 513 }
 514
 515 #undef PerlIO_get_base
 516 STDCHAR *
 517 PerlIO_get_base(PerlIO *f)
 518 {
 519  return (*PerlIOBase(f)->tab->Get_base)(f);
 520 }
 521
 522 #undef PerlIO_get_bufsiz
 523 int
 524 PerlIO_get_bufsiz(PerlIO *f)
 525 {
 526  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 527 }
 528
 529 #undef PerlIO_get_ptr
 530 STDCHAR *
 531 PerlIO_get_ptr(PerlIO *f)
 532 {
 533  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 534 }
 535
 536 #undef PerlIO_get_cnt
 537 int
 538 PerlIO_get_cnt(PerlIO *f)
 539 {
 540  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 541 }
 542
 543 #undef PerlIO_set_cnt
 544 void
 545 PerlIO_set_cnt(PerlIO *f,int cnt)
 546 {
 547  return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 548 }
 549
 550 #undef PerlIO_set_ptrcnt
 551 void
 552 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 553 {
 554  return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 555 }
 556
 557 /*--------------------------------------------------------------------------------------*/
 558 /* "Methods" of the "base class" */
 559
 560 IV
 561 PerlIOBase_fileno(PerlIO *f)
 562 {
 563  return PerlIO_fileno(PerlIONext(f));
 564 }
 565
 566 PerlIO *
 567 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 568 {
 569  PerlIOl *l = NULL;
 570  Newc('L',l,tab->size,char,PerlIOl);
 571  if (l)
 572   {
 573    Zero(l,tab->size,char);
 574    l->next = *f;
 575    l->tab  = tab;
 576    *f      = l;
 577    PerlIOBase_init(f,mode);
 578   }
 579  return f;
 580 }
 581
 582 SSize_t
 583 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 584 {
 585  Off_t old = PerlIO_tell(f);
 586  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 587   {
 588    Off_t new = PerlIO_tell(f);
 589    return old - new;
 590   }
 591  return 0;
 592 }
 593
 594 IV
 595 PerlIOBase_sync(PerlIO *f)
 596 {
 597  return 0;
 598 }
 599
 600 IV
 601 PerlIOBase_close(PerlIO *f)
 602 {
 603  IV code = 0;
 604  if (PerlIO_flush(f) != 0)
 605   code = -1;
 606  if (PerlIO_close(PerlIONext(f)) != 0)
 607   code = -1;
 608  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 609  return code;
 610 }
 611
 612 IV
 613 PerlIOBase_eof(PerlIO *f)
 614 {
 615  if (f && *f)
 616   {
 617    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
 618   }
 619  return 1;
 620 }
 621
 622 IV
 623 PerlIOBase_error(PerlIO *f)
 624 {
 625  if (f && *f)
 626   {
 627    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
 628   }
 629  return 1;
 630 }
 631
 632 void
 633 PerlIOBase_clearerr(PerlIO *f)
 634 {
 635  if (f && *f)
 636   {
 637    PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
 638   }
 639 }
 640
 641 void
 642 PerlIOBase_setlinebuf(PerlIO *f)
 643 {
 644
 645 }
 646
 647
 648
 649 /*--------------------------------------------------------------------------------------*/
 650 /* Bottom-most level for UNIX-like case */
 651
 652 typedef struct
 653 {
 654  struct _PerlIO base;       /* The generic part */
 655  int            fd;         /* UNIX like file descriptor */
 656  int            oflags;     /* open/fcntl flags */
 657 } PerlIOUnix;
 658
 659 int
 660 PerlIOUnix_oflags(const char *mode)
 661 {
 662  int oflags = -1;
 663  switch(*mode)
 664   {
 665    case 'r':
 666     oflags = O_RDONLY;
 667     if (*++mode == '+')
 668      {
 669       oflags = O_RDWR;
 670       mode++;
 671      }
 672     break;
 673
 674    case 'w':
 675     oflags = O_CREAT|O_TRUNC;
 676     if (*++mode == '+')
 677      {
 678       oflags |= O_RDWR;
 679       mode++;
 680      }
 681     else
 682      oflags |= O_WRONLY;
 683     break;
 684
 685    case 'a':
 686     oflags = O_CREAT|O_APPEND;
 687     if (*++mode == '+')
 688      {
 689       oflags |= O_RDWR;
 690       mode++;
 691      }
 692     else
 693      oflags |= O_WRONLY;
 694     break;
 695   }
 696  if (*mode || oflags == -1)
 697   {
 698    errno = EINVAL;
 699    oflags = -1;
 700   }
 701  return oflags;
 702 }
 703
 704 IV
 705 PerlIOUnix_fileno(PerlIO *f)
 706 {
 707  return PerlIOSelf(f,PerlIOUnix)->fd;
 708 }
 709
 710 PerlIO *
 711 PerlIOUnix_fdopen(int fd,const char *mode)
 712 {
 713  PerlIO *f = NULL;
 714  if (*mode == 'I')
 715   mode++;
 716  if (fd >= 0)
 717   {
 718    int oflags = PerlIOUnix_oflags(mode);
 719    if (oflags != -1)
 720     {
 721      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
 722      s->fd     = fd;
 723      s->oflags = oflags;
 724      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 725     }
 726   }
 727  return f;
 728 }
 729
 730 PerlIO *
 731 PerlIOUnix_open(const char *path,const char *mode)
 732 {
 733  PerlIO *f = NULL;
 734  int oflags = PerlIOUnix_oflags(mode);
 735  if (oflags != -1)
 736   {
 737    int fd = open(path,oflags,0666);
 738    if (fd >= 0)
 739     {
 740      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
 741      s->fd     = fd;
 742      s->oflags = oflags;
 743      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 744     }
 745   }
 746  return f;
 747 }
 748
 749 int
 750 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
 751 {
 752  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
 753  int oflags = PerlIOUnix_oflags(mode);
 754  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
 755   (*PerlIOBase(f)->tab->Close)(f);
 756  if (oflags != -1)
 757   {
 758    int fd = open(path,oflags,0666);
 759    if (fd >= 0)
 760     {
 761      s->fd = fd;
 762      s->oflags = oflags;
 763      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 764      return 0;
 765     }
 766   }
 767  return -1;
 768 }
 769
 770 SSize_t
 771 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
 772 {
 773  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 774  while (1)
 775   {
 776    SSize_t len = read(fd,vbuf,count);
 777    if (len >= 0 || errno != EINTR)
 778     return len;
 779   }
 780 }
 781
 782 SSize_t
 783 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
 784 {
 785  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 786  while (1)
 787   {
 788    SSize_t len = write(fd,vbuf,count);
 789    if (len >= 0 || errno != EINTR)
 790     return len;
 791   }
 792 }
 793
 794 IV
 795 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
 796 {
 797  Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
 798  return (new == (Off_t) -1) ? -1 : 0;
 799 }
 800
 801 Off_t
 802 PerlIOUnix_tell(PerlIO *f)
 803 {
 804  return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
 805 }
 806
 807 IV
 808 PerlIOUnix_close(PerlIO *f)
 809 {
 810  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 811  int code = 0;
 812  while (close(fd) != 0)
 813   {
 814    if (errno != EINTR)
 815     {
 816      code = -1;
 817      break;
 818     }
 819   }
 820  if (code == 0)
 821   {
 822    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 823   }
 824  return code;
 825 }
 826
 827 PerlIO_funcs PerlIO_unix = {
 828  "unix",
 829  sizeof(PerlIOUnix),
 830  0,
 831  PerlIOUnix_fileno,
 832  PerlIOUnix_fdopen,
 833  PerlIOUnix_open,
 834  PerlIOUnix_reopen,
 835  PerlIOUnix_read,
 836  PerlIOBase_unread,
 837  PerlIOUnix_write,
 838  PerlIOUnix_seek,
 839  PerlIOUnix_tell,
 840  PerlIOUnix_close,
 841  PerlIOBase_sync,
 842  PerlIOBase_eof,
 843  PerlIOBase_error,
 844  PerlIOBase_clearerr,
 845  PerlIOBase_setlinebuf,
 846  NULL, /* get_base */
 847  NULL, /* get_bufsiz */
 848  NULL, /* get_ptr */
 849  NULL, /* get_cnt */
 850  NULL, /* set_ptrcnt */
 851 };
 852
 853 /*--------------------------------------------------------------------------------------*/
 854 /* stdio as a layer */
 855
 856 typedef struct
 857 {
 858  struct _PerlIO base;
 859  FILE *         stdio;      /* The stream */
 860 } PerlIOStdio;
 861
 862 IV
 863 PerlIOStdio_fileno(PerlIO *f)
 864 {
 865  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
 866 }
 867
 868
 869 PerlIO *
 870 PerlIOStdio_fdopen(int fd,const char *mode)
 871 {
 872  PerlIO *f = NULL;
 873  int init = 0;
 874  if (*mode == 'I')
 875   {
 876    init = 1;
 877    mode++;
 878   }
 879  if (fd >= 0)
 880   {
 881    FILE *stdio = NULL;
 882    if (init)
 883     {
 884      switch(fd)
 885       {
 886        case 0:
 887         stdio = stdin;
 888         break;
 889        case 1:
 890         stdio = stdout;
 891         break;
 892        case 2:
 893         stdio = stderr;
 894         break;
 895       }
 896     }
 897    else
 898     stdio = fdopen(fd,mode);
 899    if (stdio)
 900     {
 901      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
 902      s->stdio  = stdio;
 903     }
 904   }
 905  return f;
 906 }
 907
 908 #undef PerlIO_importFILE
 909 PerlIO *
 910 PerlIO_importFILE(FILE *stdio, int fl)
 911 {
 912  PerlIO *f = NULL;
 913  if (stdio)
 914   {
 915    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
 916    s->stdio  = stdio;
 917   }
 918  return f;
 919 }
 920
 921 PerlIO *
 922 PerlIOStdio_open(const char *path,const char *mode)
 923 {
 924  PerlIO *f = NULL;
 925  FILE *stdio = fopen(path,mode);
 926  if (stdio)
 927   {
 928    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
 929    s->stdio  = stdio;
 930   }
 931  return f;
 932 }
 933
 934 int
 935 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
 936 {
 937  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
 938  FILE *stdio = freopen(path,mode,s->stdio);
 939  if (!s->stdio)
 940   return -1;
 941  s->stdio = stdio;
 942  return 0;
 943 }
 944
 945 SSize_t
 946 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
 947 {
 948  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
 949  SSize_t got = 0;
 950  if (count == 1)
 951   {
 952    STDCHAR *buf = (STDCHAR *) vbuf;
 953    /* Perl is expecting PerlIO_getc() to fill the buffer
 954     * Linux's stdio does not do that for fread()
 955     */
 956    int ch = fgetc(s);
 957    if (ch != EOF)
 958     {
 959      *buf = ch;
 960      got = 1;
 961     }
 962   }
 963  else
 964   got = fread(vbuf,1,count,s);
 965  return got;
 966 }
 967
 968 SSize_t
 969 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
 970 {
 971  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
 972  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
 973  SSize_t unread = 0;
 974  while (count > 0)
 975   {
 976    int ch = *buf-- & 0xff;
 977    if (ungetc(ch,s) != ch)
 978     break;
 979    unread++;
 980    count--;
 981   }
 982  return unread;
 983 }
 984
 985 SSize_t
 986 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
 987 {
 988  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
 989 }
 990
 991 IV
 992 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
 993 {
 994  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
 995  return fseek(stdio,offset,whence);
 996 }
 997
 998 Off_t
 999 PerlIOStdio_tell(PerlIO *f)
1000 {
1001  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1002  return ftell(stdio);
1003 }
1004
1005 IV
1006 PerlIOStdio_close(PerlIO *f)
1007 {
1008  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1009 }
1010
1011 IV
1012 PerlIOStdio_flush(PerlIO *f)
1013 {
1014  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1015  return fflush(stdio);
1016 }
1017
1018 IV
1019 PerlIOStdio_eof(PerlIO *f)
1020 {
1021  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1022 }
1023
1024 IV
1025 PerlIOStdio_error(PerlIO *f)
1026 {
1027  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1028 }
1029
1030 void
1031 PerlIOStdio_clearerr(PerlIO *f)
1032 {
1033  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1034 }
1035
1036 void
1037 PerlIOStdio_setlinebuf(PerlIO *f)
1038 {
1039 #ifdef HAS_SETLINEBUF
1040  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1041 #else
1042  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1043 #endif
1044 }
1045
1046 #ifdef FILE_base
1047 STDCHAR *
1048 PerlIOStdio_get_base(PerlIO *f)
1049 {
1050  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1051  return FILE_base(stdio);
1052 }
1053
1054 Size_t
1055 PerlIOStdio_get_bufsiz(PerlIO *f)
1056 {
1057  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1058  return FILE_bufsiz(stdio);
1059 }
1060 #endif
1061
1062 #ifdef USE_STDIO_PTR
1063 STDCHAR *
1064 PerlIOStdio_get_ptr(PerlIO *f)
1065 {
1066  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1067  return FILE_ptr(stdio);
1068 }
1069
1070 SSize_t
1071 PerlIOStdio_get_cnt(PerlIO *f)
1072 {
1073  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1074  return FILE_cnt(stdio);
1075 }
1076
1077 void
1078 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1079 {
1080  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1081  if (ptr != NULL)
1082   {
1083 #ifdef STDIO_PTR_LVALUE
1084    FILE_ptr(stdio) = ptr;
1085 #ifdef STDIO_PTR_LVAL_SETS_CNT
1086    if (FILE_cnt(stdio) != (cnt))
1087     {
1088      dTHX;
1089      assert(FILE_cnt(stdio) == (cnt));
1090     }
1091 #endif
1092 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1093    /* Setting ptr _does_ change cnt - we are done */
1094    return;
1095 #endif
1096 #else  /* STDIO_PTR_LVALUE */
1097    abort();
1098 #endif /* STDIO_PTR_LVALUE */
1099   }
1100 /* Now (or only) set cnt */
1101 #ifdef STDIO_CNT_LVALUE
1102  FILE_cnt(stdio) = cnt;
1103 #else  /* STDIO_CNT_LVALUE */
1104 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1105  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1106 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1107  abort();
1108 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1109 #endif /* STDIO_CNT_LVALUE */
1110 }
1111
1112 #endif
1113
1114 PerlIO_funcs PerlIO_stdio = {
1115  "stdio",
1116  sizeof(PerlIOStdio),
1117  0,
1118  PerlIOStdio_fileno,
1119  PerlIOStdio_fdopen,
1120  PerlIOStdio_open,
1121  PerlIOStdio_reopen,
1122  PerlIOStdio_read,
1123  PerlIOStdio_unread,
1124  PerlIOStdio_write,
1125  PerlIOStdio_seek,
1126  PerlIOStdio_tell,
1127  PerlIOStdio_close,
1128  PerlIOStdio_flush,
1129  PerlIOStdio_eof,
1130  PerlIOStdio_error,
1131  PerlIOStdio_clearerr,
1132  PerlIOStdio_setlinebuf,
1133 #ifdef FILE_base
1134  PerlIOStdio_get_base,
1135  PerlIOStdio_get_bufsiz,
1136 #else
1137  NULL,
1138  NULL,
1139 #endif
1140 #ifdef USE_STDIO_PTR
1141  PerlIOStdio_get_ptr,
1142  PerlIOStdio_get_cnt,
1143 #if (defined(STDIO_PTR_LVALUE) && \
1144     (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1145  PerlIOStdio_set_ptrcnt
1146 #else  /* STDIO_PTR_LVALUE */
1147  NULL
1148 #endif /* STDIO_PTR_LVALUE */
1149 #else  /* USE_STDIO_PTR */
1150  NULL,
1151  NULL,
1152  NULL
1153 #endif /* USE_STDIO_PTR */
1154 };
1155
1156 #undef PerlIO_exportFILE
1157 FILE *
1158 PerlIO_exportFILE(PerlIO *f, int fl)
1159 {
1160  PerlIO_flush(f);
1161  /* Should really push stdio discipline when we have them */
1162  return fdopen(PerlIO_fileno(f),"r+");
1163 }
1164
1165 #undef PerlIO_findFILE
1166 FILE *
1167 PerlIO_findFILE(PerlIO *f)
1168 {
1169  return PerlIO_exportFILE(f,0);
1170 }
1171
1172 #undef PerlIO_releaseFILE
1173 void
1174 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1175 {
1176 }
1177
1178 /*--------------------------------------------------------------------------------------*/
1179 /* perlio buffer layer */
1180
1181 typedef struct
1182 {
1183  struct _PerlIO base;
1184  Off_t          posn;       /* Offset of buf into the file */
1185  STDCHAR *      buf;        /* Start of buffer */
1186  STDCHAR *      end;        /* End of valid part of buffer */
1187  STDCHAR *      ptr;        /* Current position in buffer */
1188  Size_t         bufsiz;     /* Size of buffer */
1189  IV             oneword;    /* Emergency buffer */
1190 } PerlIOBuf;
1191
1192
1193 PerlIO *
1194 PerlIOBuf_fdopen(int fd, const char *mode)
1195 {
1196  PerlIO_funcs *tab = PerlIO_default_btm();
1197  int init = 0;
1198  PerlIO *f;
1199  if (*mode == 'I')
1200   {
1201    init = 1;
1202    mode++;
1203   }
1204  f = (*tab->Fdopen)(fd,mode);
1205  if (f)
1206   {
1207    /* Initial stderr is unbuffered */
1208    if (!init || fd != 2)
1209     {
1210      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1211      b->posn = PerlIO_tell(PerlIONext(f));
1212     }
1213   }
1214  return f;
1215 }
1216
1217 PerlIO *
1218 PerlIOBuf_open(const char *path, const char *mode)
1219 {
1220  PerlIO_funcs *tab = PerlIO_default_btm();
1221  PerlIO *f = (*tab->Open)(path,mode);
1222  if (f)
1223   {
1224    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1225    b->posn = 0;
1226   }
1227  return f;
1228 }
1229
1230 int
1231 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1232 {
1233  return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1234 }
1235
1236 void
1237 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1238 {
1239  if (!b->bufsiz)
1240   b->bufsiz = 4096;
1241  New('B',b->buf,b->bufsiz,STDCHAR);
1242  if (!b->buf)
1243   {
1244    b->buf = (STDCHAR *)&b->oneword;
1245    b->bufsiz = sizeof(b->oneword);
1246   }
1247  b->ptr = b->buf;
1248  b->end = b->ptr;
1249 }
1250
1251 /* This "flush" is akin to sfio's sync in that it handles files in either
1252    read or write state
1253 */
1254 IV
1255 PerlIOBuf_flush(PerlIO *f)
1256 {
1257  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1258  int code = 0;
1259  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1260   {
1261    /* write() the buffer */
1262    STDCHAR *p = b->buf;
1263    int count;
1264    while (p < b->ptr)
1265     {
1266      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1267      if (count > 0)
1268       {
1269        p += count;
1270       }
1271      else if (count < 0)
1272       {
1273        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1274        code = -1;
1275        break;
1276       }
1277     }
1278    b->posn += (p - b->buf);
1279   }
1280  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1281   {
1282    /* Note position change */
1283    b->posn += (b->ptr - b->buf);
1284    if (b->ptr < b->end)
1285     {
1286      /* We did not consume all of it */
1287      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1288       {
1289        b->posn = PerlIO_tell(PerlIONext(f));
1290       }
1291     }
1292   }
1293  b->ptr = b->end = b->buf;
1294  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1295  if (PerlIO_flush(PerlIONext(f)) != 0)
1296   code = -1;
1297  return code;
1298 }
1299
1300 SSize_t
1301 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1302 {
1303  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1304  STDCHAR *buf = (STDCHAR *) vbuf;
1305  if (f)
1306   {
1307    Size_t got = 0;
1308    if (!b->ptr)
1309     PerlIOBuf_alloc_buf(b);
1310    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1311     return 0;
1312    while (count > 0)
1313     {
1314      SSize_t avail = (b->end - b->ptr);
1315      if ((SSize_t) count < avail)
1316       avail = count;
1317      if (avail > 0)
1318       {
1319        Copy(b->ptr,buf,avail,char);
1320        got     += avail;
1321        b->ptr  += avail;
1322        count   -= avail;
1323        buf     += avail;
1324       }
1325      if (count && (b->ptr >= b->end))
1326       {
1327        PerlIO_flush(f);
1328        b->ptr = b->end = b->buf;
1329        avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1330        if (avail <= 0)
1331         {
1332          if (avail == 0)
1333           PerlIOBase(f)->flags |= PERLIO_F_EOF;
1334          else
1335           PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1336          break;
1337         }
1338        b->end      = b->buf+avail;
1339        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1340       }
1341     }
1342    return got;
1343   }
1344  return 0;
1345 }
1346
1347 SSize_t
1348 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1349 {
1350  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1351  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1352  SSize_t unread = 0;
1353  SSize_t avail;
1354  if (!b->buf)
1355   PerlIOBuf_alloc_buf(b);
1356  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1357   PerlIO_flush(f);
1358  if (b->buf)
1359   {
1360    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1361     {
1362      avail = (b->ptr - b->buf);
1363      if (avail > (SSize_t) count)
1364       avail = count;
1365      b->ptr -= avail;
1366     }
1367    else
1368     {
1369      avail = b->bufsiz;
1370      if (avail > (SSize_t) count)
1371       avail = count;
1372      b->end = b->ptr + avail;
1373     }
1374    if (avail > 0)
1375     {
1376      buf    -= avail;
1377      if (buf != b->ptr)
1378       {
1379        Copy(buf,b->ptr,avail,char);
1380       }
1381      count  -= avail;
1382      unread += avail;
1383      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1384     }
1385   }
1386  return unread;
1387 }
1388
1389 SSize_t
1390 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1391 {
1392  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1393  const STDCHAR *buf = (const STDCHAR *) vbuf;
1394  Size_t written = 0;
1395  if (!b->buf)
1396   PerlIOBuf_alloc_buf(b);
1397  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1398   return 0;
1399  while (count > 0)
1400   {
1401    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1402    if ((SSize_t) count < avail)
1403     avail = count;
1404    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1405    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1406     {
1407      while (avail > 0)
1408       {
1409        int ch = *buf++;
1410        *(b->ptr)++ = ch;
1411        count--;
1412        avail--;
1413        written++;
1414        if (ch == '\n')
1415         {
1416          PerlIO_flush(f);
1417          break;
1418         }
1419       }
1420     }
1421    else
1422     {
1423      if (avail)
1424       {
1425        Copy(buf,b->ptr,avail,char);
1426        count   -= avail;
1427        buf     += avail;
1428        written += avail;
1429        b->ptr  += avail;
1430       }
1431     }
1432    if (b->ptr >= (b->buf + b->bufsiz))
1433     PerlIO_flush(f);
1434   }
1435  return written;
1436 }
1437
1438 IV
1439 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1440 {
1441  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1442  int code;
1443  code = PerlIO_flush(f);
1444  if (code == 0)
1445   {
1446    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1447    code = PerlIO_seek(PerlIONext(f),offset,whence);
1448    if (code == 0)
1449     {
1450      b->posn = PerlIO_tell(PerlIONext(f));
1451     }
1452   }
1453  return code;
1454 }
1455
1456 Off_t
1457 PerlIOBuf_tell(PerlIO *f)
1458 {
1459  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1460  Off_t posn = b->posn;
1461  if (b->buf)
1462   posn += (b->ptr - b->buf);
1463  return posn;
1464 }
1465
1466 IV
1467 PerlIOBuf_close(PerlIO *f)
1468 {
1469  IV code = PerlIOBase_close(f);
1470  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1471  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1472   {
1473    Safefree(b->buf);
1474   }
1475  b->buf = NULL;
1476  b->ptr = b->end = b->buf;
1477  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1478  return code;
1479 }
1480
1481 void
1482 PerlIOBuf_setlinebuf(PerlIO *f)
1483 {
1484  if (f)
1485   {
1486    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1487   }
1488 }
1489
1490 void
1491 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1492 {
1493  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1494  dTHX;
1495  if (!b->buf)
1496   PerlIOBuf_alloc_buf(b);
1497  b->ptr = b->end - cnt;
1498  assert(b->ptr >= b->buf);
1499 }
1500
1501 STDCHAR *
1502 PerlIOBuf_get_ptr(PerlIO *f)
1503 {
1504  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1505  if (!b->buf)
1506   PerlIOBuf_alloc_buf(b);
1507  return b->ptr;
1508 }
1509
1510 SSize_t
1511 PerlIOBuf_get_cnt(PerlIO *f)
1512 {
1513  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1514  if (!b->buf)
1515   PerlIOBuf_alloc_buf(b);
1516  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1517   return (b->end - b->ptr);
1518  return 0;
1519 }
1520
1521 STDCHAR *
1522 PerlIOBuf_get_base(PerlIO *f)
1523 {
1524  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1525  if (!b->buf)
1526   PerlIOBuf_alloc_buf(b);
1527  return b->buf;
1528 }
1529
1530 Size_t
1531 PerlIOBuf_bufsiz(PerlIO *f)
1532 {
1533  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1534  if (!b->buf)
1535   PerlIOBuf_alloc_buf(b);
1536  return (b->end - b->buf);
1537 }
1538
1539 void
1540 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1541 {
1542  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1543  if (!b->buf)
1544   PerlIOBuf_alloc_buf(b);
1545  b->ptr = ptr;
1546  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1547   {
1548    dTHX;
1549    assert(PerlIO_get_cnt(f) == cnt);
1550    assert(b->ptr >= b->buf);
1551   }
1552  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1553 }
1554
1555 PerlIO_funcs PerlIO_perlio = {
1556  "perlio",
1557  sizeof(PerlIOBuf),
1558  0,
1559  PerlIOBase_fileno,
1560  PerlIOBuf_fdopen,
1561  PerlIOBuf_open,
1562  PerlIOBase_reopen,
1563  PerlIOBuf_read,
1564  PerlIOBuf_unread,
1565  PerlIOBuf_write,
1566  PerlIOBuf_seek,
1567  PerlIOBuf_tell,
1568  PerlIOBuf_close,
1569  PerlIOBuf_flush,
1570  PerlIOBase_eof,
1571  PerlIOBase_error,
1572  PerlIOBase_clearerr,
1573  PerlIOBuf_setlinebuf,
1574  PerlIOBuf_get_base,
1575  PerlIOBuf_bufsiz,
1576  PerlIOBuf_get_ptr,
1577  PerlIOBuf_get_cnt,
1578  PerlIOBuf_set_ptrcnt,
1579 };
1580
1581 void
1582 PerlIO_init(void)
1583 {
1584  if (!_perlio)
1585   {
1586    atexit(&PerlIO_cleanup);
1587    PerlIO_fdopen(0,"Ir");
1588    PerlIO_fdopen(1,"Iw");
1589    PerlIO_fdopen(2,"Iw");
1590   }
1591 }
1592
1593 #undef PerlIO_stdin
1594 PerlIO *
1595 PerlIO_stdin(void)
1596 {
1597  if (!_perlio)
1598   PerlIO_init();
1599  return &_perlio[1];
1600 }
1601
1602 #undef PerlIO_stdout
1603 PerlIO *
1604 PerlIO_stdout(void)
1605 {
1606  if (!_perlio)
1607   PerlIO_init();
1608  return &_perlio[2];
1609 }
1610
1611 #undef PerlIO_stderr
1612 PerlIO *
1613 PerlIO_stderr(void)
1614 {
1615  if (!_perlio)
1616   PerlIO_init();
1617  return &_perlio[3];
1618 }
1619
1620 /*--------------------------------------------------------------------------------------*/
1621
1622 #undef PerlIO_getname
1623 char *
1624 PerlIO_getname(PerlIO *f, char *buf)
1625 {
1626  dTHX;
1627  Perl_croak(aTHX_ "Don't know how to get file name");
1628  return NULL;
1629 }
1630
1631
1632 /*--------------------------------------------------------------------------------------*/
1633 /* Functions which can be called on any kind of PerlIO implemented
1634    in terms of above
1635 */
1636
1637 #undef PerlIO_getc
1638 int
1639 PerlIO_getc(PerlIO *f)
1640 {
1641  STDCHAR buf;
1642  int count = PerlIO_read(f,&buf,1);
1643  if (count == 1)
1644   return (unsigned char) buf;
1645  return -1;
1646 }
1647
1648 #undef PerlIO_putc
1649 int
1650 PerlIO_putc(PerlIO *f, int ch)
1651 {
1652  STDCHAR buf = ch;
1653  return PerlIO_write(f,&buf,1);
1654 }
1655
1656 #undef PerlIO_puts
1657 int
1658 PerlIO_puts(PerlIO *f, const char *s)
1659 {
1660  STRLEN len = strlen(s);
1661  return PerlIO_write(f,s,len);
1662 }
1663
1664 #undef PerlIO_rewind
1665 void
1666 PerlIO_rewind(PerlIO *f)
1667 {
1668  PerlIO_seek(f,(Off_t)0,SEEK_SET);
1669  PerlIO_clearerr(f);
1670 }
1671
1672 #undef PerlIO_vprintf
1673 int
1674 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1675 {
1676  dTHX;
1677  SV *sv = newSVpvn("",0);
1678  char *s;
1679  STRLEN len;
1680  sv_vcatpvf(sv, fmt, &ap);
1681  s = SvPV(sv,len);
1682  return PerlIO_write(f,s,len);
1683 }
1684
1685 #undef PerlIO_printf
1686 int
1687 PerlIO_printf(PerlIO *f,const char *fmt,...)
1688 {
1689  va_list ap;
1690  int result;
1691  va_start(ap,fmt);
1692  result = PerlIO_vprintf(f,fmt,ap);
1693  va_end(ap);
1694  return result;
1695 }
1696
1697 #undef PerlIO_stdoutf
1698 int
1699 PerlIO_stdoutf(const char *fmt,...)
1700 {
1701  va_list ap;
1702  int result;
1703  va_start(ap,fmt);
1704  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1705  va_end(ap);
1706  return result;
1707 }
1708
1709 #undef PerlIO_tmpfile
1710 PerlIO *
1711 PerlIO_tmpfile(void)
1712 {
1713  dTHX;
1714  /* I have no idea how portable mkstemp() is ... */
1715  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1716  int fd = mkstemp(SvPVX(sv));
1717  PerlIO *f = NULL;
1718  if (fd >= 0)
1719   {
1720    f = PerlIO_fdopen(fd,"w+");
1721    if (f)
1722     {
1723      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1724     }
1725    unlink(SvPVX(sv));
1726    SvREFCNT_dec(sv);
1727   }
1728  return f;
1729 }
1730
1731 #undef HAS_FSETPOS
1732 #undef HAS_FGETPOS
1733
1734 #endif /* USE_SFIO */
1735 #endif /* PERLIO_IS_STDIO */
1736
1737 /*======================================================================================*/
1738 /* Now some functions in terms of above which may be needed even if
1739    we are not in true PerlIO mode
1740  */
1741
1742 #ifndef HAS_FSETPOS
1743 #undef PerlIO_setpos
1744 int
1745 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1746 {
1747  return PerlIO_seek(f,*pos,0);
1748 }
1749 #else
1750 #ifndef PERLIO_IS_STDIO
1751 #undef PerlIO_setpos
1752 int
1753 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1754 {
1755 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1756  return fsetpos64(f, pos);
1757 #else
1758  return fsetpos(f, pos);
1759 #endif
1760 }
1761 #endif
1762 #endif
1763
1764 #ifndef HAS_FGETPOS
1765 #undef PerlIO_getpos
1766 int
1767 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1768 {
1769  *pos = PerlIO_tell(f);
1770  return 0;
1771 }
1772 #else
1773 #ifndef PERLIO_IS_STDIO
1774 #undef PerlIO_getpos
1775 int
1776 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1777 {
1778 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1779  return fgetpos64(f, pos);
1780 #else
1781  return fgetpos(f, pos);
1782 #endif
1783 }
1784 #endif
1785 #endif
1786
1787 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1788
1789 int
1790 vprintf(char *pat, char *args)
1791 {
1792     _doprnt(pat, args, stdout);
1793     return 0;           /* wrong, but perl doesn't use the return value */
1794 }
1795
1796 int
1797 vfprintf(FILE *fd, char *pat, char *args)
1798 {
1799     _doprnt(pat, args, fd);
1800     return 0;           /* wrong, but perl doesn't use the return value */
1801 }
1802
1803 #endif
1804
1805 #ifndef PerlIO_vsprintf
1806 int
1807 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1808 {
1809  int val = vsprintf(s, fmt, ap);
1810  if (n >= 0)
1811   {
1812    if (strlen(s) >= (STRLEN)n)
1813     {
1814      dTHX;
1815      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1816      my_exit(1);
1817     }
1818   }
1819  return val;
1820 }
1821 #endif
1822
1823 #ifndef PerlIO_sprintf
1824 int
1825 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1826 {
1827  va_list ap;
1828  int result;
1829  va_start(ap,fmt);
1830  result = PerlIO_vsprintf(s, n, fmt, ap);
1831  va_end(ap);
1832  return result;
1833 }
1834 #endif
1835
1836 #endif /* !PERL_IMPLICIT_SYS */
1837