perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2001, 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 /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
  11    a dTHX to get at the dispatch tables, even when we do not
  12    need it for other reasons.
  13    Invent a dSYS macro to abstract this out
  14 */
  15 #ifdef PERL_IMPLICIT_SYS
  16 #define dSYS dTHX
  17 #else
  18 #define dSYS dNOOP
  19 #endif
  20
  21 #define VOIDUSED 1
  22 #ifdef PERL_MICRO
  23 #   include "uconfig.h"
  24 #else
  25 #   include "config.h"
  26 #endif
  27
  28 #define PERLIO_NOT_STDIO 0
  29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  30 /* #define PerlIO FILE */
  31 #endif
  32 /*
  33  * This file provides those parts of PerlIO abstraction
  34  * which are not #defined in perlio.h.
  35  * Which these are depends on various Configure #ifdef's
  36  */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_PERLIO_C
  40 #include "perl.h"
  41
  42 #undef PerlMemShared_calloc
  43 #define PerlMemShared_calloc(x,y) calloc(x,y)
  44 #undef PerlMemShared_free
  45 #define PerlMemShared_free(x) free(x)
  46
  47 int
  48 perlsio_binmode(FILE *fp, int iotype, int mode)
  49 {
  50 /* This used to be contents of do_binmode in doio.c */
  51 #ifdef DOSISH
  52 #  if defined(atarist) || defined(__MINT__)
  53     if (!fflush(fp)) {
  54         if (mode & O_BINARY)
  55             ((FILE*)fp)->_flag |= _IOBIN;
  56         else
  57             ((FILE*)fp)->_flag &= ~ _IOBIN;
  58         return 1;
  59     }
  60     return 0;
  61 #  else
  62     dTHX;
  63     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  64 #    if defined(WIN32) && defined(__BORLANDC__)
  65         /* The translation mode of the stream is maintained independent
  66          * of the translation mode of the fd in the Borland RTL (heavy
  67          * digging through their runtime sources reveal).  User has to
  68          * set the mode explicitly for the stream (though they don't
  69          * document this anywhere). GSAR 97-5-24
  70          */
  71         fseek(fp,0L,0);
  72         if (mode & O_BINARY)
  73             fp->flags |= _F_BIN;
  74         else
  75             fp->flags &= ~ _F_BIN;
  76 #    endif
  77         return 1;
  78     }
  79     else
  80         return 0;
  81 #  endif
  82 #else
  83 #  if defined(USEMYBINMODE)
  84     if (my_binmode(fp, iotype, mode) != FALSE)
  85         return 1;
  86     else
  87         return 0;
  88 #  else
  89     return 1;
  90 #  endif
  91 #endif
  92 }
  93
  94 #ifndef PERLIO_LAYERS
  95 int
  96 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  97 {
  98  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  99   {
 100    return 0;
 101   }
 102  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
 103  /* NOTREACHED */
 104  return -1;
 105 }
 106
 107 void
 108 PerlIO_destruct(pTHX)
 109 {
 110 }
 111
 112 int
 113 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 114 {
 115 #ifdef USE_SFIO
 116  return 1;
 117 #else
 118  return perlsio_binmode(fp,iotype,mode);
 119 #endif
 120 }
 121
 122 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
 123
 124 PerlIO *
 125 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
 126 {
 127  if (narg == 1)
 128   {
 129    if (*args == &PL_sv_undef)
 130     return PerlIO_tmpfile();
 131    else
 132     {
 133      char *name = SvPV_nolen(*args);
 134      if (*mode == '#')
 135       {
 136        fd = PerlLIO_open3(name,imode,perm);
 137        if (fd >= 0)
 138         return PerlIO_fdopen(fd,(char *)mode+1);
 139       }
 140      else if (old)
 141       {
 142        return PerlIO_reopen(name,mode,old);
 143       }
 144      else
 145       {
 146        return PerlIO_open(name,mode);
 147       }
 148     }
 149   }
 150  else
 151   {
 152    return PerlIO_fdopen(fd,(char *)mode);
 153   }
 154  return NULL;
 155 }
 156
 157 #endif
 158
 159
 160 #ifdef PERLIO_IS_STDIO
 161
 162 void
 163 PerlIO_init(void)
 164 {
 165  /* Does nothing (yet) except force this file to be included
 166     in perl binary. That allows this file to force inclusion
 167     of other functions that may be required by loadable
 168     extensions e.g. for FileHandle::tmpfile
 169  */
 170 }
 171
 172 #undef PerlIO_tmpfile
 173 PerlIO *
 174 PerlIO_tmpfile(void)
 175 {
 176  return tmpfile();
 177 }
 178
 179 #else /* PERLIO_IS_STDIO */
 180
 181 #ifdef USE_SFIO
 182
 183 #undef HAS_FSETPOS
 184 #undef HAS_FGETPOS
 185
 186 /* This section is just to make sure these functions
 187    get pulled in from libsfio.a
 188 */
 189
 190 #undef PerlIO_tmpfile
 191 PerlIO *
 192 PerlIO_tmpfile(void)
 193 {
 194  return sftmp(0);
 195 }
 196
 197 void
 198 PerlIO_init(void)
 199 {
 200  /* Force this file to be included  in perl binary. Which allows
 201   *  this file to force inclusion  of other functions that may be
 202   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 203   */
 204
 205  /* Hack
 206   * sfio does its own 'autoflush' on stdout in common cases.
 207   * Flush results in a lot of lseek()s to regular files and
 208   * lot of small writes to pipes.
 209   */
 210  sfset(sfstdout,SF_SHARE,0);
 211 }
 212
 213 PerlIO *
 214 PerlIO_importFILE(FILE *stdio, int fl)
 215 {
 216  int fd    = fileno(stdio);
 217  PerlIO *r = PerlIO_fdopen(fd,"r+");
 218  return r;
 219 }
 220
 221 FILE *
 222 PerlIO_findFILE(PerlIO *pio)
 223 {
 224  int fd = PerlIO_fileno(pio);
 225  FILE *f = fdopen(fd,"r+");
 226  PerlIO_flush(pio);
 227  if (!f && errno == EINVAL)
 228   f = fdopen(fd,"w");
 229  if (!f && errno == EINVAL)
 230   f = fdopen(fd,"r");
 231  return f;
 232 }
 233
 234
 235 #else /* USE_SFIO */
 236 /*======================================================================================*/
 237 /* Implement all the PerlIO interface ourselves.
 238  */
 239
 240 #include "perliol.h"
 241
 242 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 243 #ifdef I_UNISTD
 244 #include <unistd.h>
 245 #endif
 246 #ifdef HAS_MMAP
 247 #include <sys/mman.h>
 248 #endif
 249
 250 #include "XSUB.h"
 251
 252 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 253
 254 void
 255 PerlIO_debug(const char *fmt,...)
 256 {
 257  static int dbg = 0;
 258  va_list ap;
 259  dSYS;
 260  va_start(ap,fmt);
 261  if (!dbg)
 262   {
 263    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 264    if (s && *s)
 265     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 266    else
 267     dbg = -1;
 268   }
 269  if (dbg > 0)
 270   {
 271    dTHX;
 272    SV *sv = newSVpvn("",0);
 273    char *s;
 274    STRLEN len;
 275    s = CopFILE(PL_curcop);
 276    if (!s)
 277     s = "(none)";
 278    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 279    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 280
 281    s = SvPV(sv,len);
 282    PerlLIO_write(dbg,s,len);
 283    SvREFCNT_dec(sv);
 284   }
 285  va_end(ap);
 286 }
 287
 288 /*--------------------------------------------------------------------------------------*/
 289
 290 /* Inner level routines */
 291
 292 /* Table of pointers to the PerlIO structs (malloc'ed) */
 293 PerlIO *_perlio      = NULL;
 294 #define PERLIO_TABLE_SIZE 64
 295
 296
 297
 298 PerlIO *
 299 PerlIO_allocate(pTHX)
 300 {
 301  /* Find a free slot in the table, allocating new table as necessary */
 302  PerlIO **last;
 303  PerlIO *f;
 304  last = &_perlio;
 305  while ((f = *last))
 306   {
 307    int i;
 308    last = (PerlIO **)(f);
 309    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 310     {
 311      if (!*++f)
 312       {
 313        return f;
 314       }
 315     }
 316   }
 317  f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
 318  if (!f)
 319   {
 320    return NULL;
 321   }
 322  *last = f;
 323  return f+1;
 324 }
 325
 326 void
 327 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 328 {
 329  PerlIO *table = *tablep;
 330  if (table)
 331   {
 332    int i;
 333    PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
 334    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 335     {
 336      PerlIO *f = table+i;
 337      if (*f)
 338       {
 339        PerlIO_close(f);
 340       }
 341     }
 342    PerlMemShared_free(table);
 343    *tablep = NULL;
 344   }
 345 }
 346
 347 HV *PerlIO_layer_hv;
 348 AV *PerlIO_layer_av;
 349
 350 void
 351 PerlIO_cleanup_layers(pTHXo_ void *data)
 352 {
 353  PerlIO_layer_hv = Nullhv;
 354  PerlIO_layer_av = Nullav;
 355 }
 356
 357 void
 358 PerlIO_cleanup()
 359 {
 360  dTHX;
 361  PerlIO_cleantable(aTHX_ &_perlio);
 362 }
 363
 364 void
 365 PerlIO_destruct(pTHX)
 366 {
 367  PerlIO **table = &_perlio;
 368  PerlIO *f;
 369  while ((f = *table))
 370   {
 371    int i;
 372    table = (PerlIO **)(f++);
 373    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 374     {
 375      PerlIO *x = f;
 376      PerlIOl *l;
 377      while ((l = *x))
 378       {
 379        if (l->tab->kind & PERLIO_K_DESTRUCT)
 380         {
 381          PerlIO_debug("Destruct popping %s\n",l->tab->name);
 382          PerlIO_flush(x);
 383          PerlIO_pop(aTHX_ x);
 384         }
 385        else
 386         {
 387          x = PerlIONext(x);
 388         }
 389       }
 390      f++;
 391     }
 392   }
 393 }
 394
 395 void
 396 PerlIO_pop(pTHX_ PerlIO *f)
 397 {
 398  PerlIOl *l = *f;
 399  if (l)
 400   {
 401    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 402    if (l->tab->Popped)
 403     (*l->tab->Popped)(f);
 404    *f = l->next;
 405    PerlMemShared_free(l);
 406   }
 407 }
 408
 409 /*--------------------------------------------------------------------------------------*/
 410 /* XS Interface for perl code */
 411
 412 SV *
 413 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 414 {
 415  SV **svp;
 416  SV *sv;
 417  if ((SSize_t) len <= 0)
 418   len = strlen(name);
 419  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 420  if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
 421   {
 422    SV *pkgsv  = newSVpvn("PerlIO",6);
 423    SV *layer  = newSVpvn(name,len);
 424    ENTER;
 425    /* The two SVs are magically freed by load_module */
 426    Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
 427    LEAVE;
 428    /* Say this is lvalue so we get an 'undef' if still not there */
 429    svp  = hv_fetch(PerlIO_layer_hv,name,len,1);
 430   }
 431  if (svp && (sv = *svp))
 432   {
 433    if (SvROK(sv))
 434     return *svp;
 435   }
 436  return Nullsv;
 437 }
 438
 439 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 440
 441 static int
 442 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 443 {
 444  if (SvROK(sv))
 445   {
 446    IO *io = GvIOn((GV *)SvRV(sv));
 447    PerlIO *ifp = IoIFP(io);
 448    PerlIO *ofp = IoOFP(io);
 449    Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
 450   }
 451  return 0;
 452 }
 453
 454 static int
 455 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 456 {
 457  if (SvROK(sv))
 458   {
 459    IO *io = GvIOn((GV *)SvRV(sv));
 460    PerlIO *ifp = IoIFP(io);
 461    PerlIO *ofp = IoOFP(io);
 462    Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
 463   }
 464  return 0;
 465 }
 466
 467 static int
 468 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 469 {
 470  Perl_warn(aTHX_ "clear %"SVf,sv);
 471  return 0;
 472 }
 473
 474 static int
 475 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 476 {
 477  Perl_warn(aTHX_ "free %"SVf,sv);
 478  return 0;
 479 }
 480
 481 MGVTBL perlio_vtab = {
 482  perlio_mg_get,
 483  perlio_mg_set,
 484  NULL, /* len */
 485  perlio_mg_clear,
 486  perlio_mg_free
 487 };
 488
 489 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 490 {
 491  dXSARGS;
 492  SV *sv    = SvRV(ST(1));
 493  AV *av    = newAV();
 494  MAGIC *mg;
 495  int count = 0;
 496  int i;
 497  sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
 498  SvRMAGICAL_off(sv);
 499  mg = mg_find(sv, PERL_MAGIC_ext);
 500  mg->mg_virtual = &perlio_vtab;
 501  mg_magical(sv);
 502  Perl_warn(aTHX_ "attrib %"SVf,sv);
 503  for (i=2; i < items; i++)
 504   {
 505    STRLEN len;
 506    const char *name = SvPV(ST(i),len);
 507    SV *layer  = PerlIO_find_layer(aTHX_ name,len,1);
 508    if (layer)
 509     {
 510      av_push(av,SvREFCNT_inc(layer));
 511     }
 512    else
 513     {
 514      ST(count) = ST(i);
 515      count++;
 516     }
 517   }
 518  SvREFCNT_dec(av);
 519  XSRETURN(count);
 520 }
 521
 522 #endif /* USE_ATTIBUTES_FOR_PERLIO */
 523
 524 SV *
 525 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 526 {
 527  HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
 528  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 529  return sv;
 530 }
 531
 532 void
 533 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 534 {
 535  if (!PerlIO_layer_hv)
 536   {
 537    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 538   }
 539  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
 540  PerlIO_debug("define %s %p\n",tab->name,tab);
 541 }
 542
 543 int
 544 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
 545 {
 546  if (names)
 547   {
 548    const char *s = names;
 549    while (*s)
 550     {
 551      while (isSPACE(*s) || *s == ':')
 552       s++;
 553      if (*s)
 554       {
 555        STRLEN llen = 0;
 556        const char *e = s;
 557        const char *as = Nullch;
 558        STRLEN alen = 0;
 559        if (!isIDFIRST(*s))
 560         {
 561          /* Message is consistent with how attribute lists are passed.
 562             Even though this means "foo : : bar" is seen as an invalid separator
 563             character.  */
 564          char q = ((*s == '\'') ? '"' : '\'');
 565          Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
 566          return -1;
 567         }
 568        do
 569         {
 570          e++;
 571         } while (isALNUM(*e));
 572        llen = e-s;
 573        if (*e == '(')
 574         {
 575          int nesting = 1;
 576          as = ++e;
 577          while (nesting)
 578           {
 579            switch (*e++)
 580             {
 581              case ')':
 582               if (--nesting == 0)
 583                alen = (e-1)-as;
 584               break;
 585              case '(':
 586               ++nesting;
 587               break;
 588              case '\\':
 589               /* It's a nul terminated string, not allowed to \ the terminating null.
 590                  Anything other character is passed over.  */
 591               if (*e++)
 592                {
 593                 break;
 594                }
 595               /* Drop through */
 596              case '\0':
 597               e--;
 598               Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
 599               return -1;
 600              default:
 601               /* boring.  */
 602               break;
 603             }
 604           }
 605         }
 606        if (e > s)
 607         {
 608          SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
 609          if (layer)
 610           {
 611            av_push(av,SvREFCNT_inc(layer));
 612            av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
 613           }
 614          else {
 615           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
 616           return -1;
 617          }
 618         }
 619        s = e;
 620       }
 621     }
 622   }
 623  return 0;
 624 }
 625
 626 void
 627 PerlIO_default_buffer(pTHX_ AV *av)
 628 {
 629  PerlIO_funcs *tab = &PerlIO_perlio;
 630  if (O_BINARY != O_TEXT)
 631   {
 632    tab = &PerlIO_crlf;
 633   }
 634  else
 635   {
 636    if (PerlIO_stdio.Set_ptrcnt)
 637     {
 638      tab = &PerlIO_stdio;
 639     }
 640   }
 641  PerlIO_debug("Pushing %s\n",tab->name);
 642  av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
 643  av_push(av,&PL_sv_undef);
 644 }
 645
 646 SV *
 647 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
 648 {
 649  SV **svp = av_fetch(av,n,FALSE);
 650  return (svp) ? *svp : Nullsv;
 651 }
 652
 653 PerlIO_funcs *
 654 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
 655 {
 656  SV **svp = av_fetch(av,n,FALSE);
 657  SV *layer;
 658  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 659   {
 660    /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
 661    return INT2PTR(PerlIO_funcs *, SvIV(layer));
 662   }
 663  if (!def)
 664   Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
 665  return def;
 666 }
 667
 668 AV *
 669 PerlIO_default_layers(pTHX)
 670 {
 671  IV len;
 672  if (!PerlIO_layer_av)
 673   {
 674    const char *s  = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
 675    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 676
 677 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 678    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 679 #endif
 680
 681    PerlIO_define_layer(aTHX_ &PerlIO_raw);
 682    PerlIO_define_layer(aTHX_ &PerlIO_unix);
 683    PerlIO_define_layer(aTHX_ &PerlIO_perlio);
 684    PerlIO_define_layer(aTHX_ &PerlIO_stdio);
 685    PerlIO_define_layer(aTHX_ &PerlIO_crlf);
 686 #ifdef HAS_MMAP
 687    PerlIO_define_layer(aTHX_ &PerlIO_mmap);
 688 #endif
 689    PerlIO_define_layer(aTHX_ &PerlIO_utf8);
 690    PerlIO_define_layer(aTHX_ &PerlIO_byte);
 691    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
 692    av_push(PerlIO_layer_av,&PL_sv_undef);
 693    if (s)
 694     {
 695      PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
 696     }
 697    else
 698     {
 699      PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
 700     }
 701   }
 702  len  = av_len(PerlIO_layer_av)+1;
 703  if (len < 2)
 704   {
 705    PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
 706    len  = av_len(PerlIO_layer_av);
 707   }
 708  return PerlIO_layer_av;
 709 }
 710
 711
 712 PerlIO_funcs *
 713 PerlIO_default_layer(pTHX_ I32 n)
 714 {
 715  AV *av = PerlIO_default_layers(aTHX);
 716  n *= 2;
 717  if (n < 0)
 718   n += av_len(PerlIO_layer_av)+1;
 719  return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
 720 }
 721
 722 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
 723 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
 724
 725 void
 726 PerlIO_stdstreams(pTHX)
 727 {
 728  if (!_perlio)
 729   {
 730    PerlIO_allocate(aTHX);
 731    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 732    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 733    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 734   }
 735 }
 736
 737 PerlIO *
 738 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
 739 {
 740  PerlIOl *l = NULL;
 741  l = PerlMemShared_calloc(tab->size,sizeof(char));
 742  if (l)
 743   {
 744    Zero(l,tab->size,char);
 745    l->next = *f;
 746    l->tab  = tab;
 747    *f      = l;
 748    PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
 749                  (mode) ? mode : "(Null)",arg);
 750    if ((*l->tab->Pushed)(f,mode,arg) != 0)
 751     {
 752      PerlIO_pop(aTHX_ f);
 753      return NULL;
 754     }
 755   }
 756  return f;
 757 }
 758
 759 IV
 760 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
 761 {
 762  dTHX;
 763  PerlIO_pop(aTHX_ f);
 764  if (*f)
 765   {
 766    PerlIO_flush(f);
 767    PerlIO_pop(aTHX_ f);
 768    return 0;
 769   }
 770  return -1;
 771 }
 772
 773 IV
 774 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
 775 {
 776  /* Remove the dummy layer */
 777  dTHX;
 778  PerlIO_pop(aTHX_ f);
 779  /* Pop back to bottom layer */
 780  if (f && *f)
 781   {
 782    PerlIO_flush(f);
 783    while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
 784     {
 785      if (*PerlIONext(f))
 786       {
 787        PerlIO_pop(aTHX_ f);
 788       }
 789      else
 790       {
 791        /* Nothing bellow - push unix on top then remove it */
 792        if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
 793         {
 794          PerlIO_pop(aTHX_ PerlIONext(f));
 795         }
 796        break;
 797       }
 798     }
 799    PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
 800    return 0;
 801   }
 802  return -1;
 803 }
 804
 805 int
 806 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
 807 {
 808  IV max = av_len(layers)+1;
 809  int code = 0;
 810  while (n < max)
 811   {
 812    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
 813    if (tab)
 814     {
 815      if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
 816       {
 817        code = -1;
 818        break;
 819       }
 820     }
 821    n += 2;
 822   }
 823  return code;
 824 }
 825
 826 int
 827 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 828 {
 829  int code = 0;
 830  if (names)
 831   {
 832    AV *layers = newAV();
 833    code = PerlIO_parse_layers(aTHX_ layers,names);
 834    if (code == 0)
 835     {
 836      code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
 837     }
 838    SvREFCNT_dec((SV *) layers);
 839   }
 840  return code;
 841 }
 842
 843
 844 /*--------------------------------------------------------------------------------------*/
 845 /* Given the abstraction above the public API functions */
 846
 847 int
 848 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 849 {
 850  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 851               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 852  if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
 853   {
 854    PerlIO *top = f;
 855    PerlIOl *l;
 856    while ((l = *top))
 857     {
 858      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 859       {
 860        PerlIO_flush(top);
 861        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 862        break;
 863       }
 864      top = PerlIONext(top);
 865     }
 866   }
 867  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 868 }
 869
 870 #undef PerlIO__close
 871 int
 872 PerlIO__close(PerlIO *f)
 873 {
 874  if (f && *f)
 875    return (*PerlIOBase(f)->tab->Close)(f);
 876  else
 877   {
 878    SETERRNO(EBADF,SS$_IVCHAN);
 879    return -1;
 880   }
 881 }
 882
 883 #undef PerlIO_fdupopen
 884 PerlIO *
 885 PerlIO_fdupopen(pTHX_ PerlIO *f)
 886 {
 887  if (f && *f)
 888   {
 889    char buf[8];
 890    int fd = PerlLIO_dup(PerlIO_fileno(f));
 891    PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
 892    if (new)
 893     {
 894      Off_t posn = PerlIO_tell(f);
 895      PerlIO_seek(new,posn,SEEK_SET);
 896     }
 897    return new;
 898   }
 899  else
 900   {
 901    SETERRNO(EBADF,SS$_IVCHAN);
 902    return NULL;
 903   }
 904 }
 905
 906 #undef PerlIO_close
 907 int
 908 PerlIO_close(PerlIO *f)
 909 {
 910  dTHX;
 911  int code = -1;
 912  if (f && *f)
 913   {
 914    code = (*PerlIOBase(f)->tab->Close)(f);
 915    while (*f)
 916     {
 917      PerlIO_pop(aTHX_ f);
 918     }
 919   }
 920  return code;
 921 }
 922
 923 #undef PerlIO_fileno
 924 int
 925 PerlIO_fileno(PerlIO *f)
 926 {
 927  if (f && *f)
 928   return (*PerlIOBase(f)->tab->Fileno)(f);
 929  else
 930   {
 931    SETERRNO(EBADF,SS$_IVCHAN);
 932    return -1;
 933   }
 934 }
 935
 936 static const char *
 937 PerlIO_context_layers(pTHX_ const char *mode)
 938 {
 939  const char *type = NULL;
 940  /* Need to supply default layer info from open.pm */
 941  if (PL_curcop)
 942   {
 943    SV *layers = PL_curcop->cop_io;
 944    if (layers)
 945     {
 946      STRLEN len;
 947      type = SvPV(layers,len);
 948      if (type && mode[0] != 'r')
 949       {
 950        /* Skip to write part */
 951        const char *s = strchr(type,0);
 952        if (s && (s-type) < len)
 953         {
 954          type = s+1;
 955         }
 956       }
 957     }
 958   }
 959  return type;
 960 }
 961
 962 static SV *
 963 PerlIO_layer_from_ref(pTHX_ SV *sv)
 964 {
 965  /* For any scalar type load the handler which is bundled with perl */
 966  if (SvTYPE(sv) < SVt_PVAV)
 967   return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
 968
 969  /* For other types allow if layer is known but don't try and load it */
 970  switch (SvTYPE(sv))
 971   {
 972    case SVt_PVAV:
 973     return PerlIO_find_layer(aTHX_ "Array",5, 0);
 974    case SVt_PVHV:
 975     return PerlIO_find_layer(aTHX_ "Hash",4, 0);
 976    case SVt_PVCV:
 977     return PerlIO_find_layer(aTHX_ "Code",4, 0);
 978    case SVt_PVGV:
 979     return PerlIO_find_layer(aTHX_ "Glob",4, 0);
 980   }
 981  return Nullsv;
 982 }
 983
 984 AV *
 985 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
 986 {
 987  AV *def = PerlIO_default_layers(aTHX);
 988  int incdef = 1;
 989  if (!_perlio)
 990   PerlIO_stdstreams(aTHX);
 991  if (narg)
 992   {
 993    SV *arg = *args;
 994    /* If it is a reference but not an object see if we have a handler for it */
 995    if (SvROK(arg) && !sv_isobject(arg))
 996     {
 997      SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
 998      if (handler)
 999       {
1000        def = newAV();
1001        av_push(def,SvREFCNT_inc(handler));
1002        av_push(def,&PL_sv_undef);
1003        incdef = 0;
1004       }
1005      /* Don't fail if handler cannot be found
1006       * :Via(...) etc. may do something sensible
1007       * else we will just stringfy and open resulting string.
1008       */
1009     }
1010   }
1011  if (!layers)
1012   layers = PerlIO_context_layers(aTHX_ mode);
1013  if (layers && *layers)
1014   {
1015    AV *av;
1016    if (incdef)
1017     {
1018      IV n = av_len(def)+1;
1019      av = newAV();
1020      while (n-- > 0)
1021       {
1022        SV **svp = av_fetch(def,n,0);
1023        av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
1024       }
1025     }
1026    else
1027     {
1028      av = def;
1029     }
1030    PerlIO_parse_layers(aTHX_ av,layers);
1031    return av;
1032   }
1033  else
1034   {
1035    if (incdef)
1036     SvREFCNT_inc(def);
1037    return def;
1038   }
1039 }
1040
1041 PerlIO *
1042 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1043 {
1044  if (!f && narg == 1 && *args == &PL_sv_undef)
1045   {
1046    if ((f = PerlIO_tmpfile()))
1047     {
1048      if (!layers)
1049       layers = PerlIO_context_layers(aTHX_ mode);
1050      if (layers && *layers)
1051       PerlIO_apply_layers(aTHX_ f,mode,layers);
1052     }
1053   }
1054  else
1055   {
1056    AV *layera;
1057    IV n;
1058    PerlIO_funcs *tab = NULL;
1059    if (f && *f)
1060     {
1061      /* This is "reopen" - it is not tested as perl does not use it yet */
1062      PerlIOl *l = *f;
1063      layera = newAV();
1064      while (l)
1065       {
1066        SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1067        av_unshift(layera,2);
1068        av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1069        av_store(layera,1,arg);
1070        l = *PerlIONext(&l);
1071       }
1072     }
1073    else
1074     {
1075      layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1076     }
1077    n = av_len(layera)-1;
1078    while (n >= 0)
1079     {
1080      PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1081      if (t && t->Open)
1082       {
1083        tab = t;
1084        break;
1085       }
1086      n -= 2;
1087     }
1088    if (tab)
1089     {
1090      PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1091                   tab->name,layers,mode,fd,imode,perm,f,narg,args);
1092      f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1093      if (f)
1094       {
1095        if (n+2 < av_len(layera)+1)
1096         {
1097          if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1098           {
1099            f = NULL;
1100           }
1101         }
1102       }
1103     }
1104    SvREFCNT_dec(layera);
1105   }
1106  return f;
1107 }
1108
1109
1110 #undef PerlIO_fdopen
1111 PerlIO *
1112 PerlIO_fdopen(int fd, const char *mode)
1113 {
1114  dTHX;
1115  return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1116 }
1117
1118 #undef PerlIO_open
1119 PerlIO *
1120 PerlIO_open(const char *path, const char *mode)
1121 {
1122  dTHX;
1123  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1124  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1125 }
1126
1127 #undef PerlIO_reopen
1128 PerlIO *
1129 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1130 {
1131  dTHX;
1132  SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1133  return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1134 }
1135
1136 #undef PerlIO_read
1137 SSize_t
1138 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1139 {
1140  if (f && *f)
1141   return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1142  else
1143   {
1144    SETERRNO(EBADF,SS$_IVCHAN);
1145    return -1;
1146   }
1147 }
1148
1149 #undef PerlIO_unread
1150 SSize_t
1151 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1152 {
1153  if (f && *f)
1154   return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1155  else
1156   {
1157    SETERRNO(EBADF,SS$_IVCHAN);
1158    return -1;
1159   }
1160 }
1161
1162 #undef PerlIO_write
1163 SSize_t
1164 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1165 {
1166  if (f && *f)
1167   return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1168  else
1169   {
1170    SETERRNO(EBADF,SS$_IVCHAN);
1171    return -1;
1172   }
1173 }
1174
1175 #undef PerlIO_seek
1176 int
1177 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1178 {
1179  if (f && *f)
1180   return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1181  else
1182   {
1183    SETERRNO(EBADF,SS$_IVCHAN);
1184    return -1;
1185   }
1186 }
1187
1188 #undef PerlIO_tell
1189 Off_t
1190 PerlIO_tell(PerlIO *f)
1191 {
1192   if (f && *f)
1193    return (*PerlIOBase(f)->tab->Tell)(f);
1194   else
1195    {
1196     SETERRNO(EBADF,SS$_IVCHAN);
1197     return -1;
1198    }
1199 }
1200
1201 #undef PerlIO_flush
1202 int
1203 PerlIO_flush(PerlIO *f)
1204 {
1205  if (f)
1206   {
1207    if (*f)
1208     {
1209      PerlIO_funcs *tab = PerlIOBase(f)->tab;
1210      if (tab && tab->Flush)
1211       {
1212        return (*tab->Flush)(f);
1213       }
1214      else
1215       {
1216        PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1217        SETERRNO(EBADF,SS$_IVCHAN);
1218        return -1;
1219       }
1220     }
1221    else
1222     {
1223      PerlIO_debug("Cannot flush f=%p\n",f);
1224      SETERRNO(EBADF,SS$_IVCHAN);
1225      return -1;
1226     }
1227   }
1228  else
1229   {
1230    /* Is it good API design to do flush-all on NULL,
1231     * a potentially errorneous input?  Maybe some magical
1232     * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1233     * Yes, stdio does similar things on fflush(NULL),
1234     * but should we be bound by their design decisions?
1235     * --jhi */
1236    PerlIO **table = &_perlio;
1237    int code = 0;
1238    while ((f = *table))
1239     {
1240      int i;
1241      table = (PerlIO **)(f++);
1242      for (i=1; i < PERLIO_TABLE_SIZE; i++)
1243       {
1244        if (*f && PerlIO_flush(f) != 0)
1245         code = -1;
1246        f++;
1247       }
1248     }
1249    return code;
1250   }
1251 }
1252
1253 void
1254 PerlIOBase_flush_linebuf()
1255 {
1256  PerlIO **table = &_perlio;
1257  PerlIO *f;
1258  while ((f = *table))
1259   {
1260    int i;
1261    table = (PerlIO **)(f++);
1262    for (i=1; i < PERLIO_TABLE_SIZE; i++)
1263     {
1264      if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1265                 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1266       PerlIO_flush(f);
1267      f++;
1268     }
1269   }
1270 }
1271
1272 #undef PerlIO_fill
1273 int
1274 PerlIO_fill(PerlIO *f)
1275 {
1276  if (f && *f)
1277   return (*PerlIOBase(f)->tab->Fill)(f);
1278  else
1279   {
1280    SETERRNO(EBADF,SS$_IVCHAN);
1281    return -1;
1282   }
1283 }
1284
1285 #undef PerlIO_isutf8
1286 int
1287 PerlIO_isutf8(PerlIO *f)
1288 {
1289  if (f && *f)
1290   return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1291  else
1292   {
1293    SETERRNO(EBADF,SS$_IVCHAN);
1294    return -1;
1295   }
1296 }
1297
1298 #undef PerlIO_eof
1299 int
1300 PerlIO_eof(PerlIO *f)
1301 {
1302  if (f && *f)
1303   return (*PerlIOBase(f)->tab->Eof)(f);
1304  else
1305   {
1306    SETERRNO(EBADF,SS$_IVCHAN);
1307    return -1;
1308   }
1309 }
1310
1311 #undef PerlIO_error
1312 int
1313 PerlIO_error(PerlIO *f)
1314 {
1315  if (f && *f)
1316   return (*PerlIOBase(f)->tab->Error)(f);
1317  else
1318   {
1319    SETERRNO(EBADF,SS$_IVCHAN);
1320    return -1;
1321   }
1322 }
1323
1324 #undef PerlIO_clearerr
1325 void
1326 PerlIO_clearerr(PerlIO *f)
1327 {
1328  if (f && *f)
1329   (*PerlIOBase(f)->tab->Clearerr)(f);
1330  else
1331   SETERRNO(EBADF,SS$_IVCHAN);
1332 }
1333
1334 #undef PerlIO_setlinebuf
1335 void
1336 PerlIO_setlinebuf(PerlIO *f)
1337 {
1338  if (f && *f)
1339   (*PerlIOBase(f)->tab->Setlinebuf)(f);
1340  else
1341   SETERRNO(EBADF,SS$_IVCHAN);
1342 }
1343
1344 #undef PerlIO_has_base
1345 int
1346 PerlIO_has_base(PerlIO *f)
1347 {
1348  if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1349  return 0;
1350 }
1351
1352 #undef PerlIO_fast_gets
1353 int
1354 PerlIO_fast_gets(PerlIO *f)
1355 {
1356  if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1357   {
1358    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1359    return (tab->Set_ptrcnt != NULL);
1360   }
1361  return 0;
1362 }
1363
1364 #undef PerlIO_has_cntptr
1365 int
1366 PerlIO_has_cntptr(PerlIO *f)
1367 {
1368  if (f && *f)
1369   {
1370    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1371    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1372   }
1373  return 0;
1374 }
1375
1376 #undef PerlIO_canset_cnt
1377 int
1378 PerlIO_canset_cnt(PerlIO *f)
1379 {
1380  if (f && *f)
1381   {
1382    PerlIOl *l = PerlIOBase(f);
1383    return (l->tab->Set_ptrcnt != NULL);
1384   }
1385  return 0;
1386 }
1387
1388 #undef PerlIO_get_base
1389 STDCHAR *
1390 PerlIO_get_base(PerlIO *f)
1391 {
1392  if (f && *f)
1393   return (*PerlIOBase(f)->tab->Get_base)(f);
1394  return NULL;
1395 }
1396
1397 #undef PerlIO_get_bufsiz
1398 int
1399 PerlIO_get_bufsiz(PerlIO *f)
1400 {
1401  if (f && *f)
1402   return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1403  return 0;
1404 }
1405
1406 #undef PerlIO_get_ptr
1407 STDCHAR *
1408 PerlIO_get_ptr(PerlIO *f)
1409 {
1410  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1411  if (tab->Get_ptr == NULL)
1412   return NULL;
1413  return (*tab->Get_ptr)(f);
1414 }
1415
1416 #undef PerlIO_get_cnt
1417 int
1418 PerlIO_get_cnt(PerlIO *f)
1419 {
1420  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1421  if (tab->Get_cnt == NULL)
1422   return 0;
1423  return (*tab->Get_cnt)(f);
1424 }
1425
1426 #undef PerlIO_set_cnt
1427 void
1428 PerlIO_set_cnt(PerlIO *f,int cnt)
1429 {
1430  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1431 }
1432
1433 #undef PerlIO_set_ptrcnt
1434 void
1435 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1436 {
1437  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1438  if (tab->Set_ptrcnt == NULL)
1439   {
1440    dTHX;
1441    Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1442   }
1443  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1444 }
1445
1446 /*--------------------------------------------------------------------------------------*/
1447 /* utf8 and raw dummy layers */
1448
1449 IV
1450 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1451 {
1452  if (PerlIONext(f))
1453   {
1454    dTHX;
1455    PerlIO_funcs *tab = PerlIOBase(f)->tab;
1456    PerlIO_pop(aTHX_ f);
1457    if (tab->kind & PERLIO_K_UTF8)
1458     PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1459    else
1460     PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1461    return 0;
1462   }
1463  return -1;
1464 }
1465
1466 PerlIO_funcs PerlIO_utf8 = {
1467  "utf8",
1468  sizeof(PerlIOl),
1469  PERLIO_K_DUMMY|PERLIO_F_UTF8,
1470  PerlIOUtf8_pushed,
1471  NULL,
1472  NULL,
1473  NULL,
1474  NULL,
1475  NULL,
1476  NULL,
1477  NULL,
1478  NULL,
1479  NULL,
1480  NULL,
1481  NULL, /* flush */
1482  NULL, /* fill */
1483  NULL,
1484  NULL,
1485  NULL,
1486  NULL,
1487  NULL, /* get_base */
1488  NULL, /* get_bufsiz */
1489  NULL, /* get_ptr */
1490  NULL, /* get_cnt */
1491  NULL, /* set_ptrcnt */
1492 };
1493
1494 PerlIO_funcs PerlIO_byte = {
1495  "bytes",
1496  sizeof(PerlIOl),
1497  PERLIO_K_DUMMY,
1498  PerlIOUtf8_pushed,
1499  NULL,
1500  NULL,
1501  NULL,
1502  NULL,
1503  NULL,
1504  NULL,
1505  NULL,
1506  NULL,
1507  NULL,
1508  NULL,
1509  NULL, /* flush */
1510  NULL, /* fill */
1511  NULL,
1512  NULL,
1513  NULL,
1514  NULL,
1515  NULL, /* get_base */
1516  NULL, /* get_bufsiz */
1517  NULL, /* get_ptr */
1518  NULL, /* get_cnt */
1519  NULL, /* set_ptrcnt */
1520 };
1521
1522 PerlIO *
1523 PerlIORaw_open(pTHX_ PerlIO_funcs *self,  AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1524 {
1525  PerlIO_funcs *tab = PerlIO_default_btm();
1526  return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1527 }
1528
1529 PerlIO_funcs PerlIO_raw = {
1530  "raw",
1531  sizeof(PerlIOl),
1532  PERLIO_K_DUMMY,
1533  PerlIORaw_pushed,
1534  PerlIOBase_popped,
1535  PerlIORaw_open,
1536  NULL,
1537  NULL,
1538  NULL,
1539  NULL,
1540  NULL,
1541  NULL,
1542  NULL,
1543  NULL,
1544  NULL, /* flush */
1545  NULL, /* fill */
1546  NULL,
1547  NULL,
1548  NULL,
1549  NULL,
1550  NULL, /* get_base */
1551  NULL, /* get_bufsiz */
1552  NULL, /* get_ptr */
1553  NULL, /* get_cnt */
1554  NULL, /* set_ptrcnt */
1555 };
1556 /*--------------------------------------------------------------------------------------*/
1557 /*--------------------------------------------------------------------------------------*/
1558 /* "Methods" of the "base class" */
1559
1560 IV
1561 PerlIOBase_fileno(PerlIO *f)
1562 {
1563  return PerlIO_fileno(PerlIONext(f));
1564 }
1565
1566 char *
1567 PerlIO_modestr(PerlIO *f,char *buf)
1568 {
1569  char *s = buf;
1570  IV flags = PerlIOBase(f)->flags;
1571  if (flags & PERLIO_F_APPEND)
1572   {
1573    *s++ = 'a';
1574    if (flags & PERLIO_F_CANREAD)
1575     {
1576      *s++ = '+';
1577     }
1578   }
1579  else if (flags & PERLIO_F_CANREAD)
1580   {
1581    *s++ = 'r';
1582    if (flags & PERLIO_F_CANWRITE)
1583     *s++ = '+';
1584   }
1585  else if (flags & PERLIO_F_CANWRITE)
1586   {
1587    *s++ = 'w';
1588    if (flags & PERLIO_F_CANREAD)
1589     {
1590      *s++ = '+';
1591     }
1592   }
1593 #if O_TEXT != O_BINARY
1594  if (!(flags & PERLIO_F_CRLF))
1595   *s++ = 'b';
1596 #endif
1597  *s = '\0';
1598  return buf;
1599 }
1600
1601 IV
1602 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1603 {
1604  PerlIOl *l = PerlIOBase(f);
1605 #if 0
1606  const char *omode = mode;
1607  char temp[8];
1608 #endif
1609  PerlIO_funcs *tab = PerlIOBase(f)->tab;
1610  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1611                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1612  if (tab->Set_ptrcnt != NULL)
1613   l->flags |= PERLIO_F_FASTGETS;
1614  if (mode)
1615   {
1616    if (*mode == '#' || *mode == 'I')
1617     mode++;
1618    switch (*mode++)
1619     {
1620      case 'r':
1621       l->flags |= PERLIO_F_CANREAD;
1622       break;
1623      case 'a':
1624       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1625       break;
1626      case 'w':
1627       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1628       break;
1629      default:
1630       SETERRNO(EINVAL,LIB$_INVARG);
1631       return -1;
1632     }
1633    while (*mode)
1634     {
1635      switch (*mode++)
1636       {
1637        case '+':
1638         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1639         break;
1640        case 'b':
1641         l->flags &= ~PERLIO_F_CRLF;
1642         break;
1643        case 't':
1644         l->flags |= PERLIO_F_CRLF;
1645         break;
1646       default:
1647         SETERRNO(EINVAL,LIB$_INVARG);
1648         return -1;
1649       }
1650     }
1651   }
1652  else
1653   {
1654    if (l->next)
1655     {
1656      l->flags |= l->next->flags &
1657                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1658     }
1659   }
1660 #if 0
1661  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1662               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1663               l->flags,PerlIO_modestr(f,temp));
1664 #endif
1665  return 0;
1666 }
1667
1668 IV
1669 PerlIOBase_popped(PerlIO *f)
1670 {
1671  return 0;
1672 }
1673
1674 SSize_t
1675 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1676 {
1677  dTHX;
1678  Off_t old = PerlIO_tell(f);
1679  SSize_t done;
1680  PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1681  done = PerlIOBuf_unread(f,vbuf,count);
1682  PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1683  return done;
1684 }
1685
1686 SSize_t
1687 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1688 {
1689  STDCHAR *buf  = (STDCHAR *) vbuf;
1690  if (f)
1691   {
1692    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1693     return 0;
1694    while (count > 0)
1695     {
1696      SSize_t avail = PerlIO_get_cnt(f);
1697      SSize_t take = 0;
1698      if (avail > 0)
1699        take = (count < avail) ? count : avail;
1700      if (take > 0)
1701       {
1702        STDCHAR *ptr = PerlIO_get_ptr(f);
1703        Copy(ptr,buf,take,STDCHAR);
1704        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1705        count   -= take;
1706        buf     += take;
1707       }
1708      if (count > 0  && avail <= 0)
1709       {
1710        if (PerlIO_fill(f) != 0)
1711         break;
1712       }
1713     }
1714    return (buf - (STDCHAR *) vbuf);
1715   }
1716  return 0;
1717 }
1718
1719 IV
1720 PerlIOBase_noop_ok(PerlIO *f)
1721 {
1722  return 0;
1723 }
1724
1725 IV
1726 PerlIOBase_noop_fail(PerlIO *f)
1727 {
1728  return -1;
1729 }
1730
1731 IV
1732 PerlIOBase_close(PerlIO *f)
1733 {
1734  IV code = 0;
1735  PerlIO *n = PerlIONext(f);
1736  if (PerlIO_flush(f) != 0)
1737   code = -1;
1738  if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1739   code = -1;
1740  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1741  return code;
1742 }
1743
1744 IV
1745 PerlIOBase_eof(PerlIO *f)
1746 {
1747  if (f && *f)
1748   {
1749    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1750   }
1751  return 1;
1752 }
1753
1754 IV
1755 PerlIOBase_error(PerlIO *f)
1756 {
1757  if (f && *f)
1758   {
1759    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1760   }
1761  return 1;
1762 }
1763
1764 void
1765 PerlIOBase_clearerr(PerlIO *f)
1766 {
1767  if (f && *f)
1768   {
1769    PerlIO *n = PerlIONext(f);
1770    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1771    if (n)
1772     PerlIO_clearerr(n);
1773   }
1774 }
1775
1776 void
1777 PerlIOBase_setlinebuf(PerlIO *f)
1778 {
1779  if (f)
1780   {
1781    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1782   }
1783 }
1784
1785 /*--------------------------------------------------------------------------------------*/
1786 /* Bottom-most level for UNIX-like case */
1787
1788 typedef struct
1789 {
1790  struct _PerlIO base;       /* The generic part */
1791  int            fd;         /* UNIX like file descriptor */
1792  int            oflags;     /* open/fcntl flags */
1793 } PerlIOUnix;
1794
1795 int
1796 PerlIOUnix_oflags(const char *mode)
1797 {
1798  int oflags = -1;
1799  switch(*mode)
1800   {
1801    case 'r':
1802     oflags = O_RDONLY;
1803     if (*++mode == '+')
1804      {
1805       oflags = O_RDWR;
1806       mode++;
1807      }
1808     break;
1809
1810    case 'w':
1811     oflags = O_CREAT|O_TRUNC;
1812     if (*++mode == '+')
1813      {
1814       oflags |= O_RDWR;
1815       mode++;
1816      }
1817     else
1818      oflags |= O_WRONLY;
1819     break;
1820
1821    case 'a':
1822     oflags = O_CREAT|O_APPEND;
1823     if (*++mode == '+')
1824      {
1825       oflags |= O_RDWR;
1826       mode++;
1827      }
1828     else
1829      oflags |= O_WRONLY;
1830     break;
1831   }
1832  if (*mode == 'b')
1833   {
1834    oflags |=  O_BINARY;
1835    oflags &= ~O_TEXT;
1836    mode++;
1837   }
1838  else if (*mode == 't')
1839   {
1840    oflags |=  O_TEXT;
1841    oflags &= ~O_BINARY;
1842    mode++;
1843   }
1844  /* Always open in binary mode */
1845  oflags |= O_BINARY;
1846  if (*mode || oflags == -1)
1847   {
1848    SETERRNO(EINVAL,LIB$_INVARG);
1849    oflags = -1;
1850   }
1851  return oflags;
1852 }
1853
1854 IV
1855 PerlIOUnix_fileno(PerlIO *f)
1856 {
1857  return PerlIOSelf(f,PerlIOUnix)->fd;
1858 }
1859
1860 IV
1861 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1862 {
1863  IV code = PerlIOBase_pushed(f,mode,arg);
1864  if (*PerlIONext(f))
1865   {
1866    PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1867    s->fd     = PerlIO_fileno(PerlIONext(f));
1868    s->oflags = PerlIOUnix_oflags(mode);
1869   }
1870  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1871  return code;
1872 }
1873
1874 PerlIO *
1875 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1876 {
1877  if (f)
1878   {
1879    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1880     (*PerlIOBase(f)->tab->Close)(f);
1881   }
1882  if (narg > 0)
1883   {
1884    char *path = SvPV_nolen(*args);
1885    if (*mode == '#')
1886     mode++;
1887    else
1888     {
1889      imode = PerlIOUnix_oflags(mode);
1890      perm  = 0666;
1891     }
1892    if (imode != -1)
1893     {
1894      fd = PerlLIO_open3(path,imode,perm);
1895     }
1896   }
1897  if (fd >= 0)
1898   {
1899    PerlIOUnix *s;
1900    if (*mode == 'I')
1901     mode++;
1902    if (!f)
1903     {
1904      f = PerlIO_allocate(aTHX);
1905      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1906     }
1907    else
1908     s = PerlIOSelf(f,PerlIOUnix);
1909    s->fd     = fd;
1910    s->oflags = imode;
1911    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1912    return f;
1913   }
1914  else
1915   {
1916    if (f)
1917     {
1918      /* FIXME: pop layers ??? */
1919     }
1920    return NULL;
1921   }
1922 }
1923
1924 SSize_t
1925 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1926 {
1927  dTHX;
1928  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1929  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1930   return 0;
1931  while (1)
1932   {
1933    SSize_t len = PerlLIO_read(fd,vbuf,count);
1934    if (len >= 0 || errno != EINTR)
1935     {
1936      if (len < 0)
1937       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1938      else if (len == 0 && count != 0)
1939       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1940      return len;
1941     }
1942    PERL_ASYNC_CHECK();
1943   }
1944 }
1945
1946 SSize_t
1947 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1948 {
1949  dTHX;
1950  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1951  while (1)
1952   {
1953    SSize_t len = PerlLIO_write(fd,vbuf,count);
1954    if (len >= 0 || errno != EINTR)
1955     {
1956      if (len < 0)
1957       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1958      return len;
1959     }
1960    PERL_ASYNC_CHECK();
1961   }
1962 }
1963
1964 IV
1965 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1966 {
1967  dSYS;
1968  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1969  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1970  return (new == (Off_t) -1) ? -1 : 0;
1971 }
1972
1973 Off_t
1974 PerlIOUnix_tell(PerlIO *f)
1975 {
1976  dSYS;
1977  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1978 }
1979
1980 IV
1981 PerlIOUnix_close(PerlIO *f)
1982 {
1983  dTHX;
1984  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1985  int code = 0;
1986  while (PerlLIO_close(fd) != 0)
1987   {
1988    if (errno != EINTR)
1989     {
1990      code = -1;
1991      break;
1992     }
1993    PERL_ASYNC_CHECK();
1994   }
1995  if (code == 0)
1996   {
1997    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1998   }
1999  return code;
2000 }
2001
2002 PerlIO_funcs PerlIO_unix = {
2003  "unix",
2004  sizeof(PerlIOUnix),
2005  PERLIO_K_RAW,
2006  PerlIOUnix_pushed,
2007  PerlIOBase_noop_ok,
2008  PerlIOUnix_open,
2009  NULL,
2010  PerlIOUnix_fileno,
2011  PerlIOUnix_read,
2012  PerlIOBase_unread,
2013  PerlIOUnix_write,
2014  PerlIOUnix_seek,
2015  PerlIOUnix_tell,
2016  PerlIOUnix_close,
2017  PerlIOBase_noop_ok,   /* flush */
2018  PerlIOBase_noop_fail, /* fill */
2019  PerlIOBase_eof,
2020  PerlIOBase_error,
2021  PerlIOBase_clearerr,
2022  PerlIOBase_setlinebuf,
2023  NULL, /* get_base */
2024  NULL, /* get_bufsiz */
2025  NULL, /* get_ptr */
2026  NULL, /* get_cnt */
2027  NULL, /* set_ptrcnt */
2028 };
2029
2030 /*--------------------------------------------------------------------------------------*/
2031 /* stdio as a layer */
2032
2033 typedef struct
2034 {
2035  struct _PerlIO base;
2036  FILE *         stdio;      /* The stream */
2037 } PerlIOStdio;
2038
2039 IV
2040 PerlIOStdio_fileno(PerlIO *f)
2041 {
2042  dSYS;
2043  return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2044 }
2045
2046 char *
2047 PerlIOStdio_mode(const char *mode,char *tmode)
2048 {
2049  char *ret = tmode;
2050  while (*mode)
2051   {
2052    *tmode++ = *mode++;
2053   }
2054  if (O_BINARY != O_TEXT)
2055   {
2056    *tmode++ = 'b';
2057   }
2058  *tmode = '\0';
2059  return ret;
2060 }
2061
2062 /* This isn't used yet ... */
2063 IV
2064 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2065 {
2066  if (*PerlIONext(f))
2067   {
2068    dSYS;
2069    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2070    char tmode[8];
2071    FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2072    if (stdio)
2073     s->stdio = stdio;
2074    else
2075     return -1;
2076   }
2077  return PerlIOBase_pushed(f,mode,arg);
2078 }
2079
2080 #undef PerlIO_importFILE
2081 PerlIO *
2082 PerlIO_importFILE(FILE *stdio, int fl)
2083 {
2084  dTHX;
2085  PerlIO *f = NULL;
2086  if (stdio)
2087   {
2088    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2089    s->stdio  = stdio;
2090   }
2091  return f;
2092 }
2093
2094 PerlIO *
2095 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2096 {
2097  char tmode[8];
2098  if (f)
2099   {
2100    char *path = SvPV_nolen(*args);
2101    PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2102    FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2103    if (!s->stdio)
2104     return NULL;
2105    s->stdio = stdio;
2106    return f;
2107   }
2108  else
2109   {
2110    if (narg > 0)
2111     {
2112      char *path = SvPV_nolen(*args);
2113      if (*mode == '#')
2114       {
2115        mode++;
2116        fd = PerlLIO_open3(path,imode,perm);
2117       }
2118      else
2119       {
2120        FILE *stdio = PerlSIO_fopen(path,mode);
2121        if (stdio)
2122         {
2123          PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2124                                      (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2125                                      PerlIOStdio);
2126          s->stdio  = stdio;
2127         }
2128        return f;
2129       }
2130     }
2131    if (fd >= 0)
2132     {
2133      FILE *stdio = NULL;
2134      int init = 0;
2135      if (*mode == 'I')
2136       {
2137        init = 1;
2138        mode++;
2139       }
2140      if (init)
2141       {
2142        switch(fd)
2143         {
2144          case 0:
2145           stdio = PerlSIO_stdin;
2146           break;
2147          case 1:
2148           stdio = PerlSIO_stdout;
2149           break;
2150          case 2:
2151           stdio = PerlSIO_stderr;
2152           break;
2153         }
2154       }
2155      else
2156       {
2157        stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2158       }
2159      if (stdio)
2160       {
2161        PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2162        s->stdio  = stdio;
2163        return f;
2164       }
2165     }
2166   }
2167  return NULL;
2168 }
2169
2170 SSize_t
2171 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2172 {
2173  dSYS;
2174  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2175  SSize_t got = 0;
2176  if (count == 1)
2177   {
2178    STDCHAR *buf = (STDCHAR *) vbuf;
2179    /* Perl is expecting PerlIO_getc() to fill the buffer
2180     * Linux's stdio does not do that for fread()
2181     */
2182    int ch = PerlSIO_fgetc(s);
2183    if (ch != EOF)
2184     {
2185      *buf = ch;
2186      got = 1;
2187     }
2188   }
2189  else
2190   got = PerlSIO_fread(vbuf,1,count,s);
2191  return got;
2192 }
2193
2194 SSize_t
2195 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2196 {
2197  dSYS;
2198  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2199  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2200  SSize_t unread = 0;
2201  while (count > 0)
2202   {
2203    int ch = *buf-- & 0xff;
2204    if (PerlSIO_ungetc(ch,s) != ch)
2205     break;
2206    unread++;
2207    count--;
2208   }
2209  return unread;
2210 }
2211
2212 SSize_t
2213 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2214 {
2215  dSYS;
2216  return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2217 }
2218
2219 IV
2220 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2221 {
2222  dSYS;
2223  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2224  return PerlSIO_fseek(stdio,offset,whence);
2225 }
2226
2227 Off_t
2228 PerlIOStdio_tell(PerlIO *f)
2229 {
2230  dSYS;
2231  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2232  return PerlSIO_ftell(stdio);
2233 }
2234
2235 IV
2236 PerlIOStdio_close(PerlIO *f)
2237 {
2238  dSYS;
2239 #ifdef SOCKS5_VERSION_NAME
2240  int optval;
2241  Sock_size_t optlen = sizeof(int);
2242 #endif
2243  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2244  return(
2245 #ifdef SOCKS5_VERSION_NAME
2246    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2247        PerlSIO_fclose(stdio) :
2248        close(PerlIO_fileno(f))
2249 #else
2250    PerlSIO_fclose(stdio)
2251 #endif
2252      );
2253
2254 }
2255
2256 IV
2257 PerlIOStdio_flush(PerlIO *f)
2258 {
2259  dSYS;
2260  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2261  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2262   {
2263    return PerlSIO_fflush(stdio);
2264   }
2265  else
2266   {
2267 #if 0
2268    /* FIXME: This discards ungetc() and pre-read stuff which is
2269       not right if this is just a "sync" from a layer above
2270       Suspect right design is to do _this_ but not have layer above
2271       flush this layer read-to-read
2272     */
2273    /* Not writeable - sync by attempting a seek */
2274    int err = errno;
2275    if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2276     errno = err;
2277 #endif
2278   }
2279  return 0;
2280 }
2281
2282 IV
2283 PerlIOStdio_fill(PerlIO *f)
2284 {
2285  dSYS;
2286  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2287  int c;
2288  /* fflush()ing read-only streams can cause trouble on some stdio-s */
2289  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2290   {
2291    if (PerlSIO_fflush(stdio) != 0)
2292     return EOF;
2293   }
2294  c = PerlSIO_fgetc(stdio);
2295  if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2296   return EOF;
2297  return 0;
2298 }
2299
2300 IV
2301 PerlIOStdio_eof(PerlIO *f)
2302 {
2303  dSYS;
2304  return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2305 }
2306
2307 IV
2308 PerlIOStdio_error(PerlIO *f)
2309 {
2310  dSYS;
2311  return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2312 }
2313
2314 void
2315 PerlIOStdio_clearerr(PerlIO *f)
2316 {
2317  dSYS;
2318  PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2319 }
2320
2321 void
2322 PerlIOStdio_setlinebuf(PerlIO *f)
2323 {
2324  dSYS;
2325 #ifdef HAS_SETLINEBUF
2326  PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2327 #else
2328  PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2329 #endif
2330 }
2331
2332 #ifdef FILE_base
2333 STDCHAR *
2334 PerlIOStdio_get_base(PerlIO *f)
2335 {
2336  dSYS;
2337  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
2338  return PerlSIO_get_base(stdio);
2339 }
2340
2341 Size_t
2342 PerlIOStdio_get_bufsiz(PerlIO *f)
2343 {
2344  dSYS;
2345  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2346  return PerlSIO_get_bufsiz(stdio);
2347 }
2348 #endif
2349
2350 #ifdef USE_STDIO_PTR
2351 STDCHAR *
2352 PerlIOStdio_get_ptr(PerlIO *f)
2353 {
2354  dSYS;
2355  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2356  return PerlSIO_get_ptr(stdio);
2357 }
2358
2359 SSize_t
2360 PerlIOStdio_get_cnt(PerlIO *f)
2361 {
2362  dSYS;
2363  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2364  return PerlSIO_get_cnt(stdio);
2365 }
2366
2367 void
2368 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2369 {
2370  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2371  dSYS;
2372  if (ptr != NULL)
2373   {
2374 #ifdef STDIO_PTR_LVALUE
2375    PerlSIO_set_ptr(stdio,ptr);
2376 #ifdef STDIO_PTR_LVAL_SETS_CNT
2377    if (PerlSIO_get_cnt(stdio) != (cnt))
2378     {
2379      dTHX;
2380      assert(PerlSIO_get_cnt(stdio) == (cnt));
2381     }
2382 #endif
2383 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2384    /* Setting ptr _does_ change cnt - we are done */
2385    return;
2386 #endif
2387 #else  /* STDIO_PTR_LVALUE */
2388    PerlProc_abort();
2389 #endif /* STDIO_PTR_LVALUE */
2390   }
2391 /* Now (or only) set cnt */
2392 #ifdef STDIO_CNT_LVALUE
2393  PerlSIO_set_cnt(stdio,cnt);
2394 #else  /* STDIO_CNT_LVALUE */
2395 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2396  PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2397 #else  /* STDIO_PTR_LVAL_SETS_CNT */
2398  PerlProc_abort();
2399 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2400 #endif /* STDIO_CNT_LVALUE */
2401 }
2402
2403 #endif
2404
2405 PerlIO_funcs PerlIO_stdio = {
2406  "stdio",
2407  sizeof(PerlIOStdio),
2408  PERLIO_K_BUFFERED,
2409  PerlIOBase_pushed,
2410  PerlIOBase_noop_ok,
2411  PerlIOStdio_open,
2412  NULL,
2413  PerlIOStdio_fileno,
2414  PerlIOStdio_read,
2415  PerlIOStdio_unread,
2416  PerlIOStdio_write,
2417  PerlIOStdio_seek,
2418  PerlIOStdio_tell,
2419  PerlIOStdio_close,
2420  PerlIOStdio_flush,
2421  PerlIOStdio_fill,
2422  PerlIOStdio_eof,
2423  PerlIOStdio_error,
2424  PerlIOStdio_clearerr,
2425  PerlIOStdio_setlinebuf,
2426 #ifdef FILE_base
2427  PerlIOStdio_get_base,
2428  PerlIOStdio_get_bufsiz,
2429 #else
2430  NULL,
2431  NULL,
2432 #endif
2433 #ifdef USE_STDIO_PTR
2434  PerlIOStdio_get_ptr,
2435  PerlIOStdio_get_cnt,
2436 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2437  PerlIOStdio_set_ptrcnt
2438 #else  /* STDIO_PTR_LVALUE */
2439  NULL
2440 #endif /* STDIO_PTR_LVALUE */
2441 #else  /* USE_STDIO_PTR */
2442  NULL,
2443  NULL,
2444  NULL
2445 #endif /* USE_STDIO_PTR */
2446 };
2447
2448 #undef PerlIO_exportFILE
2449 FILE *
2450 PerlIO_exportFILE(PerlIO *f, int fl)
2451 {
2452  FILE *stdio;
2453  PerlIO_flush(f);
2454  stdio = fdopen(PerlIO_fileno(f),"r+");
2455  if (stdio)
2456   {
2457    dTHX;
2458    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2459    s->stdio  = stdio;
2460   }
2461  return stdio;
2462 }
2463
2464 #undef PerlIO_findFILE
2465 FILE *
2466 PerlIO_findFILE(PerlIO *f)
2467 {
2468  PerlIOl *l = *f;
2469  while (l)
2470   {
2471    if (l->tab == &PerlIO_stdio)
2472     {
2473      PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2474      return s->stdio;
2475     }
2476    l = *PerlIONext(&l);
2477   }
2478  return PerlIO_exportFILE(f,0);
2479 }
2480
2481 #undef PerlIO_releaseFILE
2482 void
2483 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2484 {
2485 }
2486
2487 /*--------------------------------------------------------------------------------------*/
2488 /* perlio buffer layer */
2489
2490 IV
2491 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2492 {
2493  dSYS;
2494  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2495  int fd  = PerlIO_fileno(f);
2496  Off_t posn;
2497  if (fd >= 0 && PerlLIO_isatty(fd))
2498   {
2499    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2500   }
2501  posn = PerlIO_tell(PerlIONext(f));
2502  if (posn != (Off_t) -1)
2503   {
2504    b->posn = posn;
2505   }
2506  return PerlIOBase_pushed(f,mode,arg);
2507 }
2508
2509 PerlIO *
2510 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2511 {
2512  if (f)
2513   {
2514    PerlIO *next = PerlIONext(f);
2515    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2516    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2517    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2518     {
2519      return NULL;
2520     }
2521   }
2522  else
2523   {
2524    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2525    int init = 0;
2526    if (*mode == 'I')
2527     {
2528      init = 1;
2529      mode++;
2530     }
2531    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2532    if (f)
2533     {
2534      PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2535      fd = PerlIO_fileno(f);
2536 #if O_BINARY != O_TEXT
2537      /* do something about failing setmode()? --jhi */
2538      PerlLIO_setmode(fd , O_BINARY);
2539 #endif
2540      if (init && fd == 2)
2541       {
2542        /* Initial stderr is unbuffered */
2543        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2544       }
2545     }
2546   }
2547  return f;
2548 }
2549
2550 /* This "flush" is akin to sfio's sync in that it handles files in either
2551    read or write state
2552 */
2553 IV
2554 PerlIOBuf_flush(PerlIO *f)
2555 {
2556  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2557  int code = 0;
2558  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2559   {
2560    /* write() the buffer */
2561    STDCHAR *buf = b->buf;
2562    STDCHAR *p = buf;
2563    PerlIO *n = PerlIONext(f);
2564    while (p < b->ptr)
2565     {
2566      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2567      if (count > 0)
2568       {
2569        p += count;
2570       }
2571      else if (count < 0 || PerlIO_error(n))
2572       {
2573        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2574        code = -1;
2575        break;
2576       }
2577     }
2578    b->posn += (p - buf);
2579   }
2580  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2581   {
2582    STDCHAR *buf = PerlIO_get_base(f);
2583    /* Note position change */
2584    b->posn += (b->ptr - buf);
2585    if (b->ptr < b->end)
2586     {
2587      /* We did not consume all of it */
2588      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2589       {
2590        b->posn = PerlIO_tell(PerlIONext(f));
2591       }
2592     }
2593   }
2594  b->ptr = b->end = b->buf;
2595  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2596  /* FIXME: Is this right for read case ? */
2597  if (PerlIO_flush(PerlIONext(f)) != 0)
2598   code = -1;
2599  return code;
2600 }
2601
2602 IV
2603 PerlIOBuf_fill(PerlIO *f)
2604 {
2605  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2606  PerlIO *n = PerlIONext(f);
2607  SSize_t avail;
2608  /* FIXME: doing the down-stream flush is a bad idea if it causes
2609     pre-read data in stdio buffer to be discarded
2610     but this is too simplistic - as it skips _our_ hosekeeping
2611     and breaks tell tests.
2612  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2613   {
2614   }
2615   */
2616  if (PerlIO_flush(f) != 0)
2617   return -1;
2618  if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2619   PerlIOBase_flush_linebuf();
2620
2621  if (!b->buf)
2622   PerlIO_get_base(f); /* allocate via vtable */
2623
2624  b->ptr = b->end = b->buf;
2625  if (PerlIO_fast_gets(n))
2626   {
2627    /* Layer below is also buffered
2628     * We do _NOT_ want to call its ->Read() because that will loop
2629     * till it gets what we asked for which may hang on a pipe etc.
2630     * Instead take anything it has to hand, or ask it to fill _once_.
2631     */
2632    avail  = PerlIO_get_cnt(n);
2633    if (avail <= 0)
2634     {
2635      avail = PerlIO_fill(n);
2636      if (avail == 0)
2637       avail = PerlIO_get_cnt(n);
2638      else
2639       {
2640        if (!PerlIO_error(n) && PerlIO_eof(n))
2641         avail = 0;
2642       }
2643     }
2644    if (avail > 0)
2645     {
2646      STDCHAR *ptr = PerlIO_get_ptr(n);
2647      SSize_t cnt  = avail;
2648      if (avail > b->bufsiz)
2649       avail = b->bufsiz;
2650      Copy(ptr,b->buf,avail,STDCHAR);
2651      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2652     }
2653   }
2654  else
2655   {
2656    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2657   }
2658  if (avail <= 0)
2659   {
2660    if (avail == 0)
2661     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2662    else
2663     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2664    return -1;
2665   }
2666  b->end      = b->buf+avail;
2667  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2668  return 0;
2669 }
2670
2671 SSize_t
2672 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2673 {
2674  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2675  if (f)
2676   {
2677    if (!b->ptr)
2678     PerlIO_get_base(f);
2679    return PerlIOBase_read(f,vbuf,count);
2680   }
2681  return 0;
2682 }
2683
2684 SSize_t
2685 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2686 {
2687  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2688  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2689  SSize_t unread = 0;
2690  SSize_t avail;
2691  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2692   PerlIO_flush(f);
2693  if (!b->buf)
2694   PerlIO_get_base(f);
2695  if (b->buf)
2696   {
2697    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2698     {
2699      avail = (b->ptr - b->buf);
2700     }
2701    else
2702     {
2703      avail = b->bufsiz;
2704      b->end = b->buf + avail;
2705      b->ptr = b->end;
2706      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2707      b->posn -= b->bufsiz;
2708     }
2709    if (avail > (SSize_t) count)
2710     avail = count;
2711    if (avail > 0)
2712     {
2713      b->ptr -= avail;
2714      buf    -= avail;
2715      if (buf != b->ptr)
2716       {
2717        Copy(buf,b->ptr,avail,STDCHAR);
2718       }
2719      count  -= avail;
2720      unread += avail;
2721      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2722     }
2723   }
2724  return unread;
2725 }
2726
2727 SSize_t
2728 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2729 {
2730  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2731  const STDCHAR *buf = (const STDCHAR *) vbuf;
2732  Size_t written = 0;
2733  if (!b->buf)
2734   PerlIO_get_base(f);
2735  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2736   return 0;
2737  while (count > 0)
2738   {
2739    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2740    if ((SSize_t) count < avail)
2741     avail = count;
2742    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2743    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2744     {
2745      while (avail > 0)
2746       {
2747        int ch = *buf++;
2748        *(b->ptr)++ = ch;
2749        count--;
2750        avail--;
2751        written++;
2752        if (ch == '\n')
2753         {
2754          PerlIO_flush(f);
2755          break;
2756         }
2757       }
2758     }
2759    else
2760     {
2761      if (avail)
2762       {
2763        Copy(buf,b->ptr,avail,STDCHAR);
2764        count   -= avail;
2765        buf     += avail;
2766        written += avail;
2767        b->ptr  += avail;
2768       }
2769     }
2770    if (b->ptr >= (b->buf + b->bufsiz))
2771     PerlIO_flush(f);
2772   }
2773  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2774   PerlIO_flush(f);
2775  return written;
2776 }
2777
2778 IV
2779 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2780 {
2781  IV code;
2782  if ((code = PerlIO_flush(f)) == 0)
2783   {
2784    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2785    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2786    code = PerlIO_seek(PerlIONext(f),offset,whence);
2787    if (code == 0)
2788     {
2789      b->posn = PerlIO_tell(PerlIONext(f));
2790     }
2791   }
2792  return code;
2793 }
2794
2795 Off_t
2796 PerlIOBuf_tell(PerlIO *f)
2797 {
2798  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2799  Off_t posn = b->posn;
2800  if (b->buf)
2801   posn += (b->ptr - b->buf);
2802  return posn;
2803 }
2804
2805 IV
2806 PerlIOBuf_close(PerlIO *f)
2807 {
2808  IV code = PerlIOBase_close(f);
2809  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2810  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2811   {
2812    PerlMemShared_free(b->buf);
2813   }
2814  b->buf = NULL;
2815  b->ptr = b->end = b->buf;
2816  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2817  return code;
2818 }
2819
2820 STDCHAR *
2821 PerlIOBuf_get_ptr(PerlIO *f)
2822 {
2823  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2824  if (!b->buf)
2825   PerlIO_get_base(f);
2826  return b->ptr;
2827 }
2828
2829 SSize_t
2830 PerlIOBuf_get_cnt(PerlIO *f)
2831 {
2832  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2833  if (!b->buf)
2834   PerlIO_get_base(f);
2835  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2836   return (b->end - b->ptr);
2837  return 0;
2838 }
2839
2840 STDCHAR *
2841 PerlIOBuf_get_base(PerlIO *f)
2842 {
2843  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2844  if (!b->buf)
2845   {
2846    if (!b->bufsiz)
2847     b->bufsiz = 4096;
2848    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2849    if (!b->buf)
2850     {
2851      b->buf = (STDCHAR *)&b->oneword;
2852      b->bufsiz = sizeof(b->oneword);
2853     }
2854    b->ptr = b->buf;
2855    b->end = b->ptr;
2856   }
2857  return b->buf;
2858 }
2859
2860 Size_t
2861 PerlIOBuf_bufsiz(PerlIO *f)
2862 {
2863  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2864  if (!b->buf)
2865   PerlIO_get_base(f);
2866  return (b->end - b->buf);
2867 }
2868
2869 void
2870 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2871 {
2872  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2873  if (!b->buf)
2874   PerlIO_get_base(f);
2875  b->ptr = ptr;
2876  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2877   {
2878    dTHX;
2879    assert(PerlIO_get_cnt(f) == cnt);
2880    assert(b->ptr >= b->buf);
2881   }
2882  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2883 }
2884
2885 PerlIO_funcs PerlIO_perlio = {
2886  "perlio",
2887  sizeof(PerlIOBuf),
2888  PERLIO_K_BUFFERED,
2889  PerlIOBuf_pushed,
2890  PerlIOBase_noop_ok,
2891  PerlIOBuf_open,
2892  NULL,
2893  PerlIOBase_fileno,
2894  PerlIOBuf_read,
2895  PerlIOBuf_unread,
2896  PerlIOBuf_write,
2897  PerlIOBuf_seek,
2898  PerlIOBuf_tell,
2899  PerlIOBuf_close,
2900  PerlIOBuf_flush,
2901  PerlIOBuf_fill,
2902  PerlIOBase_eof,
2903  PerlIOBase_error,
2904  PerlIOBase_clearerr,
2905  PerlIOBase_setlinebuf,
2906  PerlIOBuf_get_base,
2907  PerlIOBuf_bufsiz,
2908  PerlIOBuf_get_ptr,
2909  PerlIOBuf_get_cnt,
2910  PerlIOBuf_set_ptrcnt,
2911 };
2912
2913 /*--------------------------------------------------------------------------------------*/
2914 /* Temp layer to hold unread chars when cannot do it any other way */
2915
2916 IV
2917 PerlIOPending_fill(PerlIO *f)
2918 {
2919  /* Should never happen */
2920  PerlIO_flush(f);
2921  return 0;
2922 }
2923
2924 IV
2925 PerlIOPending_close(PerlIO *f)
2926 {
2927  /* A tad tricky - flush pops us, then we close new top */
2928  PerlIO_flush(f);
2929  return PerlIO_close(f);
2930 }
2931
2932 IV
2933 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2934 {
2935  /* A tad tricky - flush pops us, then we seek new top */
2936  PerlIO_flush(f);
2937  return PerlIO_seek(f,offset,whence);
2938 }
2939
2940
2941 IV
2942 PerlIOPending_flush(PerlIO *f)
2943 {
2944  dTHX;
2945  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2946  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2947   {
2948    PerlMemShared_free(b->buf);
2949    b->buf = NULL;
2950   }
2951  PerlIO_pop(aTHX_ f);
2952  return 0;
2953 }
2954
2955 void
2956 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2957 {
2958  if (cnt <= 0)
2959   {
2960    PerlIO_flush(f);
2961   }
2962  else
2963   {
2964    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2965   }
2966 }
2967
2968 IV
2969 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2970 {
2971  IV code    = PerlIOBase_pushed(f,mode,arg);
2972  PerlIOl *l = PerlIOBase(f);
2973  /* Our PerlIO_fast_gets must match what we are pushed on,
2974     or sv_gets() etc. get muddled when it changes mid-string
2975     when we auto-pop.
2976   */
2977  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2978               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2979  return code;
2980 }
2981
2982 SSize_t
2983 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2984 {
2985  SSize_t avail = PerlIO_get_cnt(f);
2986  SSize_t got   = 0;
2987  if (count < avail)
2988   avail = count;
2989  if (avail > 0)
2990   got = PerlIOBuf_read(f,vbuf,avail);
2991  if (got >= 0 && got < count)
2992   {
2993    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2994    if (more >= 0 || got == 0)
2995     got += more;
2996   }
2997  return got;
2998 }
2999
3000 PerlIO_funcs PerlIO_pending = {
3001  "pending",
3002  sizeof(PerlIOBuf),
3003  PERLIO_K_BUFFERED,
3004  PerlIOPending_pushed,
3005  PerlIOBase_noop_ok,
3006  NULL,
3007  NULL,
3008  PerlIOBase_fileno,
3009  PerlIOPending_read,
3010  PerlIOBuf_unread,
3011  PerlIOBuf_write,
3012  PerlIOPending_seek,
3013  PerlIOBuf_tell,
3014  PerlIOPending_close,
3015  PerlIOPending_flush,
3016  PerlIOPending_fill,
3017  PerlIOBase_eof,
3018  PerlIOBase_error,
3019  PerlIOBase_clearerr,
3020  PerlIOBase_setlinebuf,
3021  PerlIOBuf_get_base,
3022  PerlIOBuf_bufsiz,
3023  PerlIOBuf_get_ptr,
3024  PerlIOBuf_get_cnt,
3025  PerlIOPending_set_ptrcnt,
3026 };
3027
3028
3029
3030 /*--------------------------------------------------------------------------------------*/
3031 /* crlf - translation
3032    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3033    to hand back a line at a time and keeping a record of which nl we "lied" about.
3034    On write translate "\n" to CR,LF
3035  */
3036
3037 typedef struct
3038 {
3039  PerlIOBuf      base;         /* PerlIOBuf stuff */
3040  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
3041 } PerlIOCrlf;
3042
3043 IV
3044 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3045 {
3046  IV code;
3047  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3048  code = PerlIOBuf_pushed(f,mode,arg);
3049 #if 0
3050  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3051               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3052               PerlIOBase(f)->flags);
3053 #endif
3054  return code;
3055 }
3056
3057
3058 SSize_t
3059 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3060 {
3061  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3062  if (c->nl)
3063   {
3064    *(c->nl) = 0xd;
3065    c->nl = NULL;
3066   }
3067  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3068   return PerlIOBuf_unread(f,vbuf,count);
3069  else
3070   {
3071    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3072    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3073    SSize_t unread = 0;
3074    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3075     PerlIO_flush(f);
3076    if (!b->buf)
3077     PerlIO_get_base(f);
3078    if (b->buf)
3079     {
3080      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3081       {
3082        b->end = b->ptr = b->buf + b->bufsiz;
3083        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3084        b->posn -= b->bufsiz;
3085       }
3086      while (count > 0 && b->ptr > b->buf)
3087       {
3088        int ch = *--buf;
3089        if (ch == '\n')
3090         {
3091          if (b->ptr - 2 >= b->buf)
3092           {
3093            *--(b->ptr) = 0xa;
3094            *--(b->ptr) = 0xd;
3095            unread++;
3096            count--;
3097           }
3098          else
3099           {
3100            buf++;
3101            break;
3102           }
3103         }
3104        else
3105         {
3106          *--(b->ptr) = ch;
3107          unread++;
3108          count--;
3109         }
3110       }
3111     }
3112    return unread;
3113   }
3114 }
3115
3116 SSize_t
3117 PerlIOCrlf_get_cnt(PerlIO *f)
3118 {
3119  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3120  if (!b->buf)
3121   PerlIO_get_base(f);
3122  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3123   {
3124    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3125    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3126     {
3127      STDCHAR *nl   = b->ptr;
3128     scan:
3129      while (nl < b->end && *nl != 0xd)
3130       nl++;
3131      if (nl < b->end && *nl == 0xd)
3132       {
3133      test:
3134        if (nl+1 < b->end)
3135         {
3136          if (nl[1] == 0xa)
3137           {
3138            *nl   = '\n';
3139            c->nl = nl;
3140           }
3141          else
3142           {
3143            /* Not CR,LF but just CR */
3144            nl++;
3145            goto scan;
3146           }
3147         }
3148        else
3149         {
3150          /* Blast - found CR as last char in buffer */
3151          if (b->ptr < nl)
3152           {
3153            /* They may not care, defer work as long as possible */
3154            return (nl - b->ptr);
3155           }
3156          else
3157           {
3158            int code;
3159            b->ptr++;               /* say we have read it as far as flush() is concerned */
3160            b->buf++;               /* Leave space an front of buffer */
3161            b->bufsiz--;            /* Buffer is thus smaller */
3162            code = PerlIO_fill(f);  /* Fetch some more */
3163            b->bufsiz++;            /* Restore size for next time */
3164            b->buf--;               /* Point at space */
3165            b->ptr = nl = b->buf;   /* Which is what we hand off */
3166            b->posn--;              /* Buffer starts here */
3167            *nl = 0xd;              /* Fill in the CR */
3168            if (code == 0)
3169             goto test;             /* fill() call worked */
3170            /* CR at EOF - just fall through */
3171           }
3172         }
3173       }
3174     }
3175    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3176   }
3177  return 0;
3178 }
3179
3180 void
3181 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3182 {
3183  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
3184  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3185  IV flags = PerlIOBase(f)->flags;
3186  if (!b->buf)
3187   PerlIO_get_base(f);
3188  if (!ptr)
3189   {
3190    if (c->nl)
3191     ptr = c->nl+1;
3192    else
3193     {
3194      ptr = b->end;
3195      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3196       ptr--;
3197     }
3198    ptr -= cnt;
3199   }
3200  else
3201   {
3202    /* Test code - delete when it works ... */
3203    STDCHAR *chk;
3204    if (c->nl)
3205     chk = c->nl+1;
3206    else
3207     {
3208      chk = b->end;
3209      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3210       chk--;
3211     }
3212    chk -= cnt;
3213
3214    if (ptr != chk)
3215     {
3216      dTHX;
3217      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3218                 ptr, chk, flags, c->nl, b->end, cnt);
3219     }
3220   }
3221  if (c->nl)
3222   {
3223    if (ptr > c->nl)
3224     {
3225      /* They have taken what we lied about */
3226      *(c->nl) = 0xd;
3227      c->nl = NULL;
3228      ptr++;
3229     }
3230   }
3231  b->ptr = ptr;
3232  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3233 }
3234
3235 SSize_t
3236 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3237 {
3238  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3239   return PerlIOBuf_write(f,vbuf,count);
3240  else
3241   {
3242    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3243    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3244    const STDCHAR *ebuf = buf+count;
3245    if (!b->buf)
3246     PerlIO_get_base(f);
3247    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3248     return 0;
3249    while (buf < ebuf)
3250     {
3251      STDCHAR *eptr = b->buf+b->bufsiz;
3252      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3253      while (buf < ebuf && b->ptr < eptr)
3254       {
3255        if (*buf == '\n')
3256         {
3257          if ((b->ptr + 2) > eptr)
3258           {
3259            /* Not room for both */
3260            PerlIO_flush(f);
3261            break;
3262           }
3263          else
3264           {
3265            *(b->ptr)++ = 0xd; /* CR */
3266            *(b->ptr)++ = 0xa; /* LF */
3267            buf++;
3268            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3269             {
3270              PerlIO_flush(f);
3271              break;
3272             }
3273           }
3274         }
3275        else
3276         {
3277          int ch = *buf++;
3278          *(b->ptr)++ = ch;
3279         }
3280        if (b->ptr >= eptr)
3281         {
3282          PerlIO_flush(f);
3283          break;
3284         }
3285       }
3286     }
3287    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3288     PerlIO_flush(f);
3289    return (buf - (STDCHAR *) vbuf);
3290   }
3291 }
3292
3293 IV
3294 PerlIOCrlf_flush(PerlIO *f)
3295 {
3296  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3297  if (c->nl)
3298   {
3299    *(c->nl) = 0xd;
3300    c->nl = NULL;
3301   }
3302  return PerlIOBuf_flush(f);
3303 }
3304
3305 PerlIO_funcs PerlIO_crlf = {
3306  "crlf",
3307  sizeof(PerlIOCrlf),
3308  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3309  PerlIOCrlf_pushed,
3310  PerlIOBase_noop_ok,   /* popped */
3311  PerlIOBuf_open,
3312  NULL,
3313  PerlIOBase_fileno,
3314  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3315  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3316  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3317  PerlIOBuf_seek,
3318  PerlIOBuf_tell,
3319  PerlIOBuf_close,
3320  PerlIOCrlf_flush,
3321  PerlIOBuf_fill,
3322  PerlIOBase_eof,
3323  PerlIOBase_error,
3324  PerlIOBase_clearerr,
3325  PerlIOBase_setlinebuf,
3326  PerlIOBuf_get_base,
3327  PerlIOBuf_bufsiz,
3328  PerlIOBuf_get_ptr,
3329  PerlIOCrlf_get_cnt,
3330  PerlIOCrlf_set_ptrcnt,
3331 };
3332
3333 #ifdef HAS_MMAP
3334 /*--------------------------------------------------------------------------------------*/
3335 /* mmap as "buffer" layer */
3336
3337 typedef struct
3338 {
3339  PerlIOBuf      base;         /* PerlIOBuf stuff */
3340  Mmap_t         mptr;        /* Mapped address */
3341  Size_t         len;          /* mapped length */
3342  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3343 } PerlIOMmap;
3344
3345 static size_t page_size = 0;
3346
3347 IV
3348 PerlIOMmap_map(PerlIO *f)
3349 {
3350  dTHX;
3351  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3352  IV flags = PerlIOBase(f)->flags;
3353  IV code  = 0;
3354  if (m->len)
3355   abort();
3356  if (flags & PERLIO_F_CANREAD)
3357   {
3358    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3359    int fd   = PerlIO_fileno(f);
3360    struct stat st;
3361    code = fstat(fd,&st);
3362    if (code == 0 && S_ISREG(st.st_mode))
3363     {
3364      SSize_t len = st.st_size - b->posn;
3365      if (len > 0)
3366       {
3367        Off_t posn;
3368        if (!page_size) {
3369 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3370            {
3371                SETERRNO(0,SS$_NORMAL);
3372 #   ifdef _SC_PAGESIZE
3373                page_size = sysconf(_SC_PAGESIZE);
3374 #   else
3375                page_size = sysconf(_SC_PAGE_SIZE);
3376 #   endif
3377                if ((long)page_size < 0) {
3378                    if (errno) {
3379                        SV *error = ERRSV;
3380                        char *msg;
3381                        STRLEN n_a;
3382                        (void)SvUPGRADE(error, SVt_PV);
3383                        msg = SvPVx(error, n_a);
3384                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3385                    }
3386                    else
3387                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3388                }
3389            }
3390 #else
3391 #   ifdef HAS_GETPAGESIZE
3392         page_size = getpagesize();
3393 #   else
3394 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3395         page_size = PAGESIZE; /* compiletime, bad */
3396 #       endif
3397 #   endif
3398 #endif
3399         if ((IV)page_size <= 0)
3400             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3401        }
3402        if (b->posn < 0)
3403         {
3404          /* This is a hack - should never happen - open should have set it ! */
3405          b->posn = PerlIO_tell(PerlIONext(f));
3406         }
3407        posn = (b->posn / page_size) * page_size;
3408        len  = st.st_size - posn;
3409        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3410        if (m->mptr && m->mptr != (Mmap_t) -1)
3411         {
3412 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3413          madvise(m->mptr, len, MADV_SEQUENTIAL);
3414 #endif
3415 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3416          madvise(m->mptr, len, MADV_WILLNEED);
3417 #endif
3418          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3419          b->end  = ((STDCHAR *)m->mptr) + len;
3420          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3421          b->ptr  = b->buf;
3422          m->len  = len;
3423         }
3424        else
3425         {
3426          b->buf = NULL;
3427         }
3428       }
3429      else
3430       {
3431        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3432        b->buf = NULL;
3433        b->ptr = b->end = b->ptr;
3434        code = -1;
3435       }
3436     }
3437   }
3438  return code;
3439 }
3440
3441 IV
3442 PerlIOMmap_unmap(PerlIO *f)
3443 {
3444  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3445  PerlIOBuf  *b = &m->base;
3446  IV code = 0;
3447  if (m->len)
3448   {
3449    if (b->buf)
3450     {
3451      code = munmap(m->mptr, m->len);
3452      b->buf  = NULL;
3453      m->len  = 0;
3454      m->mptr = NULL;
3455      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3456       code = -1;
3457     }
3458    b->ptr = b->end = b->buf;
3459    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3460   }
3461  return code;
3462 }
3463
3464 STDCHAR *
3465 PerlIOMmap_get_base(PerlIO *f)
3466 {
3467  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3468  PerlIOBuf  *b = &m->base;
3469  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3470   {
3471    /* Already have a readbuffer in progress */
3472    return b->buf;
3473   }
3474  if (b->buf)
3475   {
3476    /* We have a write buffer or flushed PerlIOBuf read buffer */
3477    m->bbuf = b->buf;  /* save it in case we need it again */
3478    b->buf  = NULL;    /* Clear to trigger below */
3479   }
3480  if (!b->buf)
3481   {
3482    PerlIOMmap_map(f);     /* Try and map it */
3483    if (!b->buf)
3484     {
3485      /* Map did not work - recover PerlIOBuf buffer if we have one */
3486      b->buf = m->bbuf;
3487     }
3488   }
3489  b->ptr  = b->end = b->buf;
3490  if (b->buf)
3491   return b->buf;
3492  return PerlIOBuf_get_base(f);
3493 }
3494
3495 SSize_t
3496 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3497 {
3498  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3499  PerlIOBuf  *b = &m->base;
3500  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3501   PerlIO_flush(f);
3502  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3503   {
3504    b->ptr -= count;
3505    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3506    return count;
3507   }
3508  if (m->len)
3509   {
3510    /* Loose the unwritable mapped buffer */
3511    PerlIO_flush(f);
3512    /* If flush took the "buffer" see if we have one from before */
3513    if (!b->buf && m->bbuf)
3514     b->buf = m->bbuf;
3515    if (!b->buf)
3516     {
3517      PerlIOBuf_get_base(f);
3518      m->bbuf = b->buf;
3519     }
3520   }
3521 return PerlIOBuf_unread(f,vbuf,count);
3522 }
3523
3524 SSize_t
3525 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3526 {
3527  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3528  PerlIOBuf  *b = &m->base;
3529  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3530   {
3531    /* No, or wrong sort of, buffer */
3532    if (m->len)
3533     {
3534      if (PerlIOMmap_unmap(f) != 0)
3535       return 0;
3536     }
3537    /* If unmap took the "buffer" see if we have one from before */
3538    if (!b->buf && m->bbuf)
3539     b->buf = m->bbuf;
3540    if (!b->buf)
3541     {
3542      PerlIOBuf_get_base(f);
3543      m->bbuf = b->buf;
3544     }
3545   }
3546  return PerlIOBuf_write(f,vbuf,count);
3547 }
3548
3549 IV
3550 PerlIOMmap_flush(PerlIO *f)
3551 {
3552  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3553  PerlIOBuf  *b = &m->base;
3554  IV code = PerlIOBuf_flush(f);
3555  /* Now we are "synced" at PerlIOBuf level */
3556  if (b->buf)
3557   {
3558    if (m->len)
3559     {
3560      /* Unmap the buffer */
3561      if (PerlIOMmap_unmap(f) != 0)
3562       code = -1;
3563     }
3564    else
3565     {
3566      /* We seem to have a PerlIOBuf buffer which was not mapped
3567       * remember it in case we need one later
3568       */
3569      m->bbuf = b->buf;
3570     }
3571   }
3572  return code;
3573 }
3574
3575 IV
3576 PerlIOMmap_fill(PerlIO *f)
3577 {
3578  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3579  IV code = PerlIO_flush(f);
3580  if (code == 0 && !b->buf)
3581   {
3582    code = PerlIOMmap_map(f);
3583   }
3584  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3585   {
3586    code = PerlIOBuf_fill(f);
3587   }
3588  return code;
3589 }
3590
3591 IV
3592 PerlIOMmap_close(PerlIO *f)
3593 {
3594  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3595  PerlIOBuf  *b = &m->base;
3596  IV code = PerlIO_flush(f);
3597  if (m->bbuf)
3598   {
3599    b->buf  = m->bbuf;
3600    m->bbuf = NULL;
3601    b->ptr  = b->end = b->buf;
3602   }
3603  if (PerlIOBuf_close(f) != 0)
3604   code = -1;
3605  return code;
3606 }
3607
3608
3609 PerlIO_funcs PerlIO_mmap = {
3610  "mmap",
3611  sizeof(PerlIOMmap),
3612  PERLIO_K_BUFFERED,
3613  PerlIOBuf_pushed,
3614  PerlIOBase_noop_ok,
3615  PerlIOBuf_open,
3616  NULL,
3617  PerlIOBase_fileno,
3618  PerlIOBuf_read,
3619  PerlIOMmap_unread,
3620  PerlIOMmap_write,
3621  PerlIOBuf_seek,
3622  PerlIOBuf_tell,
3623  PerlIOBuf_close,
3624  PerlIOMmap_flush,
3625  PerlIOMmap_fill,
3626  PerlIOBase_eof,
3627  PerlIOBase_error,
3628  PerlIOBase_clearerr,
3629  PerlIOBase_setlinebuf,
3630  PerlIOMmap_get_base,
3631  PerlIOBuf_bufsiz,
3632  PerlIOBuf_get_ptr,
3633  PerlIOBuf_get_cnt,
3634  PerlIOBuf_set_ptrcnt,
3635 };
3636
3637 #endif /* HAS_MMAP */
3638
3639 void
3640 PerlIO_init(void)
3641 {
3642  dTHX;
3643 #ifndef WIN32
3644  call_atexit(PerlIO_cleanup_layers, NULL);
3645 #endif
3646  if (!_perlio)
3647   {
3648 #ifndef WIN32
3649    atexit(&PerlIO_cleanup);
3650 #endif
3651   }
3652 }
3653
3654 #undef PerlIO_stdin
3655 PerlIO *
3656 PerlIO_stdin(void)
3657 {
3658  if (!_perlio)
3659   {
3660    dTHX;
3661    PerlIO_stdstreams(aTHX);
3662   }
3663  return &_perlio[1];
3664 }
3665
3666 #undef PerlIO_stdout
3667 PerlIO *
3668 PerlIO_stdout(void)
3669 {
3670  if (!_perlio)
3671   {
3672    dTHX;
3673    PerlIO_stdstreams(aTHX);
3674   }
3675  return &_perlio[2];
3676 }
3677
3678 #undef PerlIO_stderr
3679 PerlIO *
3680 PerlIO_stderr(void)
3681 {
3682  if (!_perlio)
3683   {
3684    dTHX;
3685    PerlIO_stdstreams(aTHX);
3686   }
3687  return &_perlio[3];
3688 }
3689
3690 /*--------------------------------------------------------------------------------------*/
3691
3692 #undef PerlIO_getname
3693 char *
3694 PerlIO_getname(PerlIO *f, char *buf)
3695 {
3696  dTHX;
3697  char *name = NULL;
3698 #ifdef VMS
3699  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3700  if (stdio) name = fgetname(stdio, buf);
3701 #else
3702  Perl_croak(aTHX_ "Don't know how to get file name");
3703 #endif
3704  return name;
3705 }
3706
3707
3708 /*--------------------------------------------------------------------------------------*/
3709 /* Functions which can be called on any kind of PerlIO implemented
3710    in terms of above
3711 */
3712
3713 #undef PerlIO_getc
3714 int
3715 PerlIO_getc(PerlIO *f)
3716 {
3717  STDCHAR buf[1];
3718  SSize_t count = PerlIO_read(f,buf,1);
3719  if (count == 1)
3720   {
3721    return (unsigned char) buf[0];
3722   }
3723  return EOF;
3724 }
3725
3726 #undef PerlIO_ungetc
3727 int
3728 PerlIO_ungetc(PerlIO *f, int ch)
3729 {
3730  if (ch != EOF)
3731   {
3732    STDCHAR buf = ch;
3733    if (PerlIO_unread(f,&buf,1) == 1)
3734     return ch;
3735   }
3736  return EOF;
3737 }
3738
3739 #undef PerlIO_putc
3740 int
3741 PerlIO_putc(PerlIO *f, int ch)
3742 {
3743  STDCHAR buf = ch;
3744  return PerlIO_write(f,&buf,1);
3745 }
3746
3747 #undef PerlIO_puts
3748 int
3749 PerlIO_puts(PerlIO *f, const char *s)
3750 {
3751  STRLEN len = strlen(s);
3752  return PerlIO_write(f,s,len);
3753 }
3754
3755 #undef PerlIO_rewind
3756 void
3757 PerlIO_rewind(PerlIO *f)
3758 {
3759  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3760  PerlIO_clearerr(f);
3761 }
3762
3763 #undef PerlIO_vprintf
3764 int
3765 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3766 {
3767  dTHX;
3768  SV *sv = newSVpvn("",0);
3769  char *s;
3770  STRLEN len;
3771  SSize_t wrote;
3772 #ifdef NEED_VA_COPY
3773  va_list apc;
3774  Perl_va_copy(ap, apc);
3775  sv_vcatpvf(sv, fmt, &apc);
3776 #else
3777  sv_vcatpvf(sv, fmt, &ap);
3778 #endif
3779  s = SvPV(sv,len);
3780  wrote = PerlIO_write(f,s,len);
3781  SvREFCNT_dec(sv);
3782  return wrote;
3783 }
3784
3785 #undef PerlIO_printf
3786 int
3787 PerlIO_printf(PerlIO *f,const char *fmt,...)
3788 {
3789  va_list ap;
3790  int result;
3791  va_start(ap,fmt);
3792  result = PerlIO_vprintf(f,fmt,ap);
3793  va_end(ap);
3794  return result;
3795 }
3796
3797 #undef PerlIO_stdoutf
3798 int
3799 PerlIO_stdoutf(const char *fmt,...)
3800 {
3801  va_list ap;
3802  int result;
3803  va_start(ap,fmt);
3804  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3805  va_end(ap);
3806  return result;
3807 }
3808
3809 #undef PerlIO_tmpfile
3810 PerlIO *
3811 PerlIO_tmpfile(void)
3812 {
3813  /* I have no idea how portable mkstemp() is ... */
3814 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3815  dTHX;
3816  PerlIO *f = NULL;
3817  FILE *stdio = PerlSIO_tmpfile();
3818  if (stdio)
3819   {
3820    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3821    s->stdio  = stdio;
3822   }
3823  return f;
3824 #else
3825  dTHX;
3826  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3827  int fd = mkstemp(SvPVX(sv));
3828  PerlIO *f = NULL;
3829  if (fd >= 0)
3830   {
3831    f = PerlIO_fdopen(fd,"w+");
3832    if (f)
3833     {
3834      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3835     }
3836    PerlLIO_unlink(SvPVX(sv));
3837    SvREFCNT_dec(sv);
3838   }
3839  return f;
3840 #endif
3841 }
3842
3843 #undef HAS_FSETPOS
3844 #undef HAS_FGETPOS
3845
3846 #endif /* USE_SFIO */
3847 #endif /* PERLIO_IS_STDIO */
3848
3849 /*======================================================================================*/
3850 /* Now some functions in terms of above which may be needed even if
3851    we are not in true PerlIO mode
3852  */
3853
3854 #ifndef HAS_FSETPOS
3855 #undef PerlIO_setpos
3856 int
3857 PerlIO_setpos(PerlIO *f, SV *pos)
3858 {
3859  dTHX;
3860  if (SvOK(pos))
3861   {
3862    STRLEN len;
3863    Off_t *posn = (Off_t *) SvPV(pos,len);
3864    if (f && len == sizeof(Off_t))
3865     return PerlIO_seek(f,*posn,SEEK_SET);
3866   }
3867  SETERRNO(EINVAL,SS$_IVCHAN);
3868  return -1;
3869 }
3870 #else
3871 #undef PerlIO_setpos
3872 int
3873 PerlIO_setpos(PerlIO *f, SV *pos)
3874 {
3875  dTHX;
3876  if (SvOK(pos))
3877   {
3878    STRLEN len;
3879    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3880    if (f && len == sizeof(Fpos_t))
3881     {
3882 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3883      return fsetpos64(f, fpos);
3884 #else
3885      return fsetpos(f, fpos);
3886 #endif
3887     }
3888   }
3889  SETERRNO(EINVAL,SS$_IVCHAN);
3890  return -1;
3891 }
3892 #endif
3893
3894 #ifndef HAS_FGETPOS
3895 #undef PerlIO_getpos
3896 int
3897 PerlIO_getpos(PerlIO *f, SV *pos)
3898 {
3899  dTHX;
3900  Off_t posn = PerlIO_tell(f);
3901  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3902  return (posn == (Off_t)-1) ? -1 : 0;
3903 }
3904 #else
3905 #undef PerlIO_getpos
3906 int
3907 PerlIO_getpos(PerlIO *f, SV *pos)
3908 {
3909  dTHX;
3910  Fpos_t fpos;
3911  int code;
3912 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3913  code = fgetpos64(f, &fpos);
3914 #else
3915  code = fgetpos(f, &fpos);
3916 #endif
3917  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3918  return code;
3919 }
3920 #endif
3921
3922 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3923
3924 int
3925 vprintf(char *pat, char *args)
3926 {
3927     _doprnt(pat, args, stdout);
3928     return 0;           /* wrong, but perl doesn't use the return value */
3929 }
3930
3931 int
3932 vfprintf(FILE *fd, char *pat, char *args)
3933 {
3934     _doprnt(pat, args, fd);
3935     return 0;           /* wrong, but perl doesn't use the return value */
3936 }
3937
3938 #endif
3939
3940 #ifndef PerlIO_vsprintf
3941 int
3942 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3943 {
3944  int val = vsprintf(s, fmt, ap);
3945  if (n >= 0)
3946   {
3947    if (strlen(s) >= (STRLEN)n)
3948     {
3949      dTHX;
3950      (void)PerlIO_puts(Perl_error_log,
3951                        "panic: sprintf overflow - memory corrupted!\n");
3952      my_exit(1);
3953     }
3954   }
3955  return val;
3956 }
3957 #endif
3958
3959 #ifndef PerlIO_sprintf
3960 int
3961 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3962 {
3963  va_list ap;
3964  int result;
3965  va_start(ap,fmt);
3966  result = PerlIO_vsprintf(s, n, fmt, ap);
3967  va_end(ap);
3968  return result;
3969 }
3970 #endif
3971
3972
3973
3974
3975