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