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