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