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  while (1)
 913   {
 914    SSize_t len = read(fd,vbuf,count);
 915    if (len >= 0 || errno != EINTR)
 916     return len;
 917   }
 918 }
 919
 920 SSize_t
 921 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
 922 {
 923  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 924  while (1)
 925   {
 926    SSize_t len = write(fd,vbuf,count);
 927    if (len >= 0 || errno != EINTR)
 928     return len;
 929   }
 930 }
 931
 932 IV
 933 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
 934 {
 935  Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
 936  return (new == (Off_t) -1) ? -1 : 0;
 937 }
 938
 939 Off_t
 940 PerlIOUnix_tell(PerlIO *f)
 941 {
 942  return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
 943 }
 944
 945 IV
 946 PerlIOUnix_close(PerlIO *f)
 947 {
 948  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
 949  int code = 0;
 950  while (close(fd) != 0)
 951   {
 952    if (errno != EINTR)
 953     {
 954      code = -1;
 955      break;
 956     }
 957   }
 958  if (code == 0)
 959   {
 960    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 961   }
 962  return code;
 963 }
 964
 965 PerlIO_funcs PerlIO_unix = {
 966  "unix",
 967  sizeof(PerlIOUnix),
 968  0,
 969  PerlIOUnix_fileno,
 970  PerlIOUnix_fdopen,
 971  PerlIOUnix_open,
 972  PerlIOUnix_reopen,
 973  PerlIOUnix_read,
 974  PerlIOBase_unread,
 975  PerlIOUnix_write,
 976  PerlIOUnix_seek,
 977  PerlIOUnix_tell,
 978  PerlIOUnix_close,
 979  PerlIOBase_sync,
 980  PerlIOBase_eof,
 981  PerlIOBase_error,
 982  PerlIOBase_clearerr,
 983  PerlIOBase_setlinebuf,
 984  NULL, /* get_base */
 985  NULL, /* get_bufsiz */
 986  NULL, /* get_ptr */
 987  NULL, /* get_cnt */
 988  NULL, /* set_ptrcnt */
 989 };
 990
 991 /*--------------------------------------------------------------------------------------*/
 992 /* stdio as a layer */
 993
 994 typedef struct
 995 {
 996  struct _PerlIO base;
 997  FILE *         stdio;      /* The stream */
 998 } PerlIOStdio;
 999
