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