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