perlio.c

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