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