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_warn(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_unread
 517 SSize_t
 518 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 519 {
 520  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 521 }
 522
 523 #undef PerlIO_write
 524 SSize_t
 525 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 526 {
 527  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 528 }
 529
 530 #undef PerlIO_seek
 531 int
 532 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 533 {
 534  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 535 }
 536
 537 #undef PerlIO_tell
 538 Off_t
 539 PerlIO_tell(PerlIO *f)
 540 {
 541  return (*PerlIOBase(f)->tab->Tell)(f);
 542 }
 543
 544 #undef PerlIO_flush
 545 int
 546 PerlIO_flush(PerlIO *f)
 547 {
 548  if (f)
 549   {
 550    return (*PerlIOBase(f)->tab->Flush)(f);
 551   }
 552  else
 553   {
 554    PerlIO **table = &_perlio;
 555    int code = 0;
 556    while ((f = *table))
 557     {
 558      int i;
 559      table = (PerlIO **)(f++);
 560      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 561       {
 562        if (*f && PerlIO_flush(f) != 0)
 563         code = -1;
 564        f++;
 565       }
 566     }
 567    return code;
 568   }
 569 }
 570
 571 #undef PerlIO_isutf8
 572 int
 573 PerlIO_isutf8(PerlIO *f)
 574 {
 575  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 576 }
 577
 578 #undef PerlIO_eof
 579 int
 580 PerlIO_eof(PerlIO *f)
 581 {
 582  return (*PerlIOBase(f)->tab->Eof)(f);
 583 }
 584
 585 #undef PerlIO_error
 586 int
 587 PerlIO_error(PerlIO *f)
 588 {
 589  return (*PerlIOBase(f)->tab->Error)(f);
 590 }
 591
 592 #undef PerlIO_clearerr
 593 void
 594 PerlIO_clearerr(PerlIO *f)
 595 {
 596  (*PerlIOBase(f)->tab->Clearerr)(f);
 597 }
 598
 599 #undef PerlIO_setlinebuf
 600 void
 601 PerlIO_setlinebuf(PerlIO *f)
 602 {
 603  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 604 }
 605
 606 #undef PerlIO_has_base
 607 int
 608 PerlIO_has_base(PerlIO *f)
 609 {
 610  if (f && *f)
 611   {
 612    return (PerlIOBase(f)->tab->Get_base != NULL);
 613   }
 614  return 0;
 615 }
 616
 617 #undef PerlIO_fast_gets
 618 int
 619 PerlIO_fast_gets(PerlIO *f)
 620 {
 621  if (f && *f)
 622   {
 623    PerlIOl *l = PerlIOBase(f);
 624    return (l->tab->Set_ptrcnt != NULL);
 625   }
 626  return 0;
 627 }
 628
 629 #undef PerlIO_has_cntptr
 630 int
 631 PerlIO_has_cntptr(PerlIO *f)
 632 {
 633  if (f && *f)
 634   {
 635    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 636    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 637   }
 638  return 0;
 639 }
 640
 641 #undef PerlIO_canset_cnt
 642 int
 643 PerlIO_canset_cnt(PerlIO *f)
 644 {
 645  if (f && *f)
 646   {
 647    PerlIOl *l = PerlIOBase(f);
 648    return (l->tab->Set_ptrcnt != NULL);
 649   }
 650  return 0;
 651 }
 652
 653 #undef PerlIO_get_base
 654 STDCHAR *
 655 PerlIO_get_base(PerlIO *f)
 656 {
 657  return (*PerlIOBase(f)->tab->Get_base)(f);
 658 }
 659
 660 #undef PerlIO_get_bufsiz
 661 int
 662 PerlIO_get_bufsiz(PerlIO *f)
 663 {
 664  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 665 }
 666
 667 #undef PerlIO_get_ptr
 668 STDCHAR *
 669 PerlIO_get_ptr(PerlIO *f)
 670 {
 671  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 672 }
 673
 674 #undef PerlIO_get_cnt
 675 int
 676 PerlIO_get_cnt(PerlIO *f)
 677 {
 678  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 679 }
 680
 681 #undef PerlIO_set_cnt
 682 void
 683 PerlIO_set_cnt(PerlIO *f,int cnt)
 684 {
 685  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 686 }
 687
 688 #undef PerlIO_set_ptrcnt
 689 void
 690 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 691 {
 692  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 693 }
 694
 695 /*--------------------------------------------------------------------------------------*/
 696 /* "Methods" of the "base class" */
 697
 698 IV
 699 PerlIOBase_fileno(PerlIO *f)
 700 {
 701  return PerlIO_fileno(PerlIONext(f));
 702 }
 703
 704 PerlIO *
 705 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 706 {
 707  PerlIOl *l = NULL;
 708  Newc('L',l,tab->size,char,PerlIOl);
 709  if (l)
 710   {
 711    Zero(l,tab->size,char);
 712    l->next = *f;
 713    l->tab  = tab;
 714    *f      = l;
 715    PerlIOBase_init(f,mode);
 716   }
 717  return f;
 718 }
 719
 720 SSize_t
 721 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 722 {
 723  Off_t old = PerlIO_tell(f);
 724  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 725   {
 726    Off_t new = PerlIO_tell(f);
 727    return old - new;
 728   }
 729  return 0;
 730 }
 731
 732 IV
 733 PerlIOBase_sync(PerlIO *f)
 734 {
 735  return 0;
 736 }
 737
 738 IV
 739 PerlIOBase_close(PerlIO *f)
 740 {
 741  IV code = 0;
 742  if (PerlIO_flush(f) != 0)
 743   code = -1;
 744  if (PerlIO_close(PerlIONext(f)) != 0)
 745   code = -1;
 746  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 747  return code;
 748 }
 749
 750 IV
 751 PerlIOBase_eof(PerlIO *f)
 752 {
 753  if (f && *f)
 754   {
 755    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
 756   }
 757  return 1;
 758 }
 759
 760 IV
 761 PerlIOBase_error(PerlIO *f)
 762 {
 763  if (f && *f)
 764   {
 765    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
 766   }
 767  return 1;
 768 }
 769
 770 void
 771 PerlIOBase_clearerr(PerlIO *f)
 772 {
 773  if (f && *f)
 774   {
 775    PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
 776   }
 777 }
 778
 779 void
 780 PerlIOBase_setlinebuf(PerlIO *f)
 781 {
 782
 783 }
 784
 785
 786
 787 /*--------------------------------------------------------------------------------------*/
 788 /* Bottom-most level for UNIX-like case */
 789
 790 typedef struct
 791 {
 792  struct _PerlIO base;       /* The generic part */
 793  int            fd;         /* UNIX like file descriptor */
 794  int            oflags;     /* open/fcntl flags */
 795 } PerlIOUnix;
 796
 797 int
 798 PerlIOUnix_oflags(const char *mode)
 799 {
 800  int oflags = -1;
 801  switch(*mode)
 802   {
 803    case 'r':
 804     oflags = O_RDONLY;
 805     if (*++mode == '+')
 806      {
 807       oflags = O_RDWR;
 808       mode++;
 809      }
 810     break;
 811
 812    case 'w':
 813     oflags = O_CREAT|O_TRUNC;
 814     if (*++mode == '+')
 815      {
 816       oflags |= O_RDWR;
 817       mode++;
 818      }
 819     else
 820      oflags |= O_WRONLY;
 821     break;
 822
 823    case 'a':
 824     oflags = O_CREAT|O_APPEND;
 825     if (*++mode == '+')
 826      {
 827       oflags |= O_RDWR;
 828       mode++;
 829      }
 830     else
 831      oflags |= O_WRONLY;
 832     break;
 833   }
 834  if (*mode || oflags == -1)
 835   {
 836    errno = EINVAL;
 837    oflags = -1;
 838   }
 839  return oflags;
 840 }
 841
 842 IV
 843 PerlIOUnix_fileno(PerlIO *f)
 844 {
 845  return PerlIOSelf(f,PerlIOUnix)->fd;
 846 }
 847
 848 PerlIO *
 849 PerlIOUnix_fdopen(int fd,const char *mode)
 850 {
 851  PerlIO *f = NULL;
 852  if (*mode == 'I')
 853   mode++;
 854  if (fd >= 0)
 855   {
 856    int oflags = PerlIOUnix_oflags(mode);
 857    if (oflags != -1)
 858     {
 859      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
 860      s->fd     = fd;
 861      s->oflags = oflags;
 862      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 863     }
 864   }
 865  return f;
 866 }
 867
 868 PerlIO *
 869 PerlIOUnix_open(const char *path,const char *mode)
 870 {
 871  PerlIO *f = NULL;
 872  int oflags = PerlIOUnix_oflags(mode);
 873  if (oflags != -1)
 874   {
 875    int fd = open(path,oflags,0666);
 876    if (fd >= 0)
 877     {
 878      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_unix,mode),PerlIOUnix);
 879      s->fd     = fd;
 880      s->oflags = oflags;
 881      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 882     }
 883   }
 884  return f;
 885 }
 886
 887 int
 888 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
 889 {
 890  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
 891  int oflags = PerlIOUnix_oflags(mode);
 892  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
 893   (*PerlIOBase(f)->tab->Close)(f);
 894  if (oflags != -1)
 895   {
 896    int fd = open(path,oflags,0666);
 897    if (fd >= 0)
 898     {
 899      s->fd = fd;
 900      s->oflags = oflags;
 901      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 902      return 0;
 903     }
 904   }
 905  return -1;
 906 }
 907
 908 SSize_t
 909 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
 910 {
 911  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 912  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
 913   return 0;
 914  while (1)
 915   {
 916    SSize_t len = read(fd,vbuf,count);
 917    if (len >= 0 || errno != EINTR)
 918     return len;
 919   }
 920 }
 921
 922 SSize_t
 923 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
 924 {
 925  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 926  while (1)
 927   {
 928    SSize_t len = write(fd,vbuf,count);
 929    if (len >= 0 || errno != EINTR)
 930     return len;
 931   }
 932 }
 933
 934 IV
 935 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
 936 {
 937  Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
 938  return (new == (Off_t) -1) ? -1 : 0;
 939 }
 940
 941 Off_t
 942 PerlIOUnix_tell(PerlIO *f)
 943 {
 944  return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
 945 }
 946
 947 IV
 948 PerlIOUnix_close(PerlIO *f)
 949 {
 950  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 951  int code = 0;
 952  while (close(fd) != 0)
 953   {
 954    if (errno != EINTR)
 955     {
 956      code = -1;
 957      break;
 958     }
 959   }
 960  if (code == 0)
 961   {
 962    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 963   }
 964  return code;
 965 }
 966
 967 PerlIO_funcs PerlIO_unix = {
 968  "unix",
 969  sizeof(PerlIOUnix),
 970  0,
 971  PerlIOUnix_fileno,
 972  PerlIOUnix_fdopen,
 973  PerlIOUnix_open,
 974  PerlIOUnix_reopen,
 975  PerlIOUnix_read,
 976  PerlIOBase_unread,
 977  PerlIOUnix_write,
 978  PerlIOUnix_seek,
 979  PerlIOUnix_tell,
 980  PerlIOUnix_close,
 981  PerlIOBase_sync,
 982  PerlIOBase_eof,
 983  PerlIOBase_error,
 984  PerlIOBase_clearerr,
 985  PerlIOBase_setlinebuf,
 986  NULL, /* get_base */
 987  NULL, /* get_bufsiz */
 988  NULL, /* get_ptr */
 989  NULL, /* get_cnt */
 990  NULL, /* set_ptrcnt */
 991 };
 992
 993 /*--------------------------------------------------------------------------------------*/
 994 /* stdio as a layer */
 995
 996 typedef struct
 997 {
 998  struct _PerlIO base;
 999  FILE *         stdio;      /* The stream */
1000 } PerlIOStdio;
1001
1002 IV
1003 PerlIOStdio_fileno(PerlIO *f)
1004 {
1005  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1006 }
1007
1008
1009 PerlIO *
1010 PerlIOStdio_fdopen(int fd,const char *mode)
1011 {
1012  PerlIO *f = NULL;
1013  int init = 0;
1014  if (*mode == 'I')
1015   {
1016    init = 1;
1017    mode++;
1018   }
1019  if (fd >= 0)
1020   {
1021    FILE *stdio = NULL;
1022    if (init)
1023     {
1024      switch(fd)
1025       {
1026        case 0:
1027         stdio = stdin;
1028         break;
1029        case 1:
1030         stdio = stdout;
1031         break;
1032        case 2:
1033         stdio = stderr;
1034         break;
1035       }
1036     }
1037    else
1038     stdio = fdopen(fd,mode);
1039    if (stdio)
1040     {
1041      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1042      s->stdio  = stdio;
1043     }
1044   }
1045  return f;
1046 }
1047
1048 #undef PerlIO_importFILE
1049 PerlIO *
1050 PerlIO_importFILE(FILE *stdio, int fl)
1051 {
1052  PerlIO *f = NULL;
1053  if (stdio)
1054   {
1055    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1056    s->stdio  = stdio;
1057   }
1058  return f;
1059 }
1060
1061 PerlIO *
1062 PerlIOStdio_open(const char *path,const char *mode)
1063 {
1064  PerlIO *f = NULL;
1065  FILE *stdio = fopen(path,mode);
1066  if (stdio)
1067   {
1068    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1069    s->stdio  = stdio;
1070   }
1071  return f;
1072 }
1073
1074 int
1075 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1076 {
1077  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1078  FILE *stdio = freopen(path,mode,s->stdio);
1079  if (!s->stdio)
1080   return -1;
1081  s->stdio = stdio;
1082  return 0;
1083 }
1084
1085 SSize_t
1086 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1087 {
1088  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1089  SSize_t got = 0;
1090  if (count == 1)
1091   {
1092    STDCHAR *buf = (STDCHAR *) vbuf;
1093    /* Perl is expecting PerlIO_getc() to fill the buffer
1094     * Linux's stdio does not do that for fread()
1095     */
1096    int ch = fgetc(s);
1097    if (ch != EOF)
1098     {
1099      *buf = ch;
1100      got = 1;
1101     }
1102   }
1103  else
1104   got = fread(vbuf,1,count,s);
1105  return got;
1106 }
1107
1108 SSize_t
1109 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1110 {
1111  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1112  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1113  SSize_t unread = 0;
1114  while (count > 0)
1115   {
1116    int ch = *buf-- & 0xff;
1117    if (ungetc(ch,s) != ch)
1118     break;
1119    unread++;
1120    count--;
1121   }
1122  return unread;
1123 }
1124
1125 SSize_t
1126 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1127 {
1128  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1129 }
1130
1131 IV
1132 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1133 {
1134  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1135  return fseek(stdio,offset,whence);
1136 }
1137
1138 Off_t
1139 PerlIOStdio_tell(PerlIO *f)
1140 {
1141  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1142  return ftell(stdio);
1143 }
1144
1145 IV
1146 PerlIOStdio_close(PerlIO *f)
1147 {
1148  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1149 }
1150
1151 IV
1152 PerlIOStdio_flush(PerlIO *f)
1153 {
1154  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1155  return fflush(stdio);
1156 }
1157
1158 IV
1159 PerlIOStdio_eof(PerlIO *f)
1160 {
1161  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1162 }
1163
1164 IV
1165 PerlIOStdio_error(PerlIO *f)
1166 {
1167  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1168 }
1169
1170 void
1171 PerlIOStdio_clearerr(PerlIO *f)
1172 {
1173  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1174 }
1175
1176 void
1177 PerlIOStdio_setlinebuf(PerlIO *f)
1178 {
1179 #ifdef HAS_SETLINEBUF
1180  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1181 #else
1182  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1183 #endif
1184 }
1185
1186 #ifdef FILE_base
1187 STDCHAR *
1188 PerlIOStdio_get_base(PerlIO *f)
1189 {
1190  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1191  return FILE_base(stdio);
1192 }
1193
1194 Size_t
1195 PerlIOStdio_get_bufsiz(PerlIO *f)
1196 {
1197  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1198  return FILE_bufsiz(stdio);
1199 }
1200 #endif
1201
1202 #ifdef USE_STDIO_PTR
1203 STDCHAR *
1204 PerlIOStdio_get_ptr(PerlIO *f)
1205 {
1206  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1207  return FILE_ptr(stdio);
1208 }
1209
1210 SSize_t
1211 PerlIOStdio_get_cnt(PerlIO *f)
1212 {
1213  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1214  return FILE_cnt(stdio);
1215 }
1216
1217 void
1218 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1219 {
1220  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1221  if (ptr != NULL)
1222   {
1223 #ifdef STDIO_PTR_LVALUE
1224    FILE_ptr(stdio) = ptr;
1225 #ifdef STDIO_PTR_LVAL_SETS_CNT
1226    if (FILE_cnt(stdio) != (cnt))
1227     {
1228      dTHX;
1229      assert(FILE_cnt(stdio) == (cnt));
1230     }
1231 #endif
1232 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1233    /* Setting ptr _does_ change cnt - we are done */
1234    return;
1235 #endif
1236 #else  /* STDIO_PTR_LVALUE */
1237    abort();
1238 #endif /* STDIO_PTR_LVALUE */
1239   }
1240 /* Now (or only) set cnt */
1241 #ifdef STDIO_CNT_LVALUE
1242  FILE_cnt(stdio) = cnt;
1243 #else  /* STDIO_CNT_LVALUE */
1244 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1245  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1246 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1247  abort();
1248 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1249 #endif /* STDIO_CNT_LVALUE */
1250 }
1251
1252 #endif
1253
1254 PerlIO_funcs PerlIO_stdio = {
1255  "stdio",
1256  sizeof(PerlIOStdio),
1257  0,
1258  PerlIOStdio_fileno,
1259  PerlIOStdio_fdopen,
1260  PerlIOStdio_open,
1261  PerlIOStdio_reopen,
1262  PerlIOStdio_read,
1263  PerlIOStdio_unread,
1264  PerlIOStdio_write,
1265  PerlIOStdio_seek,
1266  PerlIOStdio_tell,
1267  PerlIOStdio_close,
1268  PerlIOStdio_flush,
1269  PerlIOStdio_eof,
1270  PerlIOStdio_error,
1271  PerlIOStdio_clearerr,
1272  PerlIOStdio_setlinebuf,
1273 #ifdef FILE_base
1274  PerlIOStdio_get_base,
1275  PerlIOStdio_get_bufsiz,
1276 #else
1277  NULL,
1278  NULL,
1279 #endif
1280 #ifdef USE_STDIO_PTR
1281  PerlIOStdio_get_ptr,
1282  PerlIOStdio_get_cnt,
1283 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1284  PerlIOStdio_set_ptrcnt
1285 #else  /* STDIO_PTR_LVALUE */
1286  NULL
1287 #endif /* STDIO_PTR_LVALUE */
1288 #else  /* USE_STDIO_PTR */
1289  NULL,
1290  NULL,
1291  NULL
1292 #endif /* USE_STDIO_PTR */
1293 };
1294
1295 #undef PerlIO_exportFILE
1296 FILE *
1297 PerlIO_exportFILE(PerlIO *f, int fl)
1298 {
1299  PerlIO_flush(f);
1300  /* Should really push stdio discipline when we have them */
1301  return fdopen(PerlIO_fileno(f),"r+");
1302 }
1303
1304 #undef PerlIO_findFILE
1305 FILE *
1306 PerlIO_findFILE(PerlIO *f)
1307 {
1308  return PerlIO_exportFILE(f,0);
1309 }
1310
1311 #undef PerlIO_releaseFILE
1312 void
1313 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1314 {
1315 }
1316
1317 /*--------------------------------------------------------------------------------------*/
1318 /* perlio buffer layer */
1319
1320 typedef struct
1321 {
1322  struct _PerlIO base;
1323  Off_t          posn;       /* Offset of buf into the file */
1324  STDCHAR *      buf;        /* Start of buffer */
1325  STDCHAR *      end;        /* End of valid part of buffer */
1326  STDCHAR *      ptr;        /* Current position in buffer */
1327  Size_t         bufsiz;     /* Size of buffer */
1328  IV             oneword;    /* Emergency buffer */
1329 } PerlIOBuf;
1330
1331
1332 PerlIO *
1333 PerlIOBuf_fdopen(int fd, const char *mode)
1334 {
1335  PerlIO_funcs *tab = PerlIO_default_btm();
1336  int init = 0;
1337  PerlIO *f;
1338  if (*mode == 'I')
1339   {
1340    init = 1;
1341    mode++;
1342   }
1343  f = (*tab->Fdopen)(fd,mode);
1344  if (f)
1345   {
1346    /* Initial stderr is unbuffered */
1347    if (!init || fd != 2)
1348     {
1349      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1350      b->posn = PerlIO_tell(PerlIONext(f));
1351     }
1352   }
1353  return f;
1354 }
1355
1356 PerlIO *
1357 PerlIOBuf_open(const char *path, const char *mode)
1358 {
1359  PerlIO_funcs *tab = PerlIO_default_btm();
1360  PerlIO *f = (*tab->Open)(path,mode);
1361  if (f)
1362   {
1363    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1364    b->posn = 0;
1365   }
1366  return f;
1367 }
1368
1369 int
1370 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1371 {
1372  return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1373 }
1374
1375 void
1376 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1377 {
1378  if (!b->bufsiz)
1379   b->bufsiz = 4096;
1380  New('B',b->buf,b->bufsiz,STDCHAR);
1381  if (!b->buf)
1382   {
1383    b->buf = (STDCHAR *)&b->oneword;
1384    b->bufsiz = sizeof(b->oneword);
1385   }
1386  b->ptr = b->buf;
1387  b->end = b->ptr;
1388 }
1389
1390 /* This "flush" is akin to sfio's sync in that it handles files in either
1391    read or write state
1392 */
1393 IV
1394 PerlIOBuf_flush(PerlIO *f)
1395 {
1396  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1397  int code = 0;
1398  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1399   {
1400    /* write() the buffer */
1401    STDCHAR *p = b->buf;
1402    int count;
1403    while (p < b->ptr)
1404     {
1405      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1406      if (count > 0)
1407       {
1408        p += count;
1409       }
1410      else if (count < 0)
1411       {
1412        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1413        code = -1;
1414        break;
1415       }
1416     }
1417    b->posn += (p - b->buf);
1418   }
1419  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1420   {
1421    /* Note position change */
1422    b->posn += (b->ptr - b->buf);
1423    if (b->ptr < b->end)
1424     {
1425      /* We did not consume all of it */
1426      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1427       {
1428        b->posn = PerlIO_tell(PerlIONext(f));
1429       }
1430     }
1431   }
1432  b->ptr = b->end = b->buf;
1433  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1434  if (PerlIO_flush(PerlIONext(f)) != 0)
1435   code = -1;
1436  return code;
1437 }
1438
1439 SSize_t
1440 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1441 {
1442  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1443  STDCHAR *buf = (STDCHAR *) vbuf;
1444  if (f)
1445   {
1446    Size_t got = 0;
1447    if (!b->ptr)
1448     PerlIOBuf_alloc_buf(b);
1449    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1450     return 0;
1451    while (count > 0)
1452     {
1453      SSize_t avail = (b->end - b->ptr);
1454      if ((SSize_t) count < avail)
1455       avail = count;
1456      if (avail > 0)
1457       {
1458        Copy(b->ptr,buf,avail,char);
1459        got     += avail;
1460        b->ptr  += avail;
1461        count   -= avail;
1462        buf     += avail;
1463       }
1464      if (count && (b->ptr >= b->end))
1465       {
1466        PerlIO_flush(f);
1467        b->ptr = b->end = b->buf;
1468        avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1469        if (avail <= 0)
1470         {
1471          if (avail == 0)
1472           PerlIOBase(f)->flags |= PERLIO_F_EOF;
1473          else
1474           PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1475          break;
1476         }
1477        b->end      = b->buf+avail;
1478        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1479       }
1480     }
1481    return got;
1482   }
1483  return 0;
1484 }
1485
1486 SSize_t
1487 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1488 {
1489  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1490  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1491  SSize_t unread = 0;
1492  SSize_t avail;
1493  if (!b->buf)
1494   PerlIOBuf_alloc_buf(b);
1495  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1496   PerlIO_flush(f);
1497  if (b->buf)
1498   {
1499    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1500     {
1501      avail = (b->ptr - b->buf);
1502      if (avail > (SSize_t) count)
1503       avail = count;
1504      b->ptr -= avail;
1505     }
1506    else
1507     {
1508      avail = b->bufsiz;
1509      if (avail > (SSize_t) count)
1510       avail = count;
1511      b->end = b->ptr + avail;
1512     }
1513    if (avail > 0)
1514     {
1515      buf    -= avail;
1516      if (buf != b->ptr)
1517       {
1518        Copy(buf,b->ptr,avail,char);
1519       }
1520      count  -= avail;
1521      unread += avail;
1522      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1523     }
1524   }
1525  return unread;
1526 }
1527
1528 SSize_t
1529 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1530 {
1531  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1532  const STDCHAR *buf = (const STDCHAR *) vbuf;
1533  Size_t written = 0;
1534  if (!b->buf)
1535   PerlIOBuf_alloc_buf(b);
1536  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1537   return 0;
1538  while (count > 0)
1539   {
1540    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1541    if ((SSize_t) count < avail)
1542     avail = count;
1543    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1544    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1545     {
1546      while (avail > 0)
1547       {
1548        int ch = *buf++;
1549        *(b->ptr)++ = ch;
1550        count--;
1551        avail--;
1552        written++;
1553        if (ch == '\n')
1554         {
1555          PerlIO_flush(f);
1556          break;
1557         }
1558       }
1559     }
1560    else
1561     {
1562      if (avail)
1563       {
1564        Copy(buf,b->ptr,avail,char);
1565        count   -= avail;
1566        buf     += avail;
1567        written += avail;
1568        b->ptr  += avail;
1569       }
1570     }
1571    if (b->ptr >= (b->buf + b->bufsiz))
1572     PerlIO_flush(f);
1573   }
1574  return written;
1575 }
1576
1577 IV
1578 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1579 {
1580  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1581  int code;
1582  code = PerlIO_flush(f);
1583  if (code == 0)
1584   {
1585    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1586    code = PerlIO_seek(PerlIONext(f),offset,whence);
1587    if (code == 0)
1588     {
1589      b->posn = PerlIO_tell(PerlIONext(f));
1590     }
1591   }
1592  return code;
1593 }
1594
1595 Off_t
1596 PerlIOBuf_tell(PerlIO *f)
1597 {
1598  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1599  Off_t posn = b->posn;
1600  if (b->buf)
1601   posn += (b->ptr - b->buf);
1602  return posn;
1603 }
1604
1605 IV
1606 PerlIOBuf_close(PerlIO *f)
1607 {
1608  IV code = PerlIOBase_close(f);
1609  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1610  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1611   {
1612    Safefree(b->buf);
1613   }
1614  b->buf = NULL;
1615  b->ptr = b->end = b->buf;
1616  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1617  return code;
1618 }
1619
1620 void
1621 PerlIOBuf_setlinebuf(PerlIO *f)
1622 {
1623  if (f)
1624   {
1625    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1626   }
1627 }
1628
1629 void
1630 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1631 {
1632  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1633  dTHX;
1634  if (!b->buf)
1635   PerlIOBuf_alloc_buf(b);
1636  b->ptr = b->end - cnt;
1637  assert(b->ptr >= b->buf);
1638 }
1639
1640 STDCHAR *
1641 PerlIOBuf_get_ptr(PerlIO *f)
1642 {
1643  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1644  if (!b->buf)
1645   PerlIOBuf_alloc_buf(b);
1646  return b->ptr;
1647 }
1648
1649 SSize_t
1650 PerlIOBuf_get_cnt(PerlIO *f)
1651 {
1652  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1653  if (!b->buf)
1654   PerlIOBuf_alloc_buf(b);
1655  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1656   return (b->end - b->ptr);
1657  return 0;
1658 }
1659
1660 STDCHAR *
1661 PerlIOBuf_get_base(PerlIO *f)
1662 {
1663  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1664  if (!b->buf)
1665   PerlIOBuf_alloc_buf(b);
1666  return b->buf;
1667 }
1668
1669 Size_t
1670 PerlIOBuf_bufsiz(PerlIO *f)
1671 {
1672  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1673  if (!b->buf)
1674   PerlIOBuf_alloc_buf(b);
1675  return (b->end - b->buf);
1676 }
1677
1678 void
1679 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1680 {
1681  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1682  if (!b->buf)
1683   PerlIOBuf_alloc_buf(b);
1684  b->ptr = ptr;
1685  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1686   {
1687    dTHX;
1688    assert(PerlIO_get_cnt(f) == cnt);
1689    assert(b->ptr >= b->buf);
1690   }
1691  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1692 }
1693
1694 PerlIO_funcs PerlIO_perlio = {
1695  "perlio",
1696  sizeof(PerlIOBuf),
1697  0,
1698  PerlIOBase_fileno,
1699  PerlIOBuf_fdopen,
1700  PerlIOBuf_open,
1701  PerlIOBase_reopen,
1702  PerlIOBuf_read,
1703  PerlIOBuf_unread,
1704  PerlIOBuf_write,
1705  PerlIOBuf_seek,
1706  PerlIOBuf_tell,
1707  PerlIOBuf_close,
1708  PerlIOBuf_flush,
1709  PerlIOBase_eof,
1710  PerlIOBase_error,
1711  PerlIOBase_clearerr,
1712  PerlIOBuf_setlinebuf,
1713  PerlIOBuf_get_base,
1714  PerlIOBuf_bufsiz,
1715  PerlIOBuf_get_ptr,
1716  PerlIOBuf_get_cnt,
1717  PerlIOBuf_set_ptrcnt,
1718 };
1719
1720 void
1721 PerlIO_init(void)
1722 {
1723  if (!_perlio)
1724   {
1725    atexit(&PerlIO_cleanup);
1726   }
1727 }
1728
1729 #undef PerlIO_stdin
1730 PerlIO *
1731 PerlIO_stdin(void)
1732 {
1733  if (!_perlio)
1734   PerlIO_stdstreams();
1735  return &_perlio[1];
1736 }
1737
1738 #undef PerlIO_stdout
1739 PerlIO *
1740 PerlIO_stdout(void)
1741 {
1742  if (!_perlio)
1743   PerlIO_stdstreams();
1744  return &_perlio[2];
1745 }
1746
1747 #undef PerlIO_stderr
1748 PerlIO *
1749 PerlIO_stderr(void)
1750 {
1751  if (!_perlio)
1752   PerlIO_stdstreams();
1753  return &_perlio[3];
1754 }
1755
1756 /*--------------------------------------------------------------------------------------*/
1757
1758 #undef PerlIO_getname
1759 char *
1760 PerlIO_getname(PerlIO *f, char *buf)
1761 {
1762  dTHX;
1763  Perl_croak(aTHX_ "Don't know how to get file name");
1764  return NULL;
1765 }
1766
1767
1768 /*--------------------------------------------------------------------------------------*/
1769 /* Functions which can be called on any kind of PerlIO implemented
1770    in terms of above
1771 */
1772
1773 #undef PerlIO_getc
1774 int
1775 PerlIO_getc(PerlIO *f)
1776 {
1777  STDCHAR buf[1];
1778  SSize_t count = PerlIO_read(f,buf,1);
1779  if (count == 1)
1780   {
1781    return (unsigned char) buf[0];
1782   }
1783  return EOF;
1784 }
1785
1786 #undef PerlIO_ungetc
1787 int
1788 PerlIO_ungetc(PerlIO *f, int ch)
1789 {
1790  if (ch != EOF)
1791   {
1792    STDCHAR buf = ch;
1793    if (PerlIO_unread(f,&buf,1) == 1)
1794     return ch;
1795   }
1796  return EOF;
1797 }
1798
1799 #undef PerlIO_putc
1800 int
1801 PerlIO_putc(PerlIO *f, int ch)
1802 {
1803  STDCHAR buf = ch;
1804  return PerlIO_write(f,&buf,1);
1805 }
1806
1807 #undef PerlIO_puts
1808 int
1809 PerlIO_puts(PerlIO *f, const char *s)
1810 {
1811  STRLEN len = strlen(s);
1812  return PerlIO_write(f,s,len);
1813 }
1814
1815 #undef PerlIO_rewind
1816 void
1817 PerlIO_rewind(PerlIO *f)
1818 {
1819  PerlIO_seek(f,(Off_t)0,SEEK_SET);
1820  PerlIO_clearerr(f);
1821 }
1822
1823 #undef PerlIO_vprintf
1824 int
1825 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1826 {
1827  dTHX;
1828  SV *sv = newSVpvn("",0);
1829  char *s;
1830  STRLEN len;
1831  sv_vcatpvf(sv, fmt, &ap);
1832  s = SvPV(sv,len);
1833  return PerlIO_write(f,s,len);
1834 }
1835
1836 #undef PerlIO_printf
1837 int
1838 PerlIO_printf(PerlIO *f,const char *fmt,...)
1839 {
1840  va_list ap;
1841  int result;
1842  va_start(ap,fmt);
1843  result = PerlIO_vprintf(f,fmt,ap);
1844  va_end(ap);
1845  return result;
1846 }
1847
1848 #undef PerlIO_stdoutf
1849 int
1850 PerlIO_stdoutf(const char *fmt,...)
1851 {
1852  va_list ap;
1853  int result;
1854  va_start(ap,fmt);
1855  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1856  va_end(ap);
1857  return result;
1858 }
1859
1860 #undef PerlIO_tmpfile
1861 PerlIO *
1862 PerlIO_tmpfile(void)
1863 {
1864  dTHX;
1865  /* I have no idea how portable mkstemp() is ... */
1866  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1867  int fd = mkstemp(SvPVX(sv));
1868  PerlIO *f = NULL;
1869  if (fd >= 0)
1870   {
1871    f = PerlIO_fdopen(fd,"w+");
1872    if (f)
1873     {
1874      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1875     }
1876    unlink(SvPVX(sv));
1877    SvREFCNT_dec(sv);
1878   }
1879  return f;
1880 }
1881
1882 #undef HAS_FSETPOS
1883 #undef HAS_FGETPOS
1884
1885 #endif /* USE_SFIO */
1886 #endif /* PERLIO_IS_STDIO */
1887
1888 /*======================================================================================*/
1889 /* Now some functions in terms of above which may be needed even if
1890    we are not in true PerlIO mode
1891  */
1892
1893 #ifndef HAS_FSETPOS
1894 #undef PerlIO_setpos
1895 int
1896 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1897 {
1898  return PerlIO_seek(f,*pos,0);
1899 }
1900 #else
1901 #ifndef PERLIO_IS_STDIO
1902 #undef PerlIO_setpos
1903 int
1904 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1905 {
1906 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1907  return fsetpos64(f, pos);
1908 #else
1909  return fsetpos(f, pos);
1910 #endif
1911 }
1912 #endif
1913 #endif
1914
1915 #ifndef HAS_FGETPOS
1916 #undef PerlIO_getpos
1917 int
1918 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1919 {
1920  *pos = PerlIO_tell(f);
1921  return 0;
1922 }
1923 #else
1924 #ifndef PERLIO_IS_STDIO
1925 #undef PerlIO_getpos
1926 int
1927 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1928 {
1929 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1930  return fgetpos64(f, pos);
1931 #else
1932  return fgetpos(f, pos);
1933 #endif
1934 }
1935 #endif
1936 #endif
1937
1938 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1939
1940 int
1941 vprintf(char *pat, char *args)
1942 {
1943     _doprnt(pat, args, stdout);
1944     return 0;           /* wrong, but perl doesn't use the return value */
1945 }
1946
1947 int
1948 vfprintf(FILE *fd, char *pat, char *args)
1949 {
1950     _doprnt(pat, args, fd);
1951     return 0;           /* wrong, but perl doesn't use the return value */
1952 }
1953
1954 #endif
1955
1956 #ifndef PerlIO_vsprintf
1957 int
1958 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1959 {
1960  int val = vsprintf(s, fmt, ap);
1961  if (n >= 0)
1962   {
1963    if (strlen(s) >= (STRLEN)n)
1964     {
1965      dTHX;
1966      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1967      my_exit(1);
1968     }
1969   }
1970  return val;
1971 }
1972 #endif
1973
1974 #ifndef PerlIO_sprintf
1975 int
1976 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1977 {
1978  va_list ap;
1979  int result;
1980  va_start(ap,fmt);
1981  result = PerlIO_vsprintf(s, n, fmt, ap);
1982  va_end(ap);
1983  return result;
1984 }
1985 #endif
1986
1987 #endif /* !PERL_IMPLICIT_SYS */
1988