1000 IV
1001 PerlIOStdio_fileno(PerlIO *f)
1002 {
1003  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1004 }
1005
1006
1007 PerlIO *
1008 PerlIOStdio_fdopen(int fd,const char *mode)
1009 {
1010  PerlIO *f = NULL;
1011  int init = 0;
1012  if (*mode == 'I')
1013   {
1014    init = 1;
1015    mode++;
1016   }
1017  if (fd >= 0)
1018   {
1019    FILE *stdio = NULL;
1020    if (init)
1021     {
1022      switch(fd)
1023       {
1024        case 0:
1025         stdio = stdin;
1026         break;
1027        case 1:
1028         stdio = stdout;
1029         break;
1030        case 2:
1031         stdio = stderr;
1032         break;
1033       }
1034     }
1035    else
1036     stdio = fdopen(fd,mode);
1037    if (stdio)
1038     {
1039      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1040      s->stdio  = stdio;
1041     }
1042   }
1043  return f;
1044 }
1045
1046 #undef PerlIO_importFILE
1047 PerlIO *
1048 PerlIO_importFILE(FILE *stdio, int fl)
1049 {
1050  PerlIO *f = NULL;
1051  if (stdio)
1052   {
1053    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1054    s->stdio  = stdio;
1055   }
1056  return f;
1057 }
1058
1059 PerlIO *
1060 PerlIOStdio_open(const char *path,const char *mode)
1061 {
1062  PerlIO *f = NULL;
1063  FILE *stdio = fopen(path,mode);
1064  if (stdio)
1065   {
1066    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,mode),PerlIOStdio);
1067    s->stdio  = stdio;
1068   }
1069  return f;
1070 }
1071
1072 int
1073 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1074 {
1075  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1076  FILE *stdio = freopen(path,mode,s->stdio);
1077  if (!s->stdio)
1078   return -1;
1079  s->stdio = stdio;
1080  return 0;
1081 }
1082
1083 SSize_t
1084 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1085 {
1086  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1087  SSize_t got = 0;
1088  if (count == 1)
1089   {
1090    STDCHAR *buf = (STDCHAR *) vbuf;
1091    /* Perl is expecting PerlIO_getc() to fill the buffer
1092     * Linux's stdio does not do that for fread()
1093     */
1094    int ch = fgetc(s);
1095    if (ch != EOF)
1096     {
1097      *buf = ch;
1098      got = 1;
1099     }
1100   }
1101  else
1102   got = fread(vbuf,1,count,s);
1103  return got;
1104 }
1105
1106 SSize_t
1107 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1108 {
1109  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1110  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1111  SSize_t unread = 0;
1112  while (count > 0)
1113   {
1114    int ch = *buf-- & 0xff;
1115    if (ungetc(ch,s) != ch)
1116     break;
1117    unread++;
1118    count--;
1119   }
1120  return unread;
1121 }
1122
1123 SSize_t
1124 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1125 {
1126  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1127 }
1128
1129 IV
1130 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1131 {
1132  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1133  return fseek(stdio,offset,whence);
1134 }
1135
1136 Off_t
1137 PerlIOStdio_tell(PerlIO *f)
1138 {
1139  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1140  return ftell(stdio);
1141 }
1142
1143 IV
1144 PerlIOStdio_close(PerlIO *f)
1145 {
1146  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1147 }
1148
1149 IV
1150 PerlIOStdio_flush(PerlIO *f)
1151 {
1152  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1153  return fflush(stdio);
1154 }
1155
1156 IV
1157 PerlIOStdio_eof(PerlIO *f)
1158 {
1159  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1160 }
1161
1162 IV
1163 PerlIOStdio_error(PerlIO *f)
1164 {
1165  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1166 }
1167
1168 void
1169 PerlIOStdio_clearerr(PerlIO *f)
1170 {
1171  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1172 }
1173
1174 void
1175 PerlIOStdio_setlinebuf(PerlIO *f)
1176 {
1177 #ifdef HAS_SETLINEBUF
1178  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1179 #else
1180  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1181 #endif
1182 }
1183
1184 #ifdef FILE_base
1185 STDCHAR *
1186 PerlIOStdio_get_base(PerlIO *f)
1187 {
1188  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1189  return FILE_base(stdio);
1190 }
1191
1192 Size_t
1193 PerlIOStdio_get_bufsiz(PerlIO *f)
1194 {
1195  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1196  return FILE_bufsiz(stdio);
1197 }
1198 #endif
1199
1200 #ifdef USE_STDIO_PTR
1201 STDCHAR *
1202 PerlIOStdio_get_ptr(PerlIO *f)
1203 {
1204  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1205  return FILE_ptr(stdio);
1206 }
1207
1208 SSize_t
1209 PerlIOStdio_get_cnt(PerlIO *f)
1210 {
1211  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1212  return FILE_cnt(stdio);
1213 }
1214
1215 void
1216 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1217 {
1218  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1219  if (ptr != NULL)
1220   {
1221 #ifdef STDIO_PTR_LVALUE
1222    FILE_ptr(stdio) = ptr;
1223 #ifdef STDIO_PTR_LVAL_SETS_CNT
1224    if (FILE_cnt(stdio) != (cnt))
1225     {
1226      dTHX;
1227      assert(FILE_cnt(stdio) == (cnt));
1228     }
1229 #endif
1230 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1231    /* Setting ptr _does_ change cnt - we are done */
1232    return;
1233 #endif
1234 #else  /* STDIO_PTR_LVALUE */
1235    abort();
1236 #endif /* STDIO_PTR_LVALUE */
1237   }
1238 /* Now (or only) set cnt */
1239 #ifdef STDIO_CNT_LVALUE
1240  FILE_cnt(stdio) = cnt;
1241 #else  /* STDIO_CNT_LVALUE */
1242 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1243  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1244 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1245  abort();
1246 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1247 #endif /* STDIO_CNT_LVALUE */
1248 }
1249
1250 #endif
1251
1252 PerlIO_funcs PerlIO_stdio = {
1253  "stdio",
1254  sizeof(PerlIOStdio),
1255  0,
1256  PerlIOStdio_fileno,
1257  PerlIOStdio_fdopen,
1258  PerlIOStdio_open,
1259  PerlIOStdio_reopen,
1260  PerlIOStdio_read,
1261  PerlIOStdio_unread,
1262  PerlIOStdio_write,
1263  PerlIOStdio_seek,
1264  PerlIOStdio_tell,
1265  PerlIOStdio_close,
1266  PerlIOStdio_flush,
1267  PerlIOStdio_eof,
1268  PerlIOStdio_error,
1269  PerlIOStdio_clearerr,
1270  PerlIOStdio_setlinebuf,
1271 #ifdef FILE_base
1272  PerlIOStdio_get_base,
1273  PerlIOStdio_get_bufsiz,
1274 #else
1275  NULL,
1276  NULL,
1277 #endif
1278 #ifdef USE_STDIO_PTR
1279  PerlIOStdio_get_ptr,
1280  PerlIOStdio_get_cnt,
1281 #if (defined(STDIO_PTR_LVALUE) && \
1282     (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1283  PerlIOStdio_set_ptrcnt
1284 #else  /* STDIO_PTR_LVALUE */
1285  NULL
1286 #endif /* STDIO_PTR_LVALUE */
1287 #else  /* USE_STDIO_PTR */
1288  NULL,
1289  NULL,
1290  NULL
1291 #endif /* USE_STDIO_PTR */
1292 };
1293
1294 #undef PerlIO_exportFILE
1295 FILE *
1296 PerlIO_exportFILE(PerlIO *f, int fl)
1297 {
1298  PerlIO_flush(f);
1299  /* Should really push stdio discipline when we have them */
1300  return fdopen(PerlIO_fileno(f),"r+");
1301 }
1302
1303 #undef PerlIO_findFILE
1304 FILE *
1305 PerlIO_findFILE(PerlIO *f)
1306 {
1307  return PerlIO_exportFILE(f,0);
1308 }
1309
1310 #undef PerlIO_releaseFILE
1311 void
1312 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1313 {
1314 }
1315
1316 /*--------------------------------------------------------------------------------------*/
1317 /* perlio buffer layer */
1318
1319 typedef struct
1320 {
1321  struct _PerlIO base;
1322  Off_t          posn;       /* Offset of buf into the file */
1323  STDCHAR *      buf;        /* Start of buffer */
1324  STDCHAR *      end;        /* End of valid part of buffer */
1325  STDCHAR *      ptr;        /* Current position in buffer */
1326  Size_t         bufsiz;     /* Size of buffer */
1327  IV             oneword;    /* Emergency buffer */
1328 } PerlIOBuf;
1329
1330
1331 PerlIO *
1332 PerlIOBuf_fdopen(int fd, const char *mode)
1333 {
1334  PerlIO_funcs *tab = PerlIO_default_btm();
1335  int init = 0;
1336  PerlIO *f;
1337  if (*mode == 'I')
1338   {
1339    init = 1;
1340    mode++;
1341   }
1342  f = (*tab->Fdopen)(fd,mode);
1343  if (f)
1344   {
1345    /* Initial stderr is unbuffered */
1346    if (!init || fd != 2)
1347     {
1348      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1349      b->posn = PerlIO_tell(PerlIONext(f));
1350     }
1351   }
1352  return f;
1353 }
1354
1355 PerlIO *
1356 PerlIOBuf_open(const char *path, const char *mode)
1357 {
1358  PerlIO_funcs *tab = PerlIO_default_btm();
1359  PerlIO *f = (*tab->Open)(path,mode);
1360  if (f)
1361   {
1362    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,&PerlIO_perlio,NULL),PerlIOBuf);
1363    b->posn = 0;
1364   }
1365  return f;
1366 }
1367
1368 int
1369 PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1370 {
1371  return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1372 }
1373
1374 void
1375 PerlIOBuf_alloc_buf(PerlIOBuf *b)
1376 {
1377  if (!b->bufsiz)
1378   b->bufsiz = 4096;
1379  New('B',b->buf,b->bufsiz,STDCHAR);
1380  if (!b->buf)
1381   {
1382    b->buf = (STDCHAR *)&b->oneword;
1383    b->bufsiz = sizeof(b->oneword);
1384   }
1385  b->ptr = b->buf;
1386  b->end = b->ptr;
1387 }
1388
1389 /* This "flush" is akin to sfio's sync in that it handles files in either
1390    read or write state
1391 */
1392 IV
1393 PerlIOBuf_flush(PerlIO *f)
1394 {
1395  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1396  int code = 0;
1397  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1398   {
1399    /* write() the buffer */
1400    STDCHAR *p = b->buf;
1401    int count;
1402    while (p < b->ptr)
1403     {
1404      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1405      if (count > 0)
1406       {
1407        p += count;
1408       }
1409      else if (count < 0)
1410       {
1411        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1412        code = -1;
1413        break;
1414       }
1415     }
1416    b->posn += (p - b->buf);
1417   }
1418  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1419   {
1420    /* Note position change */
1421    b->posn += (b->ptr - b->buf);
1422    if (b->ptr < b->end)
1423     {
1424      /* We did not consume all of it */
1425      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1426       {
1427        b->posn = PerlIO_tell(PerlIONext(f));
1428       }
1429     }
1430   }
1431  b->ptr = b->end = b->buf;
1432  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1433  if (PerlIO_flush(PerlIONext(f)) != 0)
1434   code = -1;
1435  return code;
1436 }
1437
1438 SSize_t
1439 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1440 {
1441  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1442  STDCHAR *buf = (STDCHAR *) vbuf;
1443  if (f)
1444   {
1445    Size_t got = 0;
1446    if (!b->ptr)
1447     PerlIOBuf_alloc_buf(b);
1448    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1449     return 0;
1450    while (count > 0)
1451     {
1452      SSize_t avail = (b->end - b->ptr);
1453      if ((SSize_t) count < avail)
1454       avail = count;
1455      if (avail > 0)
1456       {
1457        Copy(b->ptr,buf,avail,char);
1458        got     += avail;
1459        b->ptr  += avail;
1460        count   -= avail;
1461        buf     += avail;
1462       }
1463      if (count && (b->ptr >= b->end))
1464       {
1465        PerlIO_flush(f);
1466        b->ptr = b->end = b->buf;
1467        avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1468        if (avail <= 0)
1469         {
1470          if (avail == 0)
1471           PerlIOBase(f)->flags |= PERLIO_F_EOF;
1472          else
1473           PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1474          break;
1475         }
1476        b->end      = b->buf+avail;
1477        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1478       }
1479     }
1480    return got;
1481   }
1482  return 0;
1483 }
1484
1485 SSize_t
1486 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1487 {
1488  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1489  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1490  SSize_t unread = 0;
1491  SSize_t avail;
1492  if (!b->buf)
1493   PerlIOBuf_alloc_buf(b);
1494  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1495   PerlIO_flush(f);
1496  if (b->buf)
1497   {
1498    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1499     {
1500      avail = (b->ptr - b->buf);
1501      if (avail > (SSize_t) count)
1502       avail = count;
1503      b->ptr -= avail;
1504     }
1505    else
1506     {
1507      avail = b->bufsiz;
1508      if (avail > (SSize_t) count)
1509       avail = count;
1510      b->end = b->ptr + avail;
1511     }
1512    if (avail > 0)
1513     {
1514      buf    -= avail;
1515      if (buf != b->ptr)
1516       {
1517        Copy(buf,b->ptr,avail,char);
1518       }
1519      count  -= avail;
1520      unread += avail;
1521      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1522     }
1523   }
1524  return unread;
1525 }
1526
1527 SSize_t
1528 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1529 {
1530  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1531  const STDCHAR *buf = (const STDCHAR *) vbuf;
1532  Size_t written = 0;
1533  if (!b->buf)
1534   PerlIOBuf_alloc_buf(b);
1535  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1536   return 0;
1537  while (count > 0)
1538   {
1539    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1540    if ((SSize_t) count < avail)
1541     avail = count;
1542    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1543    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1544     {
1545      while (avail > 0)
1546       {
1547        int ch = *buf++;
1548        *(b->ptr)++ = ch;
1549        count--;
1550        avail--;
1551        written++;
1552        if (ch == '\n')
1553         {
1554          PerlIO_flush(f);
1555          break;
1556         }
1557       }
1558     }
1559    else
1560     {
1561      if (avail)
1562       {
1563        Copy(buf,b->ptr,avail,char);
1564        count   -= avail;
1565        buf     += avail;
1566        written += avail;
1567        b->ptr  += avail;
1568       }
1569     }
1570    if (b->ptr >= (b->buf + b->bufsiz))
1571     PerlIO_flush(f);
1572   }
1573  return written;
1574 }
1575
1576 IV
1577 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1578 {
1579  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1580  int code;
1581  code = PerlIO_flush(f);
1582  if (code == 0)
1583   {
1584    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1585    code = PerlIO_seek(PerlIONext(f),offset,whence);
1586    if (code == 0)
1587     {
1588      b->posn = PerlIO_tell(PerlIONext(f));
1589     }
1590   }
1591  return code;
1592 }
1593
1594 Off_t
1595 PerlIOBuf_tell(PerlIO *f)
1596 {
1597  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1598  Off_t posn = b->posn;
1599  if (b->buf)
1600   posn += (b->ptr - b->buf);
1601  return posn;
1602 }
1603
1604 IV
1605 PerlIOBuf_close(PerlIO *f)
1606 {
1607  IV code = PerlIOBase_close(f);
1608  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1609  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1610   {
1611    Safefree(b->buf);
1612   }
1613  b->buf = NULL;
1614  b->ptr = b->end = b->buf;
1615  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1616  return code;
1617 }
1618
1619 void
1620 PerlIOBuf_setlinebuf(PerlIO *f)
1621 {
1622  if (f)
1623   {
1624    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1625   }
1626 }
1627
1628 void
1629 PerlIOBuf_set_cnt(PerlIO *f, int cnt)
1630 {
1631  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1632  dTHX;
1633  if (!b->buf)
1634   PerlIOBuf_alloc_buf(b);
1635  b->ptr = b->end - cnt;
1636  assert(b->ptr >= b->buf);
1637 }
1638
1639 STDCHAR *
1640 PerlIOBuf_get_ptr(PerlIO *f)
1641 {
1642  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1643  if (!b->buf)
1644   PerlIOBuf_alloc_buf(b);
1645  return b->ptr;
1646 }
1647
1648 SSize_t
1649 PerlIOBuf_get_cnt(PerlIO *f)
1650 {
1651  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1652  if (!b->buf)
1653   PerlIOBuf_alloc_buf(b);
1654  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1655   return (b->end - b->ptr);
1656  return 0;
1657 }
1658
1659 STDCHAR *
1660 PerlIOBuf_get_base(PerlIO *f)
1661 {
1662  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1663  if (!b->buf)
1664   PerlIOBuf_alloc_buf(b);
1665  return b->buf;
1666 }
1667
1668 Size_t
1669 PerlIOBuf_bufsiz(PerlIO *f)
1670 {
1671  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1672  if (!b->buf)
1673   PerlIOBuf_alloc_buf(b);
1674  return (b->end - b->buf);
1675 }
1676
1677 void
1678 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1679 {
1680  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1681  if (!b->buf)
1682   PerlIOBuf_alloc_buf(b);
1683  b->ptr = ptr;
1684  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1685   {
1686    dTHX;
1687    assert(PerlIO_get_cnt(f) == cnt);
1688    assert(b->ptr >= b->buf);
1689   }
1690  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1691 }
1692
1693 PerlIO_funcs PerlIO_perlio = {
1694  "perlio",
1695  sizeof(PerlIOBuf),
1696  0,
1697  PerlIOBase_fileno,
1698  PerlIOBuf_fdopen,
1699  PerlIOBuf_open,
1700  PerlIOBase_reopen,
1701  PerlIOBuf_read,
1702  PerlIOBuf_unread,
1703  PerlIOBuf_write,
1704  PerlIOBuf_seek,
1705  PerlIOBuf_tell,
1706  PerlIOBuf_close,
1707  PerlIOBuf_flush,
1708  PerlIOBase_eof,
1709  PerlIOBase_error,
1710  PerlIOBase_clearerr,
1711  PerlIOBuf_setlinebuf,
1712  PerlIOBuf_get_base,
1713  PerlIOBuf_bufsiz,
1714  PerlIOBuf_get_ptr,
1715  PerlIOBuf_get_cnt,
1716  PerlIOBuf_set_ptrcnt,
1717 };
1718
1719 void
1720 PerlIO_init(void)
1721 {
1722  if (!_perlio)
1723   {
1724    atexit(&PerlIO_cleanup);
1725   }
1726 }
1727
1728 #undef PerlIO_stdin
1729 PerlIO *
1730 PerlIO_stdin(void)
1731 {
1732  if (!_perlio)
1733   PerlIO_stdstreams();
1734  return &_perlio[1];
1735 }
1736
1737 #undef PerlIO_stdout
1738 PerlIO *
1739 PerlIO_stdout(void)
1740 {
1741  if (!_perlio)
1742   PerlIO_stdstreams();
1743  return &_perlio[2];
1744 }
1745
1746 #undef PerlIO_stderr
1747 PerlIO *
1748 PerlIO_stderr(void)
1749 {
1750  if (!_perlio)
1751   PerlIO_stdstreams();
1752  return &_perlio[3];
1753 }
1754
1755 /*--------------------------------------------------------------------------------------*/
1756
1757 #undef PerlIO_getname
1758 char *
1759 PerlIO_getname(PerlIO *f, char *buf)
1760 {
1761  dTHX;
1762  Perl_croak(aTHX_ "Don't know how to get file name");
1763  return NULL;
1764 }
1765
1766
1767 /*--------------------------------------------------------------------------------------*/
1768 /* Functions which can be called on any kind of PerlIO implemented
1769    in terms of above
1770 */
1771
1772 #undef PerlIO_getc
1773 int
1774 PerlIO_getc(PerlIO *f)
1775 {
1776  STDCHAR buf[1];
1777  SSize_t count = PerlIO_read(f,buf,1);
1778  if (count == 1)
1779   {
1780    return (unsigned char) buf[0];
1781   }
1782  return EOF;
1783 }
1784
1785 #undef PerlIO_ungetc
1786 int
1787 PerlIO_ungetc(PerlIO *f, int ch)
1788 {
1789  if (ch != EOF)
1790   {
1791    STDCHAR buf = ch;
1792    if (PerlIO_unread(f,&buf,1) == 1)
1793     return ch;
1794   }
1795  return EOF;
1796 }
1797
1798 #undef PerlIO_putc
1799 int
1800 PerlIO_putc(PerlIO *f, int ch)
1801 {
1802  STDCHAR buf = ch;
1803  return PerlIO_write(f,&buf,1);
1804 }
1805
1806 #undef PerlIO_puts
1807 int
1808 PerlIO_puts(PerlIO *f, const char *s)
1809 {
1810  STRLEN len = strlen(s);
1811  return PerlIO_write(f,s,len);
1812 }
1813
1814 #undef PerlIO_rewind
1815 void
1816 PerlIO_rewind(PerlIO *f)
1817 {
1818  PerlIO_seek(f,(Off_t)0,SEEK_SET);
1819  PerlIO_clearerr(f);
1820 }
1821
1822 #undef PerlIO_vprintf
1823 int
1824 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
1825 {
1826  dTHX;
1827  SV *sv = newSVpvn("",0);
1828  char *s;
1829  STRLEN len;
1830  sv_vcatpvf(sv, fmt, &ap);
1831  s = SvPV(sv,len);
1832  return PerlIO_write(f,s,len);
1833 }
1834
1835 #undef PerlIO_printf
1836 int
1837 PerlIO_printf(PerlIO *f,const char *fmt,...)
1838 {
1839  va_list ap;
1840  int result;
1841  va_start(ap,fmt);
1842  result = PerlIO_vprintf(f,fmt,ap);
1843  va_end(ap);
1844  return result;
1845 }
1846
1847 #undef PerlIO_stdoutf
1848 int
1849 PerlIO_stdoutf(const char *fmt,...)
1850 {
1851  va_list ap;
1852  int result;
1853  va_start(ap,fmt);
1854  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
1855  va_end(ap);
1856  return result;
1857 }
1858
1859 #undef PerlIO_tmpfile
1860 PerlIO *
1861 PerlIO_tmpfile(void)
1862 {
1863  dTHX;
1864  /* I have no idea how portable mkstemp() is ... */
1865  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
1866  int fd = mkstemp(SvPVX(sv));
1867  PerlIO *f = NULL;
1868  if (fd >= 0)
1869   {
1870    f = PerlIO_fdopen(fd,"w+");
1871    if (f)
1872     {
1873      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
1874     }
1875    unlink(SvPVX(sv));
1876    SvREFCNT_dec(sv);
1877   }
1878  return f;
1879 }
1880
1881 #undef HAS_FSETPOS
1882 #undef HAS_FGETPOS
1883
1884 #endif /* USE_SFIO */
1885 #endif /* PERLIO_IS_STDIO */
1886
1887 /*======================================================================================*/
1888 /* Now some functions in terms of above which may be needed even if
1889    we are not in true PerlIO mode
1890  */
1891
1892 #ifndef HAS_FSETPOS
1893 #undef PerlIO_setpos
1894 int
1895 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1896 {
1897  return PerlIO_seek(f,*pos,0);
1898 }
1899 #else
1900 #ifndef PERLIO_IS_STDIO
1901 #undef PerlIO_setpos
1902 int
1903 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
1904 {
1905 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1906  return fsetpos64(f, pos);
1907 #else
1908  return fsetpos(f, pos);
1909 #endif
1910 }
1911 #endif
1912 #endif
1913
1914 #ifndef HAS_FGETPOS
1915 #undef PerlIO_getpos
1916 int
1917 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1918 {
1919  *pos = PerlIO_tell(f);
1920  return 0;
1921 }
1922 #else
1923 #ifndef PERLIO_IS_STDIO
1924 #undef PerlIO_getpos
1925 int
1926 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
1927 {
1928 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
1929  return fgetpos64(f, pos);
1930 #else
1931  return fgetpos(f, pos);
1932 #endif
1933 }
1934 #endif
1935 #endif
1936
1937 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
1938
1939 int
1940 vprintf(char *pat, char *args)
1941 {
1942     _doprnt(pat, args, stdout);
1943     return 0;           /* wrong, but perl doesn't use the return value */
1944 }
1945
1946 int
1947 vfprintf(FILE *fd, char *pat, char *args)
1948 {
1949     _doprnt(pat, args, fd);
1950     return 0;           /* wrong, but perl doesn't use the return value */
1951 }
1952
1953 #endif
1954
1955 #ifndef PerlIO_vsprintf
1956 int
1957 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
1958 {
1959  int val = vsprintf(s, fmt, ap);
1960  if (n >= 0)
1961   {
1962    if (strlen(s) >= (STRLEN)n)
1963     {
1964      dTHX;
1965      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
1966      my_exit(1);
1967     }
1968   }
1969  return val;
1970 }
1971 #endif
1972
1973 #ifndef PerlIO_sprintf
1974 int
1975 PerlIO_sprintf(char *s, int n, const char *fmt,...)
1976 {
1977  va_list ap;
1978  int result;
1979  va_start(ap,fmt);
1980  result = PerlIO_vsprintf(s, n, fmt, ap);
1981  va_end(ap);
1982  return result;
1983 }
1984 #endif
1985
1986 #endif /* !PERL_IMPLICIT_SYS */
1987