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 #ifndef PERLIO_LAYERS
  32 int
  33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  34 {
  35  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
  36  /* NOTREACHED */
  37  return -1;
  38 }
  39 #endif
  40
  41 #if !defined(PERL_IMPLICIT_SYS)
  42
  43 #ifdef PERLIO_IS_STDIO
  44
  45 void
  46 PerlIO_init(void)
  47 {
  48  /* Does nothing (yet) except force this file to be included
  49     in perl binary. That allows this file to force inclusion
  50     of other functions that may be required by loadable
  51     extensions e.g. for FileHandle::tmpfile
  52  */
  53 }
  54
  55 #undef PerlIO_tmpfile
  56 PerlIO *
  57 PerlIO_tmpfile(void)
  58 {
  59  return tmpfile();
  60 }
  61
  62 #else /* PERLIO_IS_STDIO */
  63
  64 #ifdef USE_SFIO
  65
  66 #undef HAS_FSETPOS
  67 #undef HAS_FGETPOS
  68
  69 /* This section is just to make sure these functions
  70    get pulled in from libsfio.a
  71 */
  72
  73 #undef PerlIO_tmpfile
  74 PerlIO *
  75 PerlIO_tmpfile(void)
  76 {
  77  return sftmp(0);
  78 }
  79
  80 void
  81 PerlIO_init(void)
  82 {
  83  /* Force this file to be included  in perl binary. Which allows
  84   *  this file to force inclusion  of other functions that may be
  85   *  required by loadable  extensions e.g. for FileHandle::tmpfile
  86   */
  87
  88  /* Hack
  89   * sfio does its own 'autoflush' on stdout in common cases.
  90   * Flush results in a lot of lseek()s to regular files and
  91   * lot of small writes to pipes.
  92   */
  93  sfset(sfstdout,SF_SHARE,0);
  94 }
  95
  96 #else /* USE_SFIO */
  97 /*======================================================================================*/
  98 /* Implement all the PerlIO interface ourselves.
  99  */
 100
 101 #include "perliol.h"
 102
 103 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 104 #ifdef I_UNISTD
 105 #include <unistd.h>
 106 #endif
 107 #ifdef HAS_MMAP
 108 #include <sys/mman.h>
 109 #endif
 110
 111 #include "XSUB.h"
 112
 113 void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2)));
 114
 115 void
 116 PerlIO_debug(char *fmt,...)
 117 {
 118  static int dbg = 0;
 119  if (!dbg)
 120   {
 121    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 122    if (s && *s)
 123     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 124    else
 125     dbg = -1;
 126   }
 127  if (dbg > 0)
 128   {
 129    dTHX;
 130    va_list ap;
 131    SV *sv = newSVpvn("",0);
 132    char *s;
 133    STRLEN len;
 134    va_start(ap,fmt);
 135    s = CopFILE(PL_curcop);
 136    if (!s)
 137     s = "(none)";
 138    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 139    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 140
 141    s = SvPV(sv,len);
 142    PerlLIO_write(dbg,s,len);
 143    va_end(ap);
 144    SvREFCNT_dec(sv);
 145   }
 146 }
 147
 148 /*--------------------------------------------------------------------------------------*/
 149
 150 /* Inner level routines */
 151
 152 /* Table of pointers to the PerlIO structs (malloc'ed) */
 153 PerlIO *_perlio      = NULL;
 154 #define PERLIO_TABLE_SIZE 64
 155
 156 PerlIO *
 157 PerlIO_allocate(void)
 158 {
 159  /* Find a free slot in the table, allocating new table as necessary */
 160  PerlIO **last = &_perlio;
 161  PerlIO *f;
 162  while ((f = *last))
 163   {
 164    int i;
 165    last = (PerlIO **)(f);
 166    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 167     {
 168      if (!*++f)
 169       {
 170        return f;
 171       }
 172     }
 173   }
 174  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 175  if (!f)
 176   return NULL;
 177  *last = f;
 178  return f+1;
 179 }
 180
 181 void
 182 PerlIO_cleantable(PerlIO **tablep)
 183 {
 184  PerlIO *table = *tablep;
 185  if (table)
 186   {
 187    int i;
 188    PerlIO_cleantable((PerlIO **) &(table[0]));
 189    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 190     {
 191      PerlIO *f = table+i;
 192      if (*f)
 193       PerlIO_close(f);
 194     }
 195    Safefree(table);
 196    *tablep = NULL;
 197   }
 198 }
 199
 200 HV *PerlIO_layer_hv;
 201 AV *PerlIO_layer_av;
 202
 203 void
 204 PerlIO_cleanup(void)
 205 {
 206  PerlIO_cleantable(&_perlio);
 207 }
 208
 209 void
 210 PerlIO_pop(PerlIO *f)
 211 {
 212  PerlIOl *l = *f;
 213  if (l)
 214   {
 215    (*l->tab->Popped)(f);
 216    *f = l->next;
 217    Safefree(l);
 218   }
 219 }
 220
 221 /*--------------------------------------------------------------------------------------*/
 222 /* XS Interface for perl code */
 223
 224 XS(XS_perlio_import)
 225 {
 226  dXSARGS;
 227  GV *gv = CvGV(cv);
 228  char *s = GvNAME(gv);
 229  STRLEN l = GvNAMELEN(gv);
 230  PerlIO_debug("%.*s\n",(int) l,s);
 231  XSRETURN_EMPTY;
 232 }
 233
 234 XS(XS_perlio_unimport)
 235 {
 236  dXSARGS;
 237  GV *gv = CvGV(cv);
 238  char *s = GvNAME(gv);
 239  STRLEN l = GvNAMELEN(gv);
 240  PerlIO_debug("%.*s\n",(int) l,s);
 241  XSRETURN_EMPTY;
 242 }
 243
 244 SV *
 245 PerlIO_find_layer(const char *name, STRLEN len)
 246 {
 247  dTHX;
 248  SV **svp;
 249  SV *sv;
 250  if (len <= 0)
 251   len = strlen(name);
 252  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 253  if (svp && (sv = *svp) && SvROK(sv))
 254   return *svp;
 255  return NULL;
 256 }
 257
 258
 259 static int
 260 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 261 {
 262  if (SvROK(sv))
 263   {
 264    IO *io = GvIOn((GV *)SvRV(sv));
 265    PerlIO *ifp = IoIFP(io);
 266    PerlIO *ofp = IoOFP(io);
 267    AV *av = (AV *) mg->mg_obj;
 268    Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
 269   }
 270  return 0;
 271 }
 272
 273 static int
 274 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 275 {
 276  if (SvROK(sv))
 277   {
 278    IO *io = GvIOn((GV *)SvRV(sv));
 279    PerlIO *ifp = IoIFP(io);
 280    PerlIO *ofp = IoOFP(io);
 281    AV *av = (AV *) mg->mg_obj;
 282    Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
 283   }
 284  return 0;
 285 }
 286
 287 static int
 288 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 289 {
 290  Perl_warn(aTHX_ "clear %_",sv);
 291  return 0;
 292 }
 293
 294 static int
 295 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 296 {
 297  Perl_warn(aTHX_ "free %_",sv);
 298  return 0;
 299 }
 300
 301 MGVTBL perlio_vtab = {
 302  perlio_mg_get,
 303  perlio_mg_set,
 304  NULL, /* len */
 305  NULL,
 306  perlio_mg_free
 307 };
 308
 309 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 310 {
 311  dXSARGS;
 312  SV *sv    = SvRV(ST(1));
 313  AV *av    = newAV();
 314  MAGIC *mg;
 315  int count = 0;
 316  int i;
 317  sv_magic(sv, (SV *)av, '~', NULL, 0);
 318  SvRMAGICAL_off(sv);
 319  mg = mg_find(sv,'~');
 320  mg->mg_virtual = &perlio_vtab;
 321  mg_magical(sv);
 322  Perl_warn(aTHX_ "attrib %_",sv);
 323  for (i=2; i < items; i++)
 324   {
 325    STRLEN len;
 326    const char *name = SvPV(ST(i),len);
 327    SV *layer  = PerlIO_find_layer(name,len);
 328    if (layer)
 329     {
 330      av_push(av,SvREFCNT_inc(layer));
 331     }
 332    else
 333     {
 334      ST(count) = ST(i);
 335      count++;
 336     }
 337   }
 338  SvREFCNT_dec(av);
 339  XSRETURN(count);
 340 }
 341
 342 void
 343 PerlIO_define_layer(PerlIO_funcs *tab)
 344 {
 345  dTHX;
 346  HV *stash = gv_stashpv("perlio::Layer", TRUE);
 347  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 348  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 349 }
 350
 351 PerlIO_funcs *
 352 PerlIO_default_layer(I32 n)
 353 {
 354  dTHX;
 355  SV **svp;
 356  SV *layer;
 357  PerlIO_funcs *tab = &PerlIO_stdio;
 358  int len;
 359  if (!PerlIO_layer_hv)
 360   {
 361    const char *s  = PerlEnv_getenv("PERLIO");
 362    newXS("perlio::import",XS_perlio_import,__FILE__);
 363    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 364 #if 0
 365    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 366 #endif
 367    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 368    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 369    PerlIO_define_layer(&PerlIO_unix);
 370    PerlIO_define_layer(&PerlIO_perlio);
 371    PerlIO_define_layer(&PerlIO_stdio);
 372 #ifdef HAS_MMAP
 373    PerlIO_define_layer(&PerlIO_mmap);
 374 #endif
 375    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 376    if (s)
 377     {
 378      while (*s)
 379       {
 380        while (*s && isSPACE((unsigned char)*s))
 381         s++;
 382        if (*s)
 383         {
 384          const char *e = s;
 385          SV *layer;
 386          while (*e && !isSPACE((unsigned char)*e))
 387           e++;
 388          if (*s == ':')
 389           s++;
 390          layer = PerlIO_find_layer(s,e-s);
 391          if (layer)
 392           {
 393            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 394            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 395           }
 396          else
 397           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 398          s = e;
 399         }
 400       }
 401     }
 402   }
 403  len  = av_len(PerlIO_layer_av);
 404  if (len < 1)
 405   {
 406    if (PerlIO_stdio.Set_ptrcnt)
 407     {
 408      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 409     }
 410    else
 411     {
 412      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 413     }
 414    len  = av_len(PerlIO_layer_av);
 415   }
 416  if (n < 0)
 417   n += len+1;
 418  svp = av_fetch(PerlIO_layer_av,n,0);
 419  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 420   {
 421    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 422   }
 423  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 424  return tab;
 425 }
 426
 427 int
 428 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 429 {
 430  if (names)
 431   {
 432    const char *s = names;
 433    while (*s)
 434     {
 435      while (isSPACE(*s))
 436       s++;
 437      if (*s == ':')
 438       s++;
 439      if (*s)
 440       {
 441        const char *e = s;
 442        while (*e && *e != ':' && !isSPACE(*e))
 443         e++;
 444        if (e > s)
 445         {
 446          SV *layer = PerlIO_find_layer(s,e-s);
 447          if (layer)
 448           {
 449            PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 450            if (tab)
 451             {
 452              PerlIO *new = PerlIO_push(f,tab,mode);
 453              if (!new)
 454               return -1;
 455             }
 456           }
 457          else
 458           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 459         }
 460        s = e;
 461       }
 462     }
 463   }
 464  return 0;
 465 }
 466
 467 #define PerlIO_default_top() PerlIO_default_layer(-1)
 468 #define PerlIO_default_btm() PerlIO_default_layer(0)
 469
 470 void
 471 PerlIO_stdstreams()
 472 {
 473  if (!_perlio)
 474   {
 475    PerlIO_allocate();
 476    PerlIO_fdopen(0,"Ir");
 477    PerlIO_fdopen(1,"Iw");
 478    PerlIO_fdopen(2,"Iw");
 479   }
 480 }
 481
 482 PerlIO *
 483 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 484 {
 485  PerlIOl *l = NULL;
 486  Newc('L',l,tab->size,char,PerlIOl);
 487  if (l)
 488   {
 489    Zero(l,tab->size,char);
 490    l->next = *f;
 491    l->tab  = tab;
 492    *f      = l;
 493    if ((*l->tab->Pushed)(f,mode) != 0)
 494     {
 495      PerlIO_pop(f);
 496      return NULL;
 497     }
 498   }
 499  return f;
 500 }
 501
 502 /*--------------------------------------------------------------------------------------*/
 503 /* Given the abstraction above the public API functions */
 504
 505 #undef PerlIO_close
 506 int
 507 PerlIO_close(PerlIO *f)
 508 {
 509  int code = (*PerlIOBase(f)->tab->Close)(f);
 510  while (*f)
 511   {
 512    PerlIO_pop(f);
 513   }
 514  return code;
 515 }
 516
 517 #undef PerlIO_fileno
 518 int
 519 PerlIO_fileno(PerlIO *f)
 520 {
 521  return (*PerlIOBase(f)->tab->Fileno)(f);
 522 }
 523
 524
 525
 526 #undef PerlIO_fdopen
 527 PerlIO *
 528 PerlIO_fdopen(int fd, const char *mode)
 529 {
 530  PerlIO_funcs *tab = PerlIO_default_top();
 531  if (!_perlio)
 532   PerlIO_stdstreams();
 533  return (*tab->Fdopen)(tab,fd,mode);
 534 }
 535
 536 #undef PerlIO_open
 537 PerlIO *
 538 PerlIO_open(const char *path, const char *mode)
 539 {
 540  PerlIO_funcs *tab = PerlIO_default_top();
 541  if (!_perlio)
 542   PerlIO_stdstreams();
 543  return (*tab->Open)(tab,path,mode);
 544 }
 545
 546 #undef PerlIO_reopen
 547 PerlIO *
 548 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 549 {
 550  if (f)
 551   {
 552    PerlIO_flush(f);
 553    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 554     {
 555      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 556       return f;
 557     }
 558    return NULL;
 559   }
 560  else
 561   return PerlIO_open(path,mode);
 562 }
 563
 564 #undef PerlIO_read
 565 SSize_t
 566 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 567 {
 568  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 569 }
 570
 571 #undef PerlIO_unread
 572 SSize_t
 573 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 574 {
 575  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 576 }
 577
 578 #undef PerlIO_write
 579 SSize_t
 580 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 581 {
 582  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 583 }
 584
 585 #undef PerlIO_seek
 586 int
 587 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 588 {
 589  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 590 }
 591
 592 #undef PerlIO_tell
 593 Off_t
 594 PerlIO_tell(PerlIO *f)
 595 {
 596  return (*PerlIOBase(f)->tab->Tell)(f);
 597 }
 598
 599 #undef PerlIO_flush
 600 int
 601 PerlIO_flush(PerlIO *f)
 602 {
 603  if (f)
 604   {
 605    return (*PerlIOBase(f)->tab->Flush)(f);
 606   }
 607  else
 608   {
 609    PerlIO **table = &_perlio;
 610    int code = 0;
 611    while ((f = *table))
 612     {
 613      int i;
 614      table = (PerlIO **)(f++);
 615      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 616       {
 617        if (*f && PerlIO_flush(f) != 0)
 618         code = -1;
 619        f++;
 620       }
 621     }
 622    return code;
 623   }
 624 }
 625
 626 #undef PerlIO_fill
 627 int
 628 PerlIO_fill(PerlIO *f)
 629 {
 630  return (*PerlIOBase(f)->tab->Fill)(f);
 631 }
 632
 633 #undef PerlIO_isutf8
 634 int
 635 PerlIO_isutf8(PerlIO *f)
 636 {
 637  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 638 }
 639
 640 #undef PerlIO_eof
 641 int
 642 PerlIO_eof(PerlIO *f)
 643 {
 644  return (*PerlIOBase(f)->tab->Eof)(f);
 645 }
 646
 647 #undef PerlIO_error
 648 int
 649 PerlIO_error(PerlIO *f)
 650 {
 651  return (*PerlIOBase(f)->tab->Error)(f);
 652 }
 653
 654 #undef PerlIO_clearerr
 655 void
 656 PerlIO_clearerr(PerlIO *f)
 657 {
 658  (*PerlIOBase(f)->tab->Clearerr)(f);
 659 }
 660
 661 #undef PerlIO_setlinebuf
 662 void
 663 PerlIO_setlinebuf(PerlIO *f)
 664 {
 665  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 666 }
 667
 668 #undef PerlIO_has_base
 669 int
 670 PerlIO_has_base(PerlIO *f)
 671 {
 672  if (f && *f)
 673   {
 674    return (PerlIOBase(f)->tab->Get_base != NULL);
 675   }
 676  return 0;
 677 }
 678
 679 #undef PerlIO_fast_gets
 680 int
 681 PerlIO_fast_gets(PerlIO *f)
 682 {
 683  if (f && *f)
 684   {
 685    PerlIOl *l = PerlIOBase(f);
 686    return (l->tab->Set_ptrcnt != NULL);
 687   }
 688  return 0;
 689 }
 690
 691 #undef PerlIO_has_cntptr
 692 int
 693 PerlIO_has_cntptr(PerlIO *f)
 694 {
 695  if (f && *f)
 696   {
 697    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 698    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 699   }
 700  return 0;
 701 }
 702
 703 #undef PerlIO_canset_cnt
 704 int
 705 PerlIO_canset_cnt(PerlIO *f)
 706 {
 707  if (f && *f)
 708   {
 709    PerlIOl *l = PerlIOBase(f);
 710    return (l->tab->Set_ptrcnt != NULL);
 711   }
 712  return 0;
 713 }
 714
 715 #undef PerlIO_get_base
 716 STDCHAR *
 717 PerlIO_get_base(PerlIO *f)
 718 {
 719  return (*PerlIOBase(f)->tab->Get_base)(f);
 720 }
 721
 722 #undef PerlIO_get_bufsiz
 723 int
 724 PerlIO_get_bufsiz(PerlIO *f)
 725 {
 726  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 727 }
 728
 729 #undef PerlIO_get_ptr
 730 STDCHAR *
 731 PerlIO_get_ptr(PerlIO *f)
 732 {
 733  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 734 }
 735
 736 #undef PerlIO_get_cnt
 737 int
 738 PerlIO_get_cnt(PerlIO *f)
 739 {
 740  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 741 }
 742
 743 #undef PerlIO_set_cnt
 744 void
 745 PerlIO_set_cnt(PerlIO *f,int cnt)
 746 {
 747  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 748 }
 749
 750 #undef PerlIO_set_ptrcnt
 751 void
 752 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 753 {
 754  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 755 }
 756
 757 /*--------------------------------------------------------------------------------------*/
 758 /* "Methods" of the "base class" */
 759
 760 IV
 761 PerlIOBase_fileno(PerlIO *f)
 762 {
 763  return PerlIO_fileno(PerlIONext(f));
 764 }
 765
 766 IV
 767 PerlIOBase_pushed(PerlIO *f, const char *mode)
 768 {
 769  PerlIOl *l = PerlIOBase(f);
 770  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 771                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 772  if (mode)
 773   {
 774    switch (*mode++)
 775     {
 776      case 'r':
 777       l->flags = PERLIO_F_CANREAD;
 778       break;
 779      case 'a':
 780       l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 781       break;
 782      case 'w':
 783       l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 784       break;
 785      default:
 786       errno = EINVAL;
 787       return -1;
 788     }
 789    while (*mode)
 790     {
 791      switch (*mode++)
 792       {
 793        case '+':
 794         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 795         break;
 796        case 'b':
 797         l->flags |= PERLIO_F_BINARY;
 798         break;
 799       default:
 800        errno = EINVAL;
 801        return -1;
 802       }
 803     }
 804   }
 805  else
 806   {
 807    if (l->next)
 808     {
 809      l->flags |= l->next->flags &
 810                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 811                    PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
 812     }
 813   }
 814  return 0;
 815 }
 816
 817 IV
 818 PerlIOBase_popped(PerlIO *f)
 819 {
 820  return 0;
 821 }
 822
 823 SSize_t
 824 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 825 {
 826  Off_t old = PerlIO_tell(f);
 827  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 828   {
 829    Off_t new = PerlIO_tell(f);
 830    return old - new;
 831   }
 832  return 0;
 833 }
 834
 835 IV
 836 PerlIOBase_noop_ok(PerlIO *f)
 837 {
 838  return 0;
 839 }
 840
 841 IV
 842 PerlIOBase_noop_fail(PerlIO *f)
 843 {
 844  return -1;
 845 }
 846
 847 IV
 848 PerlIOBase_close(PerlIO *f)
 849 {
 850  IV code = 0;
 851  if (PerlIO_flush(f) != 0)
 852   code = -1;
 853  if (PerlIO_close(PerlIONext(f)) != 0)
 854   code = -1;
 855  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 856  return code;
 857 }
 858
 859 IV
 860 PerlIOBase_eof(PerlIO *f)
 861 {
 862  if (f && *f)
 863   {
 864    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
 865   }
 866  return 1;
 867 }
 868
 869 IV
 870 PerlIOBase_error(PerlIO *f)
 871 {
 872  if (f && *f)
 873   {
 874    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
 875   }
 876  return 1;
 877 }
 878
 879 void
 880 PerlIOBase_clearerr(PerlIO *f)
 881 {
 882  if (f && *f)
 883   {
 884    PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
 885   }
 886 }
 887
 888 void
 889 PerlIOBase_setlinebuf(PerlIO *f)
 890 {
 891
 892 }
 893
 894 /*--------------------------------------------------------------------------------------*/
 895 /* Bottom-most level for UNIX-like case */
 896
 897 typedef struct
 898 {
 899  struct _PerlIO base;       /* The generic part */
 900  int            fd;         /* UNIX like file descriptor */
 901  int            oflags;     /* open/fcntl flags */
 902 } PerlIOUnix;
 903
 904 int
 905 PerlIOUnix_oflags(const char *mode)
 906 {
 907  int oflags = -1;
 908  switch(*mode)
 909   {
 910    case 'r':
 911     oflags = O_RDONLY;
 912     if (*++mode == '+')
 913      {
 914       oflags = O_RDWR;
 915       mode++;
 916      }
 917     break;
 918
 919    case 'w':
 920     oflags = O_CREAT|O_TRUNC;
 921     if (*++mode == '+')
 922      {
 923       oflags |= O_RDWR;
 924       mode++;
 925      }
 926     else
 927      oflags |= O_WRONLY;
 928     break;
 929
 930    case 'a':
 931     oflags = O_CREAT|O_APPEND;
 932     if (*++mode == '+')
 933      {
 934       oflags |= O_RDWR;
 935       mode++;
 936      }
 937     else
 938      oflags |= O_WRONLY;
 939     break;
 940   }
 941  if (*mode || oflags == -1)
 942   {
 943    errno = EINVAL;
 944    oflags = -1;
 945   }
 946  return oflags;
 947 }
 948
 949 IV
 950 PerlIOUnix_fileno(PerlIO *f)
 951 {
 952  return PerlIOSelf(f,PerlIOUnix)->fd;
 953 }
 954
 955 PerlIO *
 956 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 957 {
 958  PerlIO *f = NULL;
 959  if (*mode == 'I')
 960   mode++;
 961  if (fd >= 0)
 962   {
 963    int oflags = PerlIOUnix_oflags(mode);
 964    if (oflags != -1)
 965     {
 966      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 967      s->fd     = fd;
 968      s->oflags = oflags;
 969      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 970     }
 971   }
 972  return f;
 973 }
 974
 975 PerlIO *
 976 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
 977 {
 978  PerlIO *f = NULL;
 979  int oflags = PerlIOUnix_oflags(mode);
 980  if (oflags != -1)
 981   {
 982    int fd = PerlLIO_open3(path,oflags,0666);
 983    if (fd >= 0)
 984     {
 985      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
 986      s->fd     = fd;
 987      s->oflags = oflags;
 988      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 989     }
 990   }
 991  return f;
 992 }
 993
 994 int
 995 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
 996 {
 997  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
 998  int oflags = PerlIOUnix_oflags(mode);
 999  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1000   (*PerlIOBase(f)->tab->Close)(f);
1001  if (oflags != -1)
1002   {
1003    int fd = PerlLIO_open3(path,oflags,0666);
1004    if (fd >= 0)
1005     {
1006      s->fd = fd;
1007      s->oflags = oflags;
1008      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1009      return 0;
1010     }
1011   }
1012  return -1;
1013 }
1014
1015 SSize_t
1016 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1017 {
1018  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1019  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1020   return 0;
1021  while (1)
1022   {
1023    SSize_t len = PerlLIO_read(fd,vbuf,count);
1024    if (len >= 0 || errno != EINTR)
1025     {
1026      if (len < 0)
1027       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1028      else if (len == 0 && count != 0)
1029       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1030      return len;
1031     }
1032   }
1033 }
1034
1035 SSize_t
1036 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1037 {
1038  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1039  while (1)
1040   {
1041    SSize_t len = PerlLIO_write(fd,vbuf,count);
1042    if (len >= 0 || errno != EINTR)
1043     {
1044      if (len < 0)
1045       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1046      return len;
1047     }
1048   }
1049 }
1050
1051 IV
1052 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1053 {
1054  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1055  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1056  return (new == (Off_t) -1) ? -1 : 0;
1057 }
1058
1059 Off_t
1060 PerlIOUnix_tell(PerlIO *f)
1061 {
1062  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1063 }
1064
1065 IV
1066 PerlIOUnix_close(PerlIO *f)
1067 {
1068  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1069  int code = 0;
1070  while (PerlLIO_close(fd) != 0)
1071   {
1072    if (errno != EINTR)
1073     {
1074      code = -1;
1075      break;
1076     }
1077   }
1078  if (code == 0)
1079   {
1080    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1081   }
1082  return code;
1083 }
1084
1085 PerlIO_funcs PerlIO_unix = {
1086  "unix",
1087  sizeof(PerlIOUnix),
1088  0,
1089  PerlIOUnix_fileno,
1090  PerlIOUnix_fdopen,
1091  PerlIOUnix_open,
1092  PerlIOUnix_reopen,
1093  PerlIOBase_pushed,
1094  PerlIOBase_noop_ok,
1095  PerlIOUnix_read,
1096  PerlIOBase_unread,
1097  PerlIOUnix_write,
1098  PerlIOUnix_seek,
1099  PerlIOUnix_tell,
1100  PerlIOUnix_close,
1101  PerlIOBase_noop_ok,   /* flush */
1102  PerlIOBase_noop_fail, /* fill */
1103  PerlIOBase_eof,
1104  PerlIOBase_error,
1105  PerlIOBase_clearerr,
1106  PerlIOBase_setlinebuf,
1107  NULL, /* get_base */
1108  NULL, /* get_bufsiz */
1109  NULL, /* get_ptr */
1110  NULL, /* get_cnt */
1111  NULL, /* set_ptrcnt */
1112 };
1113
1114 /*--------------------------------------------------------------------------------------*/
1115 /* stdio as a layer */
1116
1117 typedef struct
1118 {
1119  struct _PerlIO base;
1120  FILE *         stdio;      /* The stream */
1121 } PerlIOStdio;
1122
1123 IV
1124 PerlIOStdio_fileno(PerlIO *f)
1125 {
1126  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1127 }
1128
1129
1130 PerlIO *
1131 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1132 {
1133  PerlIO *f = NULL;
1134  int init = 0;
1135  if (*mode == 'I')
1136   {
1137    init = 1;
1138    mode++;
1139   }
1140  if (fd >= 0)
1141   {
1142    FILE *stdio = NULL;
1143    if (init)
1144     {
1145      switch(fd)
1146       {
1147        case 0:
1148         stdio = stdin;
1149         break;
1150        case 1:
1151         stdio = stdout;
1152         break;
1153        case 2:
1154         stdio = stderr;
1155         break;
1156       }
1157     }
1158    else
1159     stdio = fdopen(fd,mode);
1160    if (stdio)
1161     {
1162      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1163      s->stdio  = stdio;
1164     }
1165   }
1166  return f;
1167 }
1168
1169 #undef PerlIO_importFILE
1170 PerlIO *
1171 PerlIO_importFILE(FILE *stdio, int fl)
1172 {
1173  PerlIO *f = NULL;
1174  if (stdio)
1175   {
1176    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1177    s->stdio  = stdio;
1178   }
1179  return f;
1180 }
1181
1182 PerlIO *
1183 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1184 {
1185  PerlIO *f = NULL;
1186  FILE *stdio = fopen(path,mode);
1187  if (stdio)
1188   {
1189    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1190    s->stdio  = stdio;
1191   }
1192  return f;
1193 }
1194
1195 int
1196 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1197 {
1198  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1199  FILE *stdio = freopen(path,mode,s->stdio);
1200  if (!s->stdio)
1201   return -1;
1202  s->stdio = stdio;
1203  return 0;
1204 }
1205
1206 SSize_t
1207 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1208 {
1209  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1210  SSize_t got = 0;
1211  if (count == 1)
1212   {
1213    STDCHAR *buf = (STDCHAR *) vbuf;
1214    /* Perl is expecting PerlIO_getc() to fill the buffer
1215     * Linux's stdio does not do that for fread()
1216     */
1217    int ch = fgetc(s);
1218    if (ch != EOF)
1219     {
1220      *buf = ch;
1221      got = 1;
1222     }
1223   }
1224  else
1225   got = fread(vbuf,1,count,s);
1226  return got;
1227 }
1228
1229 SSize_t
1230 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1231 {
1232  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1233  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1234  SSize_t unread = 0;
1235  while (count > 0)
1236   {
1237    int ch = *buf-- & 0xff;
1238    if (ungetc(ch,s) != ch)
1239     break;
1240    unread++;
1241    count--;
1242   }
1243  return unread;
1244 }
1245
1246 SSize_t
1247 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1248 {
1249  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1250 }
1251
1252 IV
1253 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1254 {
1255  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1256  return fseek(stdio,offset,whence);
1257 }
1258
1259 Off_t
1260 PerlIOStdio_tell(PerlIO *f)
1261 {
1262  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1263  return ftell(stdio);
1264 }
1265
1266 IV
1267 PerlIOStdio_close(PerlIO *f)
1268 {
1269  return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1270 }
1271
1272 IV
1273 PerlIOStdio_flush(PerlIO *f)
1274 {
1275  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1276  return fflush(stdio);
1277 }
1278
1279 IV
1280 PerlIOStdio_fill(PerlIO *f)
1281 {
1282  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1283  int c;
1284  if (fflush(stdio) != 0)
1285   return EOF;
1286  c = fgetc(stdio);
1287  if (c == EOF || ungetc(c,stdio) != c)
1288   return EOF;
1289  return 0;
1290 }
1291
1292 IV
1293 PerlIOStdio_eof(PerlIO *f)
1294 {
1295  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1296 }
1297
1298 IV
1299 PerlIOStdio_error(PerlIO *f)
1300 {
1301  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1302 }
1303
1304 void
1305 PerlIOStdio_clearerr(PerlIO *f)
1306 {
1307  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1308 }
1309
1310 void
1311 PerlIOStdio_setlinebuf(PerlIO *f)
1312 {
1313 #ifdef HAS_SETLINEBUF
1314  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1315 #else
1316  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1317 #endif
1318 }
1319
1320 #ifdef FILE_base
1321 STDCHAR *
1322 PerlIOStdio_get_base(PerlIO *f)
1323 {
1324  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1325  return FILE_base(stdio);
1326 }
1327
1328 Size_t
1329 PerlIOStdio_get_bufsiz(PerlIO *f)
1330 {
1331  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1332  return FILE_bufsiz(stdio);
1333 }
1334 #endif
1335
1336 #ifdef USE_STDIO_PTR
1337 STDCHAR *
1338 PerlIOStdio_get_ptr(PerlIO *f)
1339 {
1340  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1341  return FILE_ptr(stdio);
1342 }
1343
1344 SSize_t
1345 PerlIOStdio_get_cnt(PerlIO *f)
1346 {
1347  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1348  return FILE_cnt(stdio);
1349 }
1350
1351 void
1352 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1353 {
1354  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1355  if (ptr != NULL)
1356   {
1357 #ifdef STDIO_PTR_LVALUE
1358    FILE_ptr(stdio) = ptr;
1359 #ifdef STDIO_PTR_LVAL_SETS_CNT
1360    if (FILE_cnt(stdio) != (cnt))
1361     {
1362      dTHX;
1363      assert(FILE_cnt(stdio) == (cnt));
1364     }
1365 #endif
1366 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1367    /* Setting ptr _does_ change cnt - we are done */
1368    return;
1369 #endif
1370 #else  /* STDIO_PTR_LVALUE */
1371    abort();
1372 #endif /* STDIO_PTR_LVALUE */
1373   }
1374 /* Now (or only) set cnt */
1375 #ifdef STDIO_CNT_LVALUE
1376  FILE_cnt(stdio) = cnt;
1377 #else  /* STDIO_CNT_LVALUE */
1378 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1379  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1380 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1381  abort();
1382 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1383 #endif /* STDIO_CNT_LVALUE */
1384 }
1385
1386 #endif
1387
1388 PerlIO_funcs PerlIO_stdio = {
1389  "stdio",
1390  sizeof(PerlIOStdio),
1391  0,
1392  PerlIOStdio_fileno,
1393  PerlIOStdio_fdopen,
1394  PerlIOStdio_open,
1395  PerlIOStdio_reopen,
1396  PerlIOBase_pushed,
1397  PerlIOBase_noop_ok,
1398  PerlIOStdio_read,
1399  PerlIOStdio_unread,
1400  PerlIOStdio_write,
1401  PerlIOStdio_seek,
1402  PerlIOStdio_tell,
1403  PerlIOStdio_close,
1404  PerlIOStdio_flush,
1405  PerlIOStdio_fill,
1406  PerlIOStdio_eof,
1407  PerlIOStdio_error,
1408  PerlIOStdio_clearerr,
1409  PerlIOStdio_setlinebuf,
1410 #ifdef FILE_base
1411  PerlIOStdio_get_base,
1412  PerlIOStdio_get_bufsiz,
1413 #else
1414  NULL,
1415  NULL,
1416 #endif
1417 #ifdef USE_STDIO_PTR
1418  PerlIOStdio_get_ptr,
1419  PerlIOStdio_get_cnt,
1420 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1421  PerlIOStdio_set_ptrcnt
1422 #else  /* STDIO_PTR_LVALUE */
1423  NULL
1424 #endif /* STDIO_PTR_LVALUE */
1425 #else  /* USE_STDIO_PTR */
1426  NULL,
1427  NULL,
1428  NULL
1429 #endif /* USE_STDIO_PTR */
1430 };
1431
1432 #undef PerlIO_exportFILE
1433 FILE *
1434 PerlIO_exportFILE(PerlIO *f, int fl)
1435 {
1436  PerlIO_flush(f);
1437  /* Should really push stdio discipline when we have them */
1438  return fdopen(PerlIO_fileno(f),"r+");
1439 }
1440
1441 #undef PerlIO_findFILE
1442 FILE *
1443 PerlIO_findFILE(PerlIO *f)
1444 {
1445  return PerlIO_exportFILE(f,0);
1446 }
1447
1448 #undef PerlIO_releaseFILE
1449 void
1450 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1451 {
1452 }
1453
1454 /*--------------------------------------------------------------------------------------*/
1455 /* perlio buffer layer */
1456
1457 PerlIO *
1458 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1459 {
1460  PerlIO_funcs *tab = PerlIO_default_btm();
1461  int init = 0;
1462  PerlIO *f;
1463  if (*mode == 'I')
1464   {
1465    init = 1;
1466    mode++;
1467   }
1468  f = (*tab->Fdopen)(tab,fd,mode);
1469  if (f)
1470   {
1471    /* Initial stderr is unbuffered */
1472    if (!init || fd != 2)
1473     {
1474      PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1475      b->posn = PerlIO_tell(PerlIONext(f));
1476     }
1477   }
1478  return f;
1479 }
1480
1481 PerlIO *
1482 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1483 {
1484  PerlIO_funcs *tab = PerlIO_default_btm();
1485  PerlIO *f = (*tab->Open)(tab,path,mode);
1486  if (f)
1487   {
1488    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
1489    b->posn = PerlIO_tell(PerlIONext(f));
1490   }
1491  return f;
1492 }
1493
1494 int
1495 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1496 {
1497  PerlIO *next = PerlIONext(f);
1498  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1499  if (code = 0)
1500   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1501  if (code == 0)
1502   {
1503    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1504    b->posn = PerlIO_tell(PerlIONext(f));
1505   }
1506  return code;
1507 }
1508
1509 /* This "flush" is akin to sfio's sync in that it handles files in either
1510    read or write state
1511 */
1512 IV
1513 PerlIOBuf_flush(PerlIO *f)
1514 {
1515  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1516  int code = 0;
1517  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1518   {
1519    /* write() the buffer */
1520    STDCHAR *p = b->buf;
1521    int count;
1522    while (p < b->ptr)
1523     {
1524      count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1525      if (count > 0)
1526       {
1527        p += count;
1528       }
1529      else if (count < 0)
1530       {
1531        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1532        code = -1;
1533        break;
1534       }
1535     }
1536    b->posn += (p - b->buf);
1537   }
1538  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1539   {
1540    /* Note position change */
1541    b->posn += (b->ptr - b->buf);
1542    if (b->ptr < b->end)
1543     {
1544      /* We did not consume all of it */
1545      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1546       {
1547        b->posn = PerlIO_tell(PerlIONext(f));
1548       }
1549     }
1550   }
1551  b->ptr = b->end = b->buf;
1552  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1553  if (PerlIO_flush(PerlIONext(f)) != 0)
1554   code = -1;
1555  return code;
1556 }
1557
1558 IV
1559 PerlIOBuf_fill(PerlIO *f)
1560 {
1561  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1562  SSize_t avail;
1563  if (PerlIO_flush(f) != 0)
1564   return -1;
1565  b->ptr = b->end = b->buf;
1566  avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1567  if (avail <= 0)
1568   {
1569    if (avail == 0)
1570     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1571    else
1572     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1573    return -1;
1574   }
1575  b->end      = b->buf+avail;
1576  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1577  return 0;
1578 }
1579
1580 SSize_t
1581 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1582 {
1583  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1584  STDCHAR *buf = (STDCHAR *) vbuf;
1585  if (f)
1586   {
1587    Size_t got = 0;
1588    if (!b->ptr)
1589     PerlIO_get_base(f);
1590    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1591     return 0;
1592    while (count > 0)
1593     {
1594      SSize_t avail = (b->end - b->ptr);
1595      if ((SSize_t) count < avail)
1596       avail = count;
1597      if (avail > 0)
1598       {
1599        Copy(b->ptr,buf,avail,char);
1600        got     += avail;
1601        b->ptr  += avail;
1602        count   -= avail;
1603        buf     += avail;
1604       }
1605      if (count && (b->ptr >= b->end))
1606       {
1607        if (PerlIO_fill(f) != 0)
1608         break;
1609       }
1610     }
1611    return got;
1612   }
1613  return 0;
1614 }
1615
1616 SSize_t
1617 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1618 {
1619  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1620  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1621  SSize_t unread = 0;
1622  SSize_t avail;
1623  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1624   PerlIO_flush(f);
1625  if (!b->buf)
1626   PerlIO_get_base(f);
1627  if (b->buf)
1628   {
1629    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1630     {
1631      avail = (b->ptr - b->buf);
1632      if (avail > (SSize_t) count)
1633       avail = count;
1634      b->ptr -= avail;
1635     }
1636    else
1637     {
1638      avail = b->bufsiz;
1639      if (avail > (SSize_t) count)
1640       avail = count;
1641      b->end = b->ptr + avail;
1642     }
1643    if (avail > 0)
1644     {
1645      buf    -= avail;
1646      if (buf != b->ptr)
1647       {
1648        Copy(buf,b->ptr,avail,char);
1649       }
1650      count  -= avail;
1651      unread += avail;
1652      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1653     }
1654   }
1655  return unread;
1656 }
1657
1658 SSize_t
1659 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1660 {
1661  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1662  const STDCHAR *buf = (const STDCHAR *) vbuf;
1663  Size_t written = 0;
1664  if (!b->buf)
1665   PerlIO_get_base(f);
1666  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1667   return 0;
1668  while (count > 0)
1669   {
1670    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1671    if ((SSize_t) count < avail)
1672     avail = count;
1673    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1674    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1675     {
1676      while (avail > 0)
1677       {
1678        int ch = *buf++;
1679        *(b->ptr)++ = ch;
1680        count--;
1681        avail--;
1682        written++;
1683        if (ch == '\n')
1684         {
1685          PerlIO_flush(f);
1686          break;
1687         }
1688       }
1689     }
1690    else
1691     {
1692      if (avail)
1693       {
1694        Copy(buf,b->ptr,avail,char);
1695        count   -= avail;
1696        buf     += avail;
1697        written += avail;
1698        b->ptr  += avail;
1699       }
1700     }
1701    if (b->ptr >= (b->buf + b->bufsiz))
1702     PerlIO_flush(f);
1703   }
1704  return written;
1705 }
1706
1707 IV
1708 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1709 {
1710  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1711  int code = PerlIO_flush(f);
1712  if (code == 0)
1713   {
1714    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1715    code = PerlIO_seek(PerlIONext(f),offset,whence);
1716    if (code == 0)
1717     {
1718      b->posn = PerlIO_tell(PerlIONext(f));
1719     }
1720   }
1721  return code;
1722 }
1723
1724 Off_t
1725 PerlIOBuf_tell(PerlIO *f)
1726 {
1727  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1728  Off_t posn = b->posn;
1729  if (b->buf)
1730   posn += (b->ptr - b->buf);
1731  return posn;
1732 }
1733
1734 IV
1735 PerlIOBuf_close(PerlIO *f)
1736 {
1737  IV code = PerlIOBase_close(f);
1738  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1739  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
1740   {
1741    Safefree(b->buf);
1742   }
1743  b->buf = NULL;
1744  b->ptr = b->end = b->buf;
1745  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1746  return code;
1747 }
1748
1749 void
1750 PerlIOBuf_setlinebuf(PerlIO *f)
1751 {
1752  if (f)
1753   {
1754    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
1755   }
1756 }
1757
1758 STDCHAR *
1759 PerlIOBuf_get_ptr(PerlIO *f)
1760 {
1761  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1762  if (!b->buf)
1763   PerlIO_get_base(f);
1764  return b->ptr;
1765 }
1766
1767 SSize_t
1768 PerlIOBuf_get_cnt(PerlIO *f)
1769 {
1770  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1771  if (!b->buf)
1772   PerlIO_get_base(f);
1773  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1774   return (b->end - b->ptr);
1775  return 0;
1776 }
1777
1778 STDCHAR *
1779 PerlIOBuf_get_base(PerlIO *f)
1780 {
1781  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1782  if (!b->buf)
1783   {
1784    if (!b->bufsiz)
1785     b->bufsiz = 4096;
1786    New('B',b->buf,b->bufsiz,STDCHAR);
1787    if (!b->buf)
1788     {
1789      b->buf = (STDCHAR *)&b->oneword;
1790      b->bufsiz = sizeof(b->oneword);
1791     }
1792    b->ptr = b->buf;
1793    b->end = b->ptr;
1794   }
1795  return b->buf;
1796 }
1797
1798 Size_t
1799 PerlIOBuf_bufsiz(PerlIO *f)
1800 {
1801  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1802  if (!b->buf)
1803   PerlIO_get_base(f);
1804  return (b->end - b->buf);
1805 }
1806
1807 void
1808 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
1809 {
1810  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1811  if (!b->buf)
1812   PerlIO_get_base(f);
1813  b->ptr = ptr;
1814  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
1815   {
1816    dTHX;
1817    assert(PerlIO_get_cnt(f) == cnt);
1818    assert(b->ptr >= b->buf);
1819   }
1820  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1821 }
1822
1823 PerlIO_funcs PerlIO_perlio = {
1824  "perlio",
1825  sizeof(PerlIOBuf),
1826  0,
1827  PerlIOBase_fileno,
1828  PerlIOBuf_fdopen,
1829  PerlIOBuf_open,
1830  PerlIOBuf_reopen,
1831  PerlIOBase_pushed,
1832  PerlIOBase_noop_ok,
1833  PerlIOBuf_read,
1834  PerlIOBuf_unread,
1835  PerlIOBuf_write,
1836  PerlIOBuf_seek,
1837  PerlIOBuf_tell,
1838  PerlIOBuf_close,
1839  PerlIOBuf_flush,
1840  PerlIOBuf_fill,
1841  PerlIOBase_eof,
1842  PerlIOBase_error,
1843  PerlIOBase_clearerr,
1844  PerlIOBuf_setlinebuf,
1845  PerlIOBuf_get_base,
1846  PerlIOBuf_bufsiz,
1847  PerlIOBuf_get_ptr,
1848  PerlIOBuf_get_cnt,
1849  PerlIOBuf_set_ptrcnt,
1850 };
1851
1852 #ifdef HAS_MMAP
1853 /*--------------------------------------------------------------------------------------*/
1854 /* mmap as "buffer" layer */
1855
1856 typedef struct
1857 {
1858  PerlIOBuf      base;         /* PerlIOBuf stuff */
1859  Mmap_t         mptr;        /* Mapped address */
1860  Size_t         len;          /* mapped length */
1861  STDCHAR        *bbuf;        /* malloced buffer if map fails */
1862
1863 } PerlIOMmap;
1864
1865 static size_t page_size = 0;
1866
1867 IV
1868 PerlIOMmap_map(PerlIO *f)
1869 {
1870  dTHX;
1871  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1872  PerlIOBuf  *b = &m->base;
1873  IV flags = PerlIOBase(f)->flags;
1874  IV code  = 0;
1875  if (m->len)
1876   abort();
1877  if (flags & PERLIO_F_CANREAD)
1878   {
1879    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1880    int fd   = PerlIO_fileno(f);
1881    struct stat st;
1882    code = fstat(fd,&st);
1883    if (code == 0 && S_ISREG(st.st_mode))
1884     {
1885      SSize_t len = st.st_size - b->posn;
1886      if (len > 0)
1887       {
1888        Off_t posn;
1889        if (!page_size) {
1890 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
1891            {
1892                SETERRNO(0,SS$_NORMAL);
1893 #   ifdef _SC_PAGESIZE
1894                page_size = sysconf(_SC_PAGESIZE);
1895 #   else
1896                page_size = sysconf(_SC_PAGE_SIZE);
1897 #   endif
1898                if ((long)page_size < 0) {
1899                    if (errno) {
1900                        SV *error = ERRSV;
1901                        char *msg;
1902                        STRLEN n_a;
1903                        (void)SvUPGRADE(error, SVt_PV);
1904                        msg = SvPVx(error, n_a);
1905                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
1906                    }
1907                    else
1908                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
1909                }
1910            }
1911 #else
1912 #   ifdef HAS_GETPAGESIZE
1913         page_size = getpagesize();
1914 #   else
1915 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
1916         page_size = PAGESIZE; /* compiletime, bad */
1917 #       endif
1918 #   endif
1919 #endif
1920         if ((IV)page_size <= 0)
1921             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
1922        }
1923        if (b->posn < 0)
1924         {
1925          /* This is a hack - should never happen - open should have set it ! */
1926          b->posn = PerlIO_tell(PerlIONext(f));
1927         }
1928        posn = (b->posn / page_size) * page_size;
1929        len  = st.st_size - posn;
1930        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1931        if (m->mptr && m->mptr != (Mmap_t) -1)
1932         {
1933 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1934          madvise(m->mptr, len, MADV_SEQUENTIAL);
1935 #endif
1936          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1937          b->end  = ((STDCHAR *)m->mptr) + len;
1938          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
1939          b->ptr  = b->buf;
1940          m->len  = len;
1941         }
1942        else
1943         {
1944          b->buf = NULL;
1945         }
1946       }
1947      else
1948       {
1949        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1950        b->buf = NULL;
1951        b->ptr = b->end = b->ptr;
1952        code = -1;
1953       }
1954     }
1955   }
1956  return code;
1957 }
1958
1959 IV
1960 PerlIOMmap_unmap(PerlIO *f)
1961 {
1962  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1963  PerlIOBuf  *b = &m->base;
1964  IV code = 0;
1965  if (m->len)
1966   {
1967    if (b->buf)
1968     {
1969      code = munmap(m->mptr, m->len);
1970      b->buf  = NULL;
1971      m->len  = 0;
1972      m->mptr = NULL;
1973      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1974       code = -1;
1975     }
1976    b->ptr = b->end = b->buf;
1977    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1978   }
1979  return code;
1980 }
1981
1982 STDCHAR *
1983 PerlIOMmap_get_base(PerlIO *f)
1984 {
1985  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1986  PerlIOBuf  *b = &m->base;
1987  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1988   {
1989    /* Already have a readbuffer in progress */
1990    return b->buf;
1991   }
1992  if (b->buf)
1993   {
1994    /* We have a write buffer or flushed PerlIOBuf read buffer */
1995    m->bbuf = b->buf;  /* save it in case we need it again */
1996    b->buf  = NULL;    /* Clear to trigger below */
1997   }
1998  if (!b->buf)
1999   {
2000    PerlIOMmap_map(f);     /* Try and map it */
2001    if (!b->buf)
2002     {
2003      /* Map did not work - recover PerlIOBuf buffer if we have one */
2004      b->buf = m->bbuf;
2005     }
2006   }
2007  b->ptr  = b->end = b->buf;
2008  if (b->buf)
2009   return b->buf;
2010  return PerlIOBuf_get_base(f);
2011 }
2012
2013 SSize_t
2014 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2015 {
2016  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2017  PerlIOBuf  *b = &m->base;
2018  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2019   PerlIO_flush(f);
2020  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2021   {
2022    b->ptr -= count;
2023    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2024    return count;
2025   }
2026  if (m->len)
2027   {
2028    /* Loose the unwritable mapped buffer */
2029    PerlIO_flush(f);
2030    /* If flush took the "buffer" see if we have one from before */
2031    if (!b->buf && m->bbuf)
2032     b->buf = m->bbuf;
2033    if (!b->buf)
2034     {
2035      PerlIOBuf_get_base(f);
2036      m->bbuf = b->buf;
2037     }
2038   }
2039  return PerlIOBuf_unread(f,vbuf,count);
2040 }
2041
2042 SSize_t
2043 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2044 {
2045  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2046  PerlIOBuf  *b = &m->base;
2047  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2048   {
2049    /* No, or wrong sort of, buffer */
2050    if (m->len)
2051     {
2052      if (PerlIOMmap_unmap(f) != 0)
2053       return 0;
2054     }
2055    /* If unmap took the "buffer" see if we have one from before */
2056    if (!b->buf && m->bbuf)
2057     b->buf = m->bbuf;
2058    if (!b->buf)
2059     {
2060      PerlIOBuf_get_base(f);
2061      m->bbuf = b->buf;
2062     }
2063   }
2064  return PerlIOBuf_write(f,vbuf,count);
2065 }
2066
2067 IV
2068 PerlIOMmap_flush(PerlIO *f)
2069 {
2070  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2071  PerlIOBuf  *b = &m->base;
2072  IV code = PerlIOBuf_flush(f);
2073  /* Now we are "synced" at PerlIOBuf level */
2074  if (b->buf)
2075   {
2076    if (m->len)
2077     {
2078      /* Unmap the buffer */
2079      if (PerlIOMmap_unmap(f) != 0)
2080       code = -1;
2081     }
2082    else
2083     {
2084      /* We seem to have a PerlIOBuf buffer which was not mapped
2085       * remember it in case we need one later
2086       */
2087      m->bbuf = b->buf;
2088     }
2089   }
2090  return code;
2091 }
2092
2093 IV
2094 PerlIOMmap_fill(PerlIO *f)
2095 {
2096  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2097  IV code = PerlIO_flush(f);
2098  if (code == 0 && !b->buf)
2099   {
2100    code = PerlIOMmap_map(f);
2101   }
2102  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2103   {
2104    code = PerlIOBuf_fill(f);
2105   }
2106  return code;
2107 }
2108
2109 IV
2110 PerlIOMmap_close(PerlIO *f)
2111 {
2112  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2113  PerlIOBuf  *b = &m->base;
2114  IV code = PerlIO_flush(f);
2115  if (m->bbuf)
2116   {
2117    b->buf  = m->bbuf;
2118    m->bbuf = NULL;
2119    b->ptr  = b->end = b->buf;
2120   }
2121  if (PerlIOBuf_close(f) != 0)
2122   code = -1;
2123  return code;
2124 }
2125
2126
2127 PerlIO_funcs PerlIO_mmap = {
2128  "mmap",
2129  sizeof(PerlIOMmap),
2130  0,
2131  PerlIOBase_fileno,
2132  PerlIOBuf_fdopen,
2133  PerlIOBuf_open,
2134  PerlIOBuf_reopen,
2135  PerlIOBase_pushed,
2136  PerlIOBase_noop_ok,
2137  PerlIOBuf_read,
2138  PerlIOMmap_unread,
2139  PerlIOMmap_write,
2140  PerlIOBuf_seek,
2141  PerlIOBuf_tell,
2142  PerlIOBuf_close,
2143  PerlIOMmap_flush,
2144  PerlIOMmap_fill,
2145  PerlIOBase_eof,
2146  PerlIOBase_error,
2147  PerlIOBase_clearerr,
2148  PerlIOBuf_setlinebuf,
2149  PerlIOMmap_get_base,
2150  PerlIOBuf_bufsiz,
2151  PerlIOBuf_get_ptr,
2152  PerlIOBuf_get_cnt,
2153  PerlIOBuf_set_ptrcnt,
2154 };
2155
2156 #endif /* HAS_MMAP */
2157
2158 void
2159 PerlIO_init(void)
2160 {
2161  if (!_perlio)
2162   {
2163    atexit(&PerlIO_cleanup);
2164   }
2165 }
2166
2167 #undef PerlIO_stdin
2168 PerlIO *
2169 PerlIO_stdin(void)
2170 {
2171  if (!_perlio)
2172   PerlIO_stdstreams();
2173  return &_perlio[1];
2174 }
2175
2176 #undef PerlIO_stdout
2177 PerlIO *
2178 PerlIO_stdout(void)
2179 {
2180  if (!_perlio)
2181   PerlIO_stdstreams();
2182  return &_perlio[2];
2183 }
2184
2185 #undef PerlIO_stderr
2186 PerlIO *
2187 PerlIO_stderr(void)
2188 {
2189  if (!_perlio)
2190   PerlIO_stdstreams();
2191  return &_perlio[3];
2192 }
2193
2194 /*--------------------------------------------------------------------------------------*/
2195
2196 #undef PerlIO_getname
2197 char *
2198 PerlIO_getname(PerlIO *f, char *buf)
2199 {
2200  dTHX;
2201  Perl_croak(aTHX_ "Don't know how to get file name");
2202  return NULL;
2203 }
2204
2205
2206 /*--------------------------------------------------------------------------------------*/
2207 /* Functions which can be called on any kind of PerlIO implemented
2208    in terms of above
2209 */
2210
2211 #undef PerlIO_getc
2212 int
2213 PerlIO_getc(PerlIO *f)
2214 {
2215  STDCHAR buf[1];
2216  SSize_t count = PerlIO_read(f,buf,1);
2217  if (count == 1)
2218   {
2219    return (unsigned char) buf[0];
2220   }
2221  return EOF;
2222 }
2223
2224 #undef PerlIO_ungetc
2225 int
2226 PerlIO_ungetc(PerlIO *f, int ch)
2227 {
2228  if (ch != EOF)
2229   {
2230    STDCHAR buf = ch;
2231    if (PerlIO_unread(f,&buf,1) == 1)
2232     return ch;
2233   }
2234  return EOF;
2235 }
2236
2237 #undef PerlIO_putc
2238 int
2239 PerlIO_putc(PerlIO *f, int ch)
2240 {
2241  STDCHAR buf = ch;
2242  return PerlIO_write(f,&buf,1);
2243 }
2244
2245 #undef PerlIO_puts
2246 int
2247 PerlIO_puts(PerlIO *f, const char *s)
2248 {
2249  STRLEN len = strlen(s);
2250  return PerlIO_write(f,s,len);
2251 }
2252
2253 #undef PerlIO_rewind
2254 void
2255 PerlIO_rewind(PerlIO *f)
2256 {
2257  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2258  PerlIO_clearerr(f);
2259 }
2260
2261 #undef PerlIO_vprintf
2262 int
2263 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2264 {
2265  dTHX;
2266  SV *sv = newSVpvn("",0);
2267  char *s;
2268  STRLEN len;
2269  sv_vcatpvf(sv, fmt, &ap);
2270  s = SvPV(sv,len);
2271  return PerlIO_write(f,s,len);
2272 }
2273
2274 #undef PerlIO_printf
2275 int
2276 PerlIO_printf(PerlIO *f,const char *fmt,...)
2277 {
2278  va_list ap;
2279  int result;
2280  va_start(ap,fmt);
2281  result = PerlIO_vprintf(f,fmt,ap);
2282  va_end(ap);
2283  return result;
2284 }
2285
2286 #undef PerlIO_stdoutf
2287 int
2288 PerlIO_stdoutf(const char *fmt,...)
2289 {
2290  va_list ap;
2291  int result;
2292  va_start(ap,fmt);
2293  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2294  va_end(ap);
2295  return result;
2296 }
2297
2298 #undef PerlIO_tmpfile
2299 PerlIO *
2300 PerlIO_tmpfile(void)
2301 {
2302  dTHX;
2303  /* I have no idea how portable mkstemp() is ... */
2304  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2305  int fd = mkstemp(SvPVX(sv));
2306  PerlIO *f = NULL;
2307  if (fd >= 0)
2308   {
2309    f = PerlIO_fdopen(fd,"w+");
2310    if (f)
2311     {
2312      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2313     }
2314    PerlLIO_unlink(SvPVX(sv));
2315    SvREFCNT_dec(sv);
2316   }
2317  return f;
2318 }
2319
2320 #undef HAS_FSETPOS
2321 #undef HAS_FGETPOS
2322
2323 #endif /* USE_SFIO */
2324 #endif /* PERLIO_IS_STDIO */
2325
2326 /*======================================================================================*/
2327 /* Now some functions in terms of above which may be needed even if
2328    we are not in true PerlIO mode
2329  */
2330
2331 #ifndef HAS_FSETPOS
2332 #undef PerlIO_setpos
2333 int
2334 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2335 {
2336  return PerlIO_seek(f,*pos,0);
2337 }
2338 #else
2339 #ifndef PERLIO_IS_STDIO
2340 #undef PerlIO_setpos
2341 int
2342 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2343 {
2344 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2345  return fsetpos64(f, pos);
2346 #else
2347  return fsetpos(f, pos);
2348 #endif
2349 }
2350 #endif
2351 #endif
2352
2353 #ifndef HAS_FGETPOS
2354 #undef PerlIO_getpos
2355 int
2356 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2357 {
2358  *pos = PerlIO_tell(f);
2359  return *pos == -1 ? -1 : 0;
2360 }
2361 #else
2362 #ifndef PERLIO_IS_STDIO
2363 #undef PerlIO_getpos
2364 int
2365 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2366 {
2367 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2368  return fgetpos64(f, pos);
2369 #else
2370  return fgetpos(f, pos);
2371 #endif
2372 }
2373 #endif
2374 #endif
2375
2376 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2377
2378 int
2379 vprintf(char *pat, char *args)
2380 {
2381     _doprnt(pat, args, stdout);
2382     return 0;           /* wrong, but perl doesn't use the return value */
2383 }
2384
2385 int
2386 vfprintf(FILE *fd, char *pat, char *args)
2387 {
2388     _doprnt(pat, args, fd);
2389     return 0;           /* wrong, but perl doesn't use the return value */
2390 }
2391
2392 #endif
2393
2394 #ifndef PerlIO_vsprintf
2395 int
2396 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2397 {
2398  int val = vsprintf(s, fmt, ap);
2399  if (n >= 0)
2400   {
2401    if (strlen(s) >= (STRLEN)n)
2402     {
2403      dTHX;
2404      (void)PerlIO_puts(Perl_error_log,
2405                        "panic: sprintf overflow - memory corrupted!\n");
2406      my_exit(1);
2407     }
2408   }
2409  return val;
2410 }
2411 #endif
2412
2413 #ifndef PerlIO_sprintf
2414 int
2415 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2416 {
2417  va_list ap;
2418  int result;
2419  va_start(ap,fmt);
2420  result = PerlIO_vsprintf(s, n, fmt, ap);
2421  va_end(ap);
2422  return result;
2423 }
2424 #endif
2425
2426 #endif /* !PERL_IMPLICIT_SYS */
2427