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