perlio.c

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