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