perlio.c

   1 /*
   2  * perlio.c
   3  * Copyright (c) 1996-2006, Nick Ing-Simmons
   4  * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
   5  *
   6  * You may distribute under the terms of either the GNU General Public License
   7  * or the Artistic License, as specified in the README file.
   8  */
   9
  10 /*
  11  * Hour after hour for nearly three weary days he had jogged up and down,
  12  * over passes, and through long dales, and across many streams.
  13  *
  14  *     [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
  15  */
  16
  17 /* This file contains the functions needed to implement PerlIO, which
  18  * is Perl's private replacement for the C stdio library. This is used
  19  * by default unless you compile with -Uuseperlio or run with
  20  * PERLIO=:stdio (but don't do this unless you know what you're doing)
  21  */
  22
  23 /*
  24  * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
  25  * at the dispatch tables, even when we do not need it for other reasons.
  26  * Invent a dSYS macro to abstract this out
  27  */
  28 #ifdef PERL_IMPLICIT_SYS
  29 #define dSYS dTHX
  30 #else
  31 #define dSYS dNOOP
  32 #endif
  33
  34 #define VOIDUSED 1
  35 #ifdef PERL_MICRO
  36 #   include "uconfig.h"
  37 #else
  38 #   ifndef USE_CROSS_COMPILE
  39 #       include "config.h"
  40 #   else
  41 #       include "xconfig.h"
  42 #   endif
  43 #endif
  44
  45 #define PERLIO_NOT_STDIO 0
  46 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  47 /*
  48  * #define PerlIO FILE
  49  */
  50 #endif
  51 /*
  52  * This file provides those parts of PerlIO abstraction
  53  * which are not #defined in perlio.h.
  54  * Which these are depends on various Configure #ifdef's
  55  */
  56
  57 #include "EXTERN.h"
  58 #define PERL_IN_PERLIO_C
  59 #include "perl.h"
  60
  61 #ifdef PERL_IMPLICIT_CONTEXT
  62 #undef dSYS
  63 #define dSYS dTHX
  64 #endif
  65
  66 #include "XSUB.h"
  67
  68 #ifdef __Lynx__
  69 /* Missing proto on LynxOS */
  70 int mkstemp(char*);
  71 #endif
  72
  73 #ifdef VMS
  74 #include <rms.h>
  75 #endif
  76
  77 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
  78
  79 /* Call the callback or PerlIOBase, and return failure. */
  80 #define Perl_PerlIO_or_Base(f, callback, base, failure, args)   \
  81         if (PerlIOValid(f)) {                                   \
  82                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
  83                 if (tab && tab->callback)                       \
  84                         return (*tab->callback) args;           \
  85                 else                                            \
  86                         return PerlIOBase_ ## base args;        \
  87         }                                                       \
  88         else                                                    \
  89                 SETERRNO(EBADF, SS_IVCHAN);                     \
  90         return failure
  91
  92 /* Call the callback or fail, and return failure. */
  93 #define Perl_PerlIO_or_fail(f, callback, failure, args)         \
  94         if (PerlIOValid(f)) {                                   \
  95                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
  96                 if (tab && tab->callback)                       \
  97                         return (*tab->callback) args;           \
  98                 SETERRNO(EINVAL, LIB_INVARG);                   \
  99         }                                                       \
 100         else                                                    \
 101                 SETERRNO(EBADF, SS_IVCHAN);                     \
 102         return failure
 103
 104 /* Call the callback or PerlIOBase, and be void. */
 105 #define Perl_PerlIO_or_Base_void(f, callback, base, args)       \
 106         if (PerlIOValid(f)) {                                   \
 107                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
 108                 if (tab && tab->callback)                       \
 109                         (*tab->callback) args;                  \
 110                 else                                            \
 111                         PerlIOBase_ ## base args;               \
 112         }                                                       \
 113         else                                                    \
 114                 SETERRNO(EBADF, SS_IVCHAN)
 115
 116 /* Call the callback or fail, and be void. */
 117 #define Perl_PerlIO_or_fail_void(f, callback, args)             \
 118         if (PerlIOValid(f)) {                                   \
 119                 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
 120                 if (tab && tab->callback)                       \
 121                         (*tab->callback) args;                  \
 122                 else                                            \
 123                         SETERRNO(EINVAL, LIB_INVARG);           \
 124         }                                                       \
 125         else                                                    \
 126                 SETERRNO(EBADF, SS_IVCHAN)
 127
 128 #if defined(__osf__) && _XOPEN_SOURCE < 500
 129 extern int   fseeko(FILE *, off_t, int);
 130 extern off_t ftello(FILE *);
 131 #endif
 132
 133 #define NATIVE_0xd  CR_NATIVE
 134 #define NATIVE_0xa  LF_NATIVE
 135
 136 #ifndef USE_SFIO
 137
 138 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
 139
 140 int
 141 perlsio_binmode(FILE *fp, int iotype, int mode)
 142 {
 143     /*
 144      * This used to be contents of do_binmode in doio.c
 145      */
 146 #ifdef DOSISH
 147     dTHX;
 148     PERL_UNUSED_ARG(iotype);
 149 #ifdef NETWARE
 150     if (PerlLIO_setmode(fp, mode) != -1) {
 151 #else
 152     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
 153 #endif
 154         return 1;
 155     }
 156     else
 157         return 0;
 158 #else
 159 #  if defined(USEMYBINMODE)
 160     dTHX;
 161 #    if defined(__CYGWIN__)
 162     PERL_UNUSED_ARG(iotype);
 163 #    endif
 164     if (my_binmode(fp, iotype, mode) != FALSE)
 165         return 1;
 166     else
 167         return 0;
 168 #  else
 169     PERL_UNUSED_ARG(fp);
 170     PERL_UNUSED_ARG(iotype);
 171     PERL_UNUSED_ARG(mode);
 172     return 1;
 173 #  endif
 174 #endif
 175 }
 176 #endif /* sfio */
 177
 178 #ifndef O_ACCMODE
 179 #define O_ACCMODE 3             /* Assume traditional implementation */
 180 #endif
 181
 182 int
 183 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
 184 {
 185     const int result = rawmode & O_ACCMODE;
 186     int ix = 0;
 187     int ptype;
 188     switch (result) {
 189     case O_RDONLY:
 190         ptype = IoTYPE_RDONLY;
 191         break;
 192     case O_WRONLY:
 193         ptype = IoTYPE_WRONLY;
 194         break;
 195     case O_RDWR:
 196     default:
 197         ptype = IoTYPE_RDWR;
 198         break;
 199     }
 200     if (writing)
 201         *writing = (result != O_RDONLY);
 202
 203     if (result == O_RDONLY) {
 204         mode[ix++] = 'r';
 205     }
 206 #ifdef O_APPEND
 207     else if (rawmode & O_APPEND) {
 208         mode[ix++] = 'a';
 209         if (result != O_WRONLY)
 210             mode[ix++] = '+';
 211     }
 212 #endif
 213     else {
 214         if (result == O_WRONLY)
 215             mode[ix++] = 'w';
 216         else {
 217             mode[ix++] = 'r';
 218             mode[ix++] = '+';
 219         }
 220     }
 221     if (rawmode & O_BINARY)
 222         mode[ix++] = 'b';
 223     mode[ix] = '\0';
 224     return ptype;
 225 }
 226
 227 #ifndef PERLIO_LAYERS
 228 int
 229 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 230 {
 231     if (!names || !*names
 232         || strEQ(names, ":crlf")
 233         || strEQ(names, ":raw")
 234         || strEQ(names, ":bytes")
 235        ) {
 236         return 0;
 237     }
 238     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
 239     /*
 240      * NOTREACHED
 241      */
 242     return -1;
 243 }
 244
 245 void
 246 PerlIO_destruct(pTHX)
 247 {
 248 }
 249
 250 int
 251 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 252 {
 253 #ifdef USE_SFIO
 254     PERL_UNUSED_ARG(iotype);
 255     PERL_UNUSED_ARG(mode);
 256     PERL_UNUSED_ARG(names);
 257     return 1;
 258 #else
 259     return perlsio_binmode(fp, iotype, mode);
 260 #endif
 261 }
 262
 263 PerlIO *
 264 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 265 {
 266 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
 267     return NULL;
 268 #else
 269 #ifdef PERL_IMPLICIT_SYS
 270     return PerlSIO_fdupopen(f);
 271 #else
 272 #ifdef WIN32
 273     return win32_fdupopen(f);
 274 #else
 275     if (f) {
 276         const int fd = PerlLIO_dup(PerlIO_fileno(f));
 277         if (fd >= 0) {
 278             char mode[8];
 279 #ifdef DJGPP
 280             const int omode = djgpp_get_stream_mode(f);
 281 #else
 282             const int omode = fcntl(fd, F_GETFL);
 283 #endif
 284             PerlIO_intmode2str(omode,mode,NULL);
 285             /* the r+ is a hack */
 286             return PerlIO_fdopen(fd, mode);
 287         }
 288         return NULL;
 289     }
 290     else {
 291         SETERRNO(EBADF, SS_IVCHAN);
 292     }
 293 #endif
 294     return NULL;
 295 #endif
 296 #endif
 297 }
 298
 299
 300 /*
 301  * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
 302  */
 303
 304 PerlIO *
 305 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 306              int imode, int perm, PerlIO *old, int narg, SV **args)
 307 {
 308     if (narg) {
 309         if (narg > 1) {
 310             Perl_croak(aTHX_ "More than one argument to open");
 311         }
 312         if (*args == &PL_sv_undef)
 313             return PerlIO_tmpfile();
 314         else {
 315             const char *name = SvPV_nolen_const(*args);
 316             if (!IS_SAFE_PATHNAME(*args, "open"))
 317                 return NULL;
 318
 319             if (*mode == IoTYPE_NUMERIC) {
 320                 fd = PerlLIO_open3(name, imode, perm);
 321                 if (fd >= 0)
 322                     return PerlIO_fdopen(fd, mode + 1);
 323             }
 324             else if (old) {
 325                 return PerlIO_reopen(name, mode, old);
 326             }
 327             else {
 328                 return PerlIO_open(name, mode);
 329             }
 330         }
 331     }
 332     else {
 333         return PerlIO_fdopen(fd, (char *) mode);
 334     }
 335     return NULL;
 336 }
 337
 338 XS(XS_PerlIO__Layer__find)
 339 {
 340     dXSARGS;
 341     if (items < 2)
 342         Perl_croak(aTHX_ "Usage class->find(name[,load])");
 343     else {
 344         const char * const name = SvPV_nolen_const(ST(1));
 345         ST(0) = (strEQ(name, "crlf")
 346                  || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
 347         XSRETURN(1);
 348     }
 349 }
 350
 351
 352 void
 353 Perl_boot_core_PerlIO(pTHX)
 354 {
 355     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
 356 }
 357
 358 #endif
 359
 360
 361 #ifdef PERLIO_IS_STDIO
 362
 363 void
 364 PerlIO_init(pTHX)
 365 {
 366     PERL_UNUSED_CONTEXT;
 367     /*
 368      * Does nothing (yet) except force this file to be included in perl
 369      * binary. That allows this file to force inclusion of other functions
 370      * that may be required by loadable extensions e.g. for
 371      * FileHandle::tmpfile
 372      */
 373 }
 374
 375 #undef PerlIO_tmpfile
 376 PerlIO *
 377 PerlIO_tmpfile(void)
 378 {
 379     return tmpfile();
 380 }
 381
 382 #else                           /* PERLIO_IS_STDIO */
 383
 384 #ifdef USE_SFIO
 385
 386 #undef HAS_FSETPOS
 387 #undef HAS_FGETPOS
 388
 389 /*
 390  * This section is just to make sure these functions get pulled in from
 391  * libsfio.a
 392  */
 393
 394 #undef PerlIO_tmpfile
 395 PerlIO *
 396 PerlIO_tmpfile(void)
 397 {
 398     return sftmp(0);
 399 }
 400
 401 void
 402 PerlIO_init(pTHX)
 403 {
 404     PERL_UNUSED_CONTEXT;
 405     /*
 406      * Force this file to be included in perl binary. Which allows this
 407      * file to force inclusion of other functions that may be required by
 408      * loadable extensions e.g. for FileHandle::tmpfile
 409      */
 410
 411     /*
 412      * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
 413      * results in a lot of lseek()s to regular files and lot of small
 414      * writes to pipes.
 415      */
 416     sfset(sfstdout, SF_SHARE, 0);
 417 }
 418
 419 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
 420 PerlIO *
 421 PerlIO_importFILE(FILE *stdio, const char *mode)
 422 {
 423     const int fd = fileno(stdio);
 424     if (!mode || !*mode) {
 425         mode = "r+";
 426     }
 427     return PerlIO_fdopen(fd, mode);
 428 }
 429
 430 FILE *
 431 PerlIO_findFILE(PerlIO *pio)
 432 {
 433     const int fd = PerlIO_fileno(pio);
 434     FILE * const f = fdopen(fd, "r+");
 435     PerlIO_flush(pio);
 436     if (!f && errno == EINVAL)
 437         f = fdopen(fd, "w");
 438     if (!f && errno == EINVAL)
 439         f = fdopen(fd, "r");
 440     return f;
 441 }
 442
 443
 444 #else                           /* USE_SFIO */
 445 /*======================================================================================*/
 446 /*
 447  * Implement all the PerlIO interface ourselves.
 448  */
 449
 450 #include "perliol.h"
 451
 452 void
 453 PerlIO_debug(const char *fmt, ...)
 454 {
 455     va_list ap;
 456     dSYS;
 457     va_start(ap, fmt);
 458     if (!PL_perlio_debug_fd) {
 459         if (!TAINTING_get &&
 460             PerlProc_getuid() == PerlProc_geteuid() &&
 461             PerlProc_getgid() == PerlProc_getegid()) {
 462             const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
 463             if (s && *s)
 464                 PL_perlio_debug_fd
 465                     = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
 466             else
 467                 PL_perlio_debug_fd = -1;
 468         } else {
 469             /* tainting or set*id, so ignore the environment, and ensure we
 470                skip these tests next time through.  */
 471             PL_perlio_debug_fd = -1;
 472         }
 473     }
 474     if (PL_perlio_debug_fd > 0) {
 475 #ifdef USE_ITHREADS
 476         const char * const s = CopFILE(PL_curcop);
 477         /* Use fixed buffer as sv_catpvf etc. needs SVs */
 478         char buffer[1024];
 479         const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
 480         const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
 481         PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
 482 #else
 483         const char *s = CopFILE(PL_curcop);
 484         STRLEN len;
 485         SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
 486                                       (IV) CopLINE(PL_curcop));
 487         Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 488
 489         s = SvPV_const(sv, len);
 490         PerlLIO_write(PL_perlio_debug_fd, s, len);
 491         SvREFCNT_dec(sv);
 492 #endif
 493     }
 494     va_end(ap);
 495 }
 496
 497 /*--------------------------------------------------------------------------------------*/
 498
 499 /*
 500  * Inner level routines
 501  */
 502
 503 /* check that the head field of each layer points back to the head */
 504
 505 #ifdef DEBUGGING
 506 #  define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
 507 static void
 508 PerlIO_verify_head(pTHX_ PerlIO *f)
 509 {
 510     PerlIOl *head, *p;
 511     int seen = 0;
 512     if (!PerlIOValid(f))
 513         return;
 514     p = head = PerlIOBase(f)->head;
 515     assert(p);
 516     do {
 517         assert(p->head == head);
 518         if (p == (PerlIOl*)f)
 519             seen = 1;
 520         p = p->next;
 521     } while (p);
 522     assert(seen);
 523 }
 524 #else
 525 #  define VERIFY_HEAD(f)
 526 #endif
 527
 528
 529 /*
 530  * Table of pointers to the PerlIO structs (malloc'ed)
 531  */
 532 #define PERLIO_TABLE_SIZE 64
 533
 534 static void
 535 PerlIO_init_table(pTHX)
 536 {
 537     if (PL_perlio)
 538         return;
 539     Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
 540 }
 541
 542
 543
 544 PerlIO *
 545 PerlIO_allocate(pTHX)
 546 {
 547     dVAR;
 548     /*
 549      * Find a free slot in the table, allocating new table as necessary
 550      */
 551     PerlIOl **last;
 552     PerlIOl *f;
 553     last = &PL_perlio;
 554     while ((f = *last)) {
 555         int i;
 556         last = (PerlIOl **) (f);
 557         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 558             if (!((++f)->next)) {
 559                 f->flags = 0; /* lockcnt */
 560                 f->tab = NULL;
 561                 f->head = f;
 562                 return (PerlIO *)f;
 563             }
 564         }
 565     }
 566     Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
 567     if (!f) {
 568         return NULL;
 569     }
 570     *last = (PerlIOl*) f++;
 571     f->flags = 0; /* lockcnt */
 572     f->tab = NULL;
 573     f->head = f;
 574     return (PerlIO*) f;
 575 }
 576
 577 #undef PerlIO_fdupopen
 578 PerlIO *
 579 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 580 {
 581     if (PerlIOValid(f)) {
 582         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
 583         PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
 584         if (tab && tab->Dup)
 585              return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
 586         else {
 587              return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
 588         }
 589     }
 590     else
 591          SETERRNO(EBADF, SS_IVCHAN);
 592
 593     return NULL;
 594 }
 595
 596 void
 597 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
 598 {
 599     PerlIOl * const table = *tablep;
 600     if (table) {
 601         int i;
 602         PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
 603         for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
 604             PerlIOl * const f = table + i;
 605             if (f->next) {
 606                 PerlIO_close(&(f->next));
 607             }
 608         }
 609         Safefree(table);
 610         *tablep = NULL;
 611     }
 612 }
 613
 614
 615 PerlIO_list_t *
 616 PerlIO_list_alloc(pTHX)
 617 {
 618     PerlIO_list_t *list;
 619     PERL_UNUSED_CONTEXT;
 620     Newxz(list, 1, PerlIO_list_t);
 621     list->refcnt = 1;
 622     return list;
 623 }
 624
 625 void
 626 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 627 {
 628     if (list) {
 629         if (--list->refcnt == 0) {
 630             if (list->array) {
 631                 IV i;
 632                 for (i = 0; i < list->cur; i++)
 633                     SvREFCNT_dec(list->array[i].arg);
 634                 Safefree(list->array);
 635             }
 636             Safefree(list);
 637         }
 638     }
 639 }
 640
 641 void
 642 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
 643 {
 644     dVAR;
 645     PerlIO_pair_t *p;
 646     PERL_UNUSED_CONTEXT;
 647
 648     if (list->cur >= list->len) {
 649         list->len += 8;
 650         if (list->array)
 651             Renew(list->array, list->len, PerlIO_pair_t);
 652         else
 653             Newx(list->array, list->len, PerlIO_pair_t);
 654     }
 655     p = &(list->array[list->cur++]);
 656     p->funcs = funcs;
 657     if ((p->arg = arg)) {
 658         SvREFCNT_inc_simple_void_NN(arg);
 659     }
 660 }
 661
 662 PerlIO_list_t *
 663 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
 664 {
 665     PerlIO_list_t *list = NULL;
 666     if (proto) {
 667         int i;
 668         list = PerlIO_list_alloc(aTHX);
 669         for (i=0; i < proto->cur; i++) {
 670             SV *arg = proto->array[i].arg;
 671 #ifdef sv_dup
 672             if (arg && param)
 673                 arg = sv_dup(arg, param);
 674 #else
 675             PERL_UNUSED_ARG(param);
 676 #endif
 677             PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
 678         }
 679     }
 680     return list;
 681 }
 682
 683 void
 684 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 685 {
 686 #ifdef USE_ITHREADS
 687     PerlIOl **table = &proto->Iperlio;
 688     PerlIOl *f;
 689     PL_perlio = NULL;
 690     PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
 691     PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
 692     PerlIO_init_table(aTHX);
 693     PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
 694     while ((f = *table)) {
 695             int i;
 696             table = (PerlIOl **) (f++);
 697             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 698                 if (f->next) {
 699                     (void) fp_dup(&(f->next), 0, param);
 700                 }
 701                 f++;
 702             }
 703         }
 704 #else
 705     PERL_UNUSED_CONTEXT;
 706     PERL_UNUSED_ARG(proto);
 707     PERL_UNUSED_ARG(param);
 708 #endif
 709 }
 710
 711 void
 712 PerlIO_destruct(pTHX)
 713 {
 714     dVAR;
 715     PerlIOl **table = &PL_perlio;
 716     PerlIOl *f;
 717 #ifdef USE_ITHREADS
 718     PerlIO_debug("Destruct %p\n",(void*)aTHX);
 719 #endif
 720     while ((f = *table)) {
 721         int i;
 722         table = (PerlIOl **) (f++);
 723         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
 724             PerlIO *x = &(f->next);
 725             const PerlIOl *l;
 726             while ((l = *x)) {
 727                 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
 728                     PerlIO_debug("Destruct popping %s\n", l->tab->name);
 729                     PerlIO_flush(x);
 730                     PerlIO_pop(aTHX_ x);
 731                 }
 732                 else {
 733                     x = PerlIONext(x);
 734                 }
 735             }
 736             f++;
 737         }
 738     }
 739 }
 740
 741 void
 742 PerlIO_pop(pTHX_ PerlIO *f)
 743 {
 744     const PerlIOl *l = *f;
 745     VERIFY_HEAD(f);
 746     if (l) {
 747         PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
 748                             l->tab ? l->tab->name : "(Null)");
 749         if (l->tab && l->tab->Popped) {
 750             /*
 751              * If popped returns non-zero do not free its layer structure
 752              * it has either done so itself, or it is shared and still in
 753              * use
 754              */
 755             if ((*l->tab->Popped) (aTHX_ f) != 0)
 756                 return;
 757         }
 758         if (PerlIO_lockcnt(f)) {
 759             /* we're in use; defer freeing the structure */
 760             PerlIOBase(f)->flags = PERLIO_F_CLEARED;
 761             PerlIOBase(f)->tab = NULL;
 762         }
 763         else {
 764             *f = l->next;
 765             Safefree(l);
 766         }
 767
 768     }
 769 }
 770
 771 /* Return as an array the stack of layers on a filehandle.  Note that
 772  * the stack is returned top-first in the array, and there are three
 773  * times as many array elements as there are layers in the stack: the
 774  * first element of a layer triplet is the name, the second one is the
 775  * arguments, and the third one is the flags. */
 776
 777 AV *
 778 PerlIO_get_layers(pTHX_ PerlIO *f)
 779 {
 780     dVAR;
 781     AV * const av = newAV();
 782
 783     if (PerlIOValid(f)) {
 784         PerlIOl *l = PerlIOBase(f);
 785
 786         while (l) {
 787             /* There is some collusion in the implementation of
 788                XS_PerlIO_get_layers - it knows that name and flags are
 789                generated as fresh SVs here, and takes advantage of that to
 790                "copy" them by taking a reference. If it changes here, it needs
 791                to change there too.  */
 792             SV * const name = l->tab && l->tab->name ?
 793             newSVpv(l->tab->name, 0) : &PL_sv_undef;
 794             SV * const arg = l->tab && l->tab->Getarg ?
 795             (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
 796             av_push(av, name);
 797             av_push(av, arg);
 798             av_push(av, newSViv((IV)l->flags));
 799             l = l->next;
 800         }
 801     }
 802
 803     return av;
 804 }
 805
 806 /*--------------------------------------------------------------------------------------*/
 807 /*
 808  * XS Interface for perl code
 809  */
 810
 811 PerlIO_funcs *
 812 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 813 {
 814     dVAR;
 815     IV i;
 816     if ((SSize_t) len <= 0)
 817         len = strlen(name);
 818     for (i = 0; i < PL_known_layers->cur; i++) {
 819         PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
 820         const STRLEN this_len = strlen(f->name);
 821         if (this_len == len && memEQ(f->name, name, len)) {
 822             PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
 823             return f;
 824         }
 825     }
 826     if (load && PL_subname && PL_def_layerlist
 827         && PL_def_layerlist->cur >= 2) {
 828         if (PL_in_load_module) {
 829             Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
 830             return NULL;
 831         } else {
 832             SV * const pkgsv = newSVpvs("PerlIO");
 833             SV * const layer = newSVpvn(name, len);
 834             CV * const cv    = get_cvs("PerlIO::Layer::NoWarnings", 0);
 835             ENTER;
 836             SAVEBOOL(PL_in_load_module);
 837             if (cv) {
 838                 SAVEGENERICSV(PL_warnhook);
 839                 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
 840             }
 841             PL_in_load_module = TRUE;
 842             /*
 843              * The two SVs are magically freed by load_module
 844              */
 845             Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
 846             LEAVE;
 847             return PerlIO_find_layer(aTHX_ name, len, 0);
 848         }
 849     }
 850     PerlIO_debug("Cannot find %.*s\n", (int) len, name);
 851     return NULL;
 852 }
 853
 854 #ifdef USE_ATTRIBUTES_FOR_PERLIO
 855
 856 static int
 857 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 858 {
 859     if (SvROK(sv)) {
 860         IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
 861         PerlIO * const ifp = IoIFP(io);
 862         PerlIO * const ofp = IoOFP(io);
 863         Perl_warn(aTHX_ "set %" SVf " %p %p %p",
 864                   SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
 865     }
 866     return 0;
 867 }
 868
 869 static int
 870 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 871 {
 872     if (SvROK(sv)) {
 873         IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
 874         PerlIO * const ifp = IoIFP(io);
 875         PerlIO * const ofp = IoOFP(io);
 876         Perl_warn(aTHX_ "get %" SVf " %p %p %p",
 877                   SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
 878     }
 879     return 0;
 880 }
 881
 882 static int
 883 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 884 {
 885     Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
 886     return 0;
 887 }
 888
 889 static int
 890 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 891 {
 892     Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
 893     return 0;
 894 }
 895
 896 MGVTBL perlio_vtab = {
 897     perlio_mg_get,
 898     perlio_mg_set,
 899     NULL,                       /* len */
 900     perlio_mg_clear,
 901     perlio_mg_free
 902 };
 903
 904 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 905 {
 906     dXSARGS;
 907     SV * const sv = SvRV(ST(1));
 908     AV * const av = newAV();
 909     MAGIC *mg;
 910     int count = 0;
 911     int i;
 912     sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
 913     SvRMAGICAL_off(sv);
 914     mg = mg_find(sv, PERL_MAGIC_ext);
 915     mg->mg_virtual = &perlio_vtab;
 916     mg_magical(sv);
 917     Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
 918     for (i = 2; i < items; i++) {
 919         STRLEN len;
 920         const char * const name = SvPV_const(ST(i), len);
 921         SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
 922         if (layer) {
 923             av_push(av, SvREFCNT_inc_simple_NN(layer));
 924         }
 925         else {
 926             ST(count) = ST(i);
 927             count++;
 928         }
 929     }
 930     SvREFCNT_dec(av);
 931     XSRETURN(count);
 932 }
 933
 934 #endif                          /* USE_ATTIBUTES_FOR_PERLIO */
 935
 936 SV *
 937 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 938 {
 939     HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
 940     SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
 941     return sv;
 942 }
 943
 944 XS(XS_PerlIO__Layer__NoWarnings)
 945 {
 946     /* This is used as a %SIG{__WARN__} handler to suppress warnings
 947        during loading of layers.
 948      */
 949     dVAR;
 950     dXSARGS;
 951     PERL_UNUSED_ARG(cv);
 952     if (items)
 953         PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
 954     XSRETURN(0);
 955 }
 956
 957 XS(XS_PerlIO__Layer__find)
 958 {
 959     dVAR;
 960     dXSARGS;
 961     PERL_UNUSED_ARG(cv);
 962     if (items < 2)
 963         Perl_croak(aTHX_ "Usage class->find(name[,load])");
 964     else {
 965         STRLEN len;
 966         const char * const name = SvPV_const(ST(1), len);
 967         const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
 968         PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
 969         ST(0) =
 970             (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
 971             &PL_sv_undef;
 972         XSRETURN(1);
 973     }
 974 }
 975
 976 void
 977 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 978 {
 979     dVAR;
 980     if (!PL_known_layers)
 981         PL_known_layers = PerlIO_list_alloc(aTHX);
 982     PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
 983     PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
 984 }
 985
 986 int
 987 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 988 {
 989     dVAR;
 990     if (names) {
 991         const char *s = names;
 992         while (*s) {
 993             while (isSPACE(*s) || *s == ':')
 994                 s++;
 995             if (*s) {
 996                 STRLEN llen = 0;
 997                 const char *e = s;
 998                 const char *as = NULL;
 999                 STRLEN alen = 0;
1000                 if (!isIDFIRST(*s)) {
1001                     /*
1002                      * Message is consistent with how attribute lists are
1003                      * passed. Even though this means "foo : : bar" is
1004                      * seen as an invalid separator character.
1005                      */
1006                     const char q = ((*s == '\'') ? '"' : '\'');
1007                     Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1008                                    "Invalid separator character %c%c%c in PerlIO layer specification %s",
1009                                    q, *s, q, s);
1010                     SETERRNO(EINVAL, LIB_INVARG);
1011                     return -1;
1012                 }
1013                 do {
1014                     e++;
1015                 } while (isWORDCHAR(*e));
1016                 llen = e - s;
1017                 if (*e == '(') {
1018                     int nesting = 1;
1019                     as = ++e;
1020                     while (nesting) {
1021                         switch (*e++) {
1022                         case ')':
1023                             if (--nesting == 0)
1024                                 alen = (e - 1) - as;
1025                             break;
1026                         case '(':
1027                             ++nesting;
1028                             break;
1029                         case '\\':
1030                             /*
1031                              * It's a nul terminated string, not allowed
1032                              * to \ the terminating null. Anything other
1033                              * character is passed over.
1034                              */
1035                             if (*e++) {
1036                                 break;
1037                             }
1038                             /*
1039                              * Drop through
1040                              */
1041                         case '\0':
1042                             e--;
1043                             Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1044                                            "Argument list not closed for PerlIO layer \"%.*s\"",
1045                                            (int) (e - s), s);
1046                             return -1;
1047                         default:
1048                             /*
1049                              * boring.
1050                              */
1051                             break;
1052                         }
1053                     }
1054                 }
1055                 if (e > s) {
1056                     PerlIO_funcs * const layer =
1057                         PerlIO_find_layer(aTHX_ s, llen, 1);
1058                     if (layer) {
1059                         SV *arg = NULL;
1060                         if (as)
1061                             arg = newSVpvn(as, alen);
1062                         PerlIO_list_push(aTHX_ av, layer,
1063                                          (arg) ? arg : &PL_sv_undef);
1064                         SvREFCNT_dec(arg);
1065                     }
1066                     else {
1067                         Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1068                                        (int) llen, s);
1069                         return -1;
1070                     }
1071                 }
1072                 s = e;
1073             }
1074         }
1075     }
1076     return 0;
1077 }
1078
1079 void
1080 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1081 {
1082     dVAR;
1083     PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1084 #ifdef PERLIO_USING_CRLF
1085     tab = &PerlIO_crlf;
1086 #else
1087     if (PerlIO_stdio.Set_ptrcnt)
1088         tab = &PerlIO_stdio;
1089 #endif
1090     PerlIO_debug("Pushing %s\n", tab->name);
1091     PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1092                      &PL_sv_undef);
1093 }
1094
1095 SV *
1096 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1097 {
1098     return av->array[n].arg;
1099 }
1100
1101 PerlIO_funcs *
1102 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1103 {
1104     if (n >= 0 && n < av->cur) {
1105         PerlIO_debug("Layer %" IVdf " is %s\n", n,
1106                      av->array[n].funcs->name);
1107         return av->array[n].funcs;
1108     }
1109     if (!def)
1110         Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1111     return def;
1112 }
1113
1114 IV
1115 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1116 {
1117     PERL_UNUSED_ARG(mode);
1118     PERL_UNUSED_ARG(arg);
1119     PERL_UNUSED_ARG(tab);
1120     if (PerlIOValid(f)) {
1121         PerlIO_flush(f);
1122         PerlIO_pop(aTHX_ f);
1123         return 0;
1124     }
1125     return -1;
1126 }
1127
1128 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1129     sizeof(PerlIO_funcs),
1130     "pop",
1131     0,
1132     PERLIO_K_DUMMY | PERLIO_K_UTF8,
1133     PerlIOPop_pushed,
1134     NULL,
1135     PerlIOBase_open,
1136     NULL,
1137     NULL,
1138     NULL,
1139     NULL,
1140     NULL,
1141     NULL,
1142     NULL,
1143     NULL,
1144     NULL,
1145     NULL,
1146     NULL,                       /* flush */
1147     NULL,                       /* fill */
1148     NULL,
1149     NULL,
1150     NULL,
1151     NULL,
1152     NULL,                       /* get_base */
1153     NULL,                       /* get_bufsiz */
1154     NULL,                       /* get_ptr */
1155     NULL,                       /* get_cnt */
1156     NULL,                       /* set_ptrcnt */
1157 };
1158
1159 PerlIO_list_t *
1160 PerlIO_default_layers(pTHX)
1161 {
1162     dVAR;
1163     if (!PL_def_layerlist) {
1164         const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1165         PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1166         PL_def_layerlist = PerlIO_list_alloc(aTHX);
1167         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1168 #if defined(WIN32)
1169         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1170 #if 0
1171         osLayer = &PerlIO_win32;
1172 #endif
1173 #endif
1174         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1175         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1176         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1177         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1178         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1179         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1180         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1181         PerlIO_list_push(aTHX_ PL_def_layerlist,
1182                          PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1183                          &PL_sv_undef);
1184         if (s) {
1185             PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1186         }
1187         else {
1188             PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1189         }
1190     }
1191     if (PL_def_layerlist->cur < 2) {
1192         PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1193     }
1194     return PL_def_layerlist;
1195 }
1196
1197 void
1198 Perl_boot_core_PerlIO(pTHX)
1199 {
1200 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1201     newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1202           __FILE__);
1203 #endif
1204     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1205     newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1206 }
1207
1208 PerlIO_funcs *
1209 PerlIO_default_layer(pTHX_ I32 n)
1210 {
1211     dVAR;
1212     PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1213     if (n < 0)
1214         n += av->cur;
1215     return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1216 }
1217
1218 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1219 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1220
1221 void
1222 PerlIO_stdstreams(pTHX)
1223 {
1224     dVAR;
1225     if (!PL_perlio) {
1226         PerlIO_init_table(aTHX);
1227         PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1228         PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1229         PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1230     }
1231 }
1232
1233 PerlIO *
1234 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1235 {
1236     VERIFY_HEAD(f);
1237     if (tab->fsize != sizeof(PerlIO_funcs)) {
1238         Perl_croak( aTHX_
1239             "%s (%"UVuf") does not match %s (%"UVuf")",
1240             "PerlIO layer function table size", (UV)tab->fsize,
1241             "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1242     }
1243     if (tab->size) {
1244         PerlIOl *l;
1245         if (tab->size < sizeof(PerlIOl)) {
1246             Perl_croak( aTHX_
1247                 "%s (%"UVuf") smaller than %s (%"UVuf")",
1248                 "PerlIO layer instance size", (UV)tab->size,
1249                 "size expected by this perl", (UV)sizeof(PerlIOl) );
1250         }
1251         /* Real layer with a data area */
1252         if (f) {
1253             char *temp;
1254             Newxz(temp, tab->size, char);
1255             l = (PerlIOl*)temp;
1256             if (l) {
1257                 l->next = *f;
1258                 l->tab = (PerlIO_funcs*) tab;
1259                 l->head = ((PerlIOl*)f)->head;
1260                 *f = l;
1261                 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1262                              (void*)f, tab->name,
1263                              (mode) ? mode : "(Null)", (void*)arg);
1264                 if (*l->tab->Pushed &&
1265                     (*l->tab->Pushed)
1266                       (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1267                     PerlIO_pop(aTHX_ f);
1268                     return NULL;
1269                 }
1270             }
1271             else
1272                 return NULL;
1273         }
1274     }
1275     else if (f) {
1276         /* Pseudo-layer where push does its own stack adjust */
1277         PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1278                      (mode) ? mode : "(Null)", (void*)arg);
1279         if (tab->Pushed &&
1280             (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1281              return NULL;
1282         }
1283     }
1284     return f;
1285 }
1286
1287 PerlIO *
1288 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1289                IV n, const char *mode, int fd, int imode, int perm,
1290                PerlIO *old, int narg, SV **args)
1291 {
1292     PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1293     if (tab && tab->Open) {
1294         PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1295         if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1296             PerlIO_close(ret);
1297             return NULL;
1298         }
1299         return ret;
1300     }
1301     SETERRNO(EINVAL, LIB_INVARG);
1302     return NULL;
1303 }
1304
1305 IV
1306 PerlIOBase_binmode(pTHX_ PerlIO *f)
1307 {
1308    if (PerlIOValid(f)) {
1309         /* Is layer suitable for raw stream ? */
1310         if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1311             /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1312             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1313         }
1314         else {
1315             /* Not suitable - pop it */
1316             PerlIO_pop(aTHX_ f);
1317         }
1318         return 0;
1319    }
1320    return -1;
1321 }
1322
1323 IV
1324 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1325 {
1326     PERL_UNUSED_ARG(mode);
1327     PERL_UNUSED_ARG(arg);
1328     PERL_UNUSED_ARG(tab);
1329
1330     if (PerlIOValid(f)) {
1331         PerlIO *t;
1332         const PerlIOl *l;
1333         PerlIO_flush(f);
1334         /*
1335          * Strip all layers that are not suitable for a raw stream
1336          */
1337         t = f;
1338         while (t && (l = *t)) {
1339             if (l->tab && l->tab->Binmode) {
1340                 /* Has a handler - normal case */
1341                 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1342                     if (*t == l) {
1343                         /* Layer still there - move down a layer */
1344                         t = PerlIONext(t);
1345                     }
1346                 }
1347                 else {
1348                     return -1;
1349                 }
1350             }
1351             else {
1352                 /* No handler - pop it */
1353                 PerlIO_pop(aTHX_ t);
1354             }
1355         }
1356         if (PerlIOValid(f)) {
1357             PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1358                 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1359             return 0;
1360         }
1361     }
1362     return -1;
1363 }
1364
1365 int
1366 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1367                     PerlIO_list_t *layers, IV n, IV max)
1368 {
1369     int code = 0;
1370     while (n < max) {
1371         PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1372         if (tab) {
1373             if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1374                 code = -1;
1375                 break;
1376             }
1377         }
1378         n++;
1379     }
1380     return code;
1381 }
1382
1383 int
1384 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1385 {
1386     int code = 0;
1387     ENTER;
1388     save_scalar(PL_errgv);
1389     if (f && names) {
1390         PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1391         code = PerlIO_parse_layers(aTHX_ layers, names);
1392         if (code == 0) {
1393             code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1394         }
1395         PerlIO_list_free(aTHX_ layers);
1396     }
1397     LEAVE;
1398     return code;
1399 }
1400
1401
1402 /*--------------------------------------------------------------------------------------*/
1403 /*
1404  * Given the abstraction above the public API functions
1405  */
1406
1407 int
1408 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1409 {
1410     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1411                  (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1412                         PerlIOBase(f)->tab->name : "(Null)",
1413                  iotype, mode, (names) ? names : "(Null)");
1414
1415     if (names) {
1416         /* Do not flush etc. if (e.g.) switching encodings.
1417            if a pushed layer knows it needs to flush lower layers
1418            (for example :unix which is never going to call them)
1419            it can do the flush when it is pushed.
1420          */
1421         return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1422     }
1423     else {
1424         /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1425 #ifdef PERLIO_USING_CRLF
1426         /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1427            O_BINARY so we can look for it in mode.
1428          */
1429         if (!(mode & O_BINARY)) {
1430             /* Text mode */
1431             /* FIXME?: Looking down the layer stack seems wrong,
1432                but is a way of reaching past (say) an encoding layer
1433                to flip CRLF-ness of the layer(s) below
1434              */
1435             while (*f) {
1436                 /* Perhaps we should turn on bottom-most aware layer
1437                    e.g. Ilya's idea that UNIX TTY could serve
1438                  */
1439                 if (PerlIOBase(f)->tab &&
1440                     PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1441                 {
1442                     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1443                         /* Not in text mode - flush any pending stuff and flip it */
1444                         PerlIO_flush(f);
1445                         PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1446                     }
1447                     /* Only need to turn it on in one layer so we are done */
1448                     return TRUE;
1449                 }
1450                 f = PerlIONext(f);
1451             }
1452             /* Not finding a CRLF aware layer presumably means we are binary
1453                which is not what was requested - so we failed
1454                We _could_ push :crlf layer but so could caller
1455              */
1456             return FALSE;
1457         }
1458 #endif
1459         /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1460            So code that used to be here is now in PerlIORaw_pushed().
1461          */
1462         return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1463     }
1464 }
1465
1466 int
1467 PerlIO__close(pTHX_ PerlIO *f)
1468 {
1469     if (PerlIOValid(f)) {
1470         PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1471         if (tab && tab->Close)
1472             return (*tab->Close)(aTHX_ f);
1473         else
1474             return PerlIOBase_close(aTHX_ f);
1475     }
1476     else {
1477         SETERRNO(EBADF, SS_IVCHAN);
1478         return -1;
1479     }
1480 }
1481
1482 int
1483 Perl_PerlIO_close(pTHX_ PerlIO *f)
1484 {
1485     const int code = PerlIO__close(aTHX_ f);
1486     while (PerlIOValid(f)) {
1487         PerlIO_pop(aTHX_ f);
1488         if (PerlIO_lockcnt(f))
1489             /* we're in use; the 'pop' deferred freeing the structure */
1490             f = PerlIONext(f);
1491     }
1492     return code;
1493 }
1494
1495 int
1496 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1497 {
1498     dVAR;
1499      Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1500 }
1501
1502
1503 static PerlIO_funcs *
1504 PerlIO_layer_from_ref(pTHX_ SV *sv)
1505 {
1506     dVAR;
1507     /*
1508      * For any scalar type load the handler which is bundled with perl
1509      */
1510     if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1511         PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1512         /* This isn't supposed to happen, since PerlIO::scalar is core,
1513          * but could happen anyway in smaller installs or with PAR */
1514         if (!f)
1515             /* diag_listed_as: Unknown PerlIO layer "%s" */
1516             Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1517         return f;
1518     }
1519
1520     /*
1521      * For other types allow if layer is known but don't try and load it
1522      */
1523     switch (SvTYPE(sv)) {
1524     case SVt_PVAV:
1525         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1526     case SVt_PVHV:
1527         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1528     case SVt_PVCV:
1529         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1530     case SVt_PVGV:
1531         return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1532     default:
1533         return NULL;
1534     }
1535 }
1536
1537 PerlIO_list_t *
1538 PerlIO_resolve_layers(pTHX_ const char *layers,
1539                       const char *mode, int narg, SV **args)
1540 {
1541     dVAR;
1542     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1543     int incdef = 1;
1544     if (!PL_perlio)
1545         PerlIO_stdstreams(aTHX);
1546     if (narg) {
1547         SV * const arg = *args;
1548         /*
1549          * If it is a reference but not an object see if we have a handler
1550          * for it
1551          */
1552         if (SvROK(arg) && !sv_isobject(arg)) {
1553             PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1554             if (handler) {
1555                 def = PerlIO_list_alloc(aTHX);
1556                 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1557                 incdef = 0;
1558             }
1559             /*
1560              * Don't fail if handler cannot be found :via(...) etc. may do
1561              * something sensible else we will just stringfy and open
1562              * resulting string.
1563              */
1564         }
1565     }
1566     if (!layers || !*layers)
1567         layers = Perl_PerlIO_context_layers(aTHX_ mode);
1568     if (layers && *layers) {
1569         PerlIO_list_t *av;
1570         if (incdef) {
1571             av = PerlIO_clone_list(aTHX_ def, NULL);
1572         }
1573         else {
1574             av = def;
1575         }
1576         if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1577              return av;
1578         }
1579         else {
1580             PerlIO_list_free(aTHX_ av);
1581             return NULL;
1582         }
1583     }
1584     else {
1585         if (incdef)
1586             def->refcnt++;
1587         return def;
1588     }
1589 }
1590
1591 PerlIO *
1592 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1593              int imode, int perm, PerlIO *f, int narg, SV **args)
1594 {
1595     dVAR;
1596     if (!f && narg == 1 && *args == &PL_sv_undef) {
1597         if ((f = PerlIO_tmpfile())) {
1598             if (!layers || !*layers)
1599                 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1600             if (layers && *layers)
1601                 PerlIO_apply_layers(aTHX_ f, mode, layers);
1602         }
1603     }
1604     else {
1605         PerlIO_list_t *layera;
1606         IV n;
1607         PerlIO_funcs *tab = NULL;
1608         if (PerlIOValid(f)) {
1609             /*
1610              * This is "reopen" - it is not tested as perl does not use it
1611              * yet
1612              */
1613             PerlIOl *l = *f;
1614             layera = PerlIO_list_alloc(aTHX);
1615             while (l) {
1616                 SV *arg = NULL;
1617                 if (l->tab && l->tab->Getarg)
1618                     arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1619                 PerlIO_list_push(aTHX_ layera, l->tab,
1620                                  (arg) ? arg : &PL_sv_undef);
1621                 SvREFCNT_dec(arg);
1622                 l = *PerlIONext(&l);
1623             }
1624         }
1625         else {
1626             layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1627             if (!layera) {
1628                 return NULL;
1629             }
1630         }
1631         /*
1632          * Start at "top" of layer stack
1633          */
1634         n = layera->cur - 1;
1635         while (n >= 0) {
1636             PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1637             if (t && t->Open) {
1638                 tab = t;
1639                 break;
1640             }
1641             n--;
1642         }
1643         if (tab) {
1644             /*
1645              * Found that layer 'n' can do opens - call it
1646              */
1647             if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1648                 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1649             }
1650             PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1651                          tab->name, layers ? layers : "(Null)", mode, fd,
1652                          imode, perm, (void*)f, narg, (void*)args);
1653             if (tab->Open)
1654                  f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1655                                    f, narg, args);
1656             else {
1657                  SETERRNO(EINVAL, LIB_INVARG);
1658                  f = NULL;
1659             }
1660             if (f) {
1661                 if (n + 1 < layera->cur) {
1662                     /*
1663                      * More layers above the one that we used to open -
1664                      * apply them now
1665                      */
1666                     if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1667                         /* If pushing layers fails close the file */
1668                         PerlIO_close(f);
1669                         f = NULL;
1670                     }
1671                 }
1672             }
1673         }
1674         PerlIO_list_free(aTHX_ layera);
1675     }
1676     return f;
1677 }
1678
1679
1680 SSize_t
1681 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1682 {
1683      PERL_ARGS_ASSERT_PERLIO_READ;
1684
1685      Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1686 }
1687
1688 SSize_t
1689 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1690 {
1691      PERL_ARGS_ASSERT_PERLIO_UNREAD;
1692
1693      Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1694 }
1695
1696 SSize_t
1697 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1698 {
1699      PERL_ARGS_ASSERT_PERLIO_WRITE;
1700
1701      Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1702 }
1703
1704 int
1705 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1706 {
1707      Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1708 }
1709
1710 Off_t
1711 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1712 {
1713      Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1714 }
1715
1716 int
1717 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1718 {
1719     dVAR;
1720     if (f) {
1721         if (*f) {
1722             const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1723
1724             if (tab && tab->Flush)
1725                 return (*tab->Flush) (aTHX_ f);
1726             else
1727                  return 0; /* If no Flush defined, silently succeed. */
1728         }
1729         else {
1730             PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1731             SETERRNO(EBADF, SS_IVCHAN);
1732             return -1;
1733         }
1734     }
1735     else {
1736         /*
1737          * Is it good API design to do flush-all on NULL, a potentially
1738          * erroneous input? Maybe some magical value (PerlIO*
1739          * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1740          * things on fflush(NULL), but should we be bound by their design
1741          * decisions? --jhi
1742          */
1743         PerlIOl **table = &PL_perlio;
1744         PerlIOl *ff;
1745         int code = 0;
1746         while ((ff = *table)) {
1747             int i;
1748             table = (PerlIOl **) (ff++);
1749             for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1750                 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1751                     code = -1;
1752                 ff++;
1753             }
1754         }
1755         return code;
1756     }
1757 }
1758
1759 void
1760 PerlIOBase_flush_linebuf(pTHX)
1761 {
1762     dVAR;
1763     PerlIOl **table = &PL_perlio;
1764     PerlIOl *f;
1765     while ((f = *table)) {
1766         int i;
1767         table = (PerlIOl **) (f++);
1768         for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1769             if (f->next
1770                 && (PerlIOBase(&(f->next))->
1771                     flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1772                 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1773                 PerlIO_flush(&(f->next));
1774             f++;
1775         }
1776     }
1777 }
1778
1779 int
1780 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1781 {
1782      Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1783 }
1784
1785 int
1786 PerlIO_isutf8(PerlIO *f)
1787 {
1788      if (PerlIOValid(f))
1789           return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1790      else
1791           SETERRNO(EBADF, SS_IVCHAN);
1792
1793      return -1;
1794 }
1795
1796 int
1797 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1798 {
1799      Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1800 }
1801
1802 int
1803 Perl_PerlIO_error(pTHX_ PerlIO *f)
1804 {
1805      Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1806 }
1807
1808 void
1809 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1810 {
1811      Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1812 }
1813
1814 void
1815 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1816 {
1817      Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1818 }
1819
1820 int
1821 PerlIO_has_base(PerlIO *f)
1822 {
1823      if (PerlIOValid(f)) {
1824           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1825
1826           if (tab)
1827                return (tab->Get_base != NULL);
1828      }
1829
1830      return 0;
1831 }
1832
1833 int
1834 PerlIO_fast_gets(PerlIO *f)
1835 {
1836     if (PerlIOValid(f)) {
1837          if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1838              const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1839
1840              if (tab)
1841                   return (tab->Set_ptrcnt != NULL);
1842          }
1843     }
1844
1845     return 0;
1846 }
1847
1848 int
1849 PerlIO_has_cntptr(PerlIO *f)
1850 {
1851     if (PerlIOValid(f)) {
1852         const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1853
1854         if (tab)
1855              return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1856     }
1857
1858     return 0;
1859 }
1860
1861 int
1862 PerlIO_canset_cnt(PerlIO *f)
1863 {
1864     if (PerlIOValid(f)) {
1865           const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1866
1867           if (tab)
1868                return (tab->Set_ptrcnt != NULL);
1869     }
1870
1871     return 0;
1872 }
1873
1874 STDCHAR *
1875 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1876 {
1877      Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1878 }
1879
1880 int
1881 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1882 {
1883      Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1884 }
1885
1886 STDCHAR *
1887 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1888 {
1889      Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1890 }
1891
1892 int
1893 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1894 {
1895      Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1896 }
1897
1898 void
1899 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1900 {
1901      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1902 }
1903
1904 void
1905 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1906 {
1907      Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1908 }
1909
1910
1911 /*--------------------------------------------------------------------------------------*/
1912 /*
1913  * utf8 and raw dummy layers
1914  */
1915
1916 IV
1917 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1918 {
1919     PERL_UNUSED_CONTEXT;
1920     PERL_UNUSED_ARG(mode);
1921     PERL_UNUSED_ARG(arg);
1922     if (PerlIOValid(f)) {
1923         if (tab && tab->kind & PERLIO_K_UTF8)
1924             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1925         else
1926             PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1927         return 0;
1928     }
1929     return -1;
1930 }
1931
1932 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1933     sizeof(PerlIO_funcs),
1934     "utf8",
1935     0,
1936     PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1937     PerlIOUtf8_pushed,
1938     NULL,
1939     PerlIOBase_open,
1940     NULL,
1941     NULL,
1942     NULL,
1943     NULL,
1944     NULL,
1945     NULL,
1946     NULL,
1947     NULL,
1948     NULL,
1949     NULL,
1950     NULL,                       /* flush */
1951     NULL,                       /* fill */
1952     NULL,
1953     NULL,
1954     NULL,
1955     NULL,
1956     NULL,                       /* get_base */
1957     NULL,                       /* get_bufsiz */
1958     NULL,                       /* get_ptr */
1959     NULL,                       /* get_cnt */
1960     NULL,                       /* set_ptrcnt */
1961 };
1962
1963 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1964     sizeof(PerlIO_funcs),
1965     "bytes",
1966     0,
1967     PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1968     PerlIOUtf8_pushed,
1969     NULL,
1970     PerlIOBase_open,
1971     NULL,
1972     NULL,
1973     NULL,
1974     NULL,
1975     NULL,
1976     NULL,
1977     NULL,
1978     NULL,
1979     NULL,
1980     NULL,
1981     NULL,                       /* flush */
1982     NULL,                       /* fill */
1983     NULL,
1984     NULL,
1985     NULL,
1986     NULL,
1987     NULL,                       /* get_base */
1988     NULL,                       /* get_bufsiz */
1989     NULL,                       /* get_ptr */
1990     NULL,                       /* get_cnt */
1991     NULL,                       /* set_ptrcnt */
1992 };
1993
1994 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1995     sizeof(PerlIO_funcs),
1996     "raw",
1997     0,
1998     PERLIO_K_DUMMY,
1999     PerlIORaw_pushed,
2000     PerlIOBase_popped,
2001     PerlIOBase_open,
2002     NULL,
2003     NULL,
2004     NULL,
2005     NULL,
2006     NULL,
2007     NULL,
2008     NULL,
2009     NULL,
2010     NULL,
2011     NULL,
2012     NULL,                       /* flush */
2013     NULL,                       /* fill */
2014     NULL,
2015     NULL,
2016     NULL,
2017     NULL,
2018     NULL,                       /* get_base */
2019     NULL,                       /* get_bufsiz */
2020     NULL,                       /* get_ptr */
2021     NULL,                       /* get_cnt */
2022     NULL,                       /* set_ptrcnt */
2023 };
2024 /*--------------------------------------------------------------------------------------*/
2025 /*--------------------------------------------------------------------------------------*/
2026 /*
2027  * "Methods" of the "base class"
2028  */
2029
2030 IV
2031 PerlIOBase_fileno(pTHX_ PerlIO *f)
2032 {
2033     return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2034 }
2035
2036 char *
2037 PerlIO_modestr(PerlIO * f, char *buf)
2038 {
2039     char *s = buf;
2040     if (PerlIOValid(f)) {
2041         const IV flags = PerlIOBase(f)->flags;
2042         if (flags & PERLIO_F_APPEND) {
2043             *s++ = 'a';
2044             if (flags & PERLIO_F_CANREAD) {
2045                 *s++ = '+';
2046             }
2047         }
2048         else if (flags & PERLIO_F_CANREAD) {
2049             *s++ = 'r';
2050             if (flags & PERLIO_F_CANWRITE)
2051                 *s++ = '+';
2052         }
2053         else if (flags & PERLIO_F_CANWRITE) {
2054             *s++ = 'w';
2055             if (flags & PERLIO_F_CANREAD) {
2056                 *s++ = '+';
2057             }
2058         }
2059 #ifdef PERLIO_USING_CRLF
2060         if (!(flags & PERLIO_F_CRLF))
2061             *s++ = 'b';
2062 #endif
2063     }
2064     *s = '\0';
2065     return buf;
2066 }
2067
2068
2069 IV
2070 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2071 {
2072     PerlIOl * const l = PerlIOBase(f);
2073     PERL_UNUSED_CONTEXT;
2074     PERL_UNUSED_ARG(arg);
2075
2076     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2077                   PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2078     if (tab && tab->Set_ptrcnt != NULL)
2079         l->flags |= PERLIO_F_FASTGETS;
2080     if (mode) {
2081         if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2082             mode++;
2083         switch (*mode++) {
2084         case 'r':
2085             l->flags |= PERLIO_F_CANREAD;
2086             break;
2087         case 'a':
2088             l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2089             break;
2090         case 'w':
2091             l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2092             break;
2093         default:
2094             SETERRNO(EINVAL, LIB_INVARG);
2095             return -1;
2096         }
2097         while (*mode) {
2098             switch (*mode++) {
2099             case '+':
2100                 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2101                 break;
2102             case 'b':
2103                 l->flags &= ~PERLIO_F_CRLF;
2104                 break;
2105             case 't':
2106                 l->flags |= PERLIO_F_CRLF;
2107                 break;
2108             default:
2109                 SETERRNO(EINVAL, LIB_INVARG);
2110                 return -1;
2111             }
2112         }
2113     }
2114     else {
2115         if (l->next) {
2116             l->flags |= l->next->flags &
2117                 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2118                  PERLIO_F_APPEND);
2119         }
2120     }
2121 #if 0
2122     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2123                  (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2124                  l->flags, PerlIO_modestr(f, temp));
2125 #endif
2126     return 0;
2127 }
2128
2129 IV
2130 PerlIOBase_popped(pTHX_ PerlIO *f)
2131 {
2132     PERL_UNUSED_CONTEXT;
2133     PERL_UNUSED_ARG(f);
2134     return 0;
2135 }
2136
2137 SSize_t
2138 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2139 {
2140     /*
2141      * Save the position as current head considers it
2142      */
2143     const Off_t old = PerlIO_tell(f);
2144     PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2145     PerlIOSelf(f, PerlIOBuf)->posn = old;
2146     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2147 }
2148
2149 SSize_t
2150 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2151 {
2152     STDCHAR *buf = (STDCHAR *) vbuf;
2153     if (f) {
2154         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2155             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2156             SETERRNO(EBADF, SS_IVCHAN);
2157             return 0;
2158         }
2159         while (count > 0) {
2160          get_cnt:
2161           {
2162             SSize_t avail = PerlIO_get_cnt(f);
2163             SSize_t take = 0;
2164             if (avail > 0)
2165                 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2166             if (take > 0) {
2167                 STDCHAR *ptr = PerlIO_get_ptr(f);
2168                 Copy(ptr, buf, take, STDCHAR);
2169                 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2170                 count -= take;
2171                 buf += take;
2172                 if (avail == 0)         /* set_ptrcnt could have reset avail */
2173                     goto get_cnt;
2174             }
2175             if (count > 0 && avail <= 0) {
2176                 if (PerlIO_fill(f) != 0)
2177                     break;
2178             }
2179           }
2180         }
2181         return (buf - (STDCHAR *) vbuf);
2182     }
2183     return 0;
2184 }
2185
2186 IV
2187 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2188 {
2189     PERL_UNUSED_CONTEXT;
2190     PERL_UNUSED_ARG(f);
2191     return 0;
2192 }
2193
2194 IV
2195 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2196 {
2197     PERL_UNUSED_CONTEXT;
2198     PERL_UNUSED_ARG(f);
2199     return -1;
2200 }
2201
2202 IV
2203 PerlIOBase_close(pTHX_ PerlIO *f)
2204 {
2205     IV code = -1;
2206     if (PerlIOValid(f)) {
2207         PerlIO *n = PerlIONext(f);
2208         code = PerlIO_flush(f);
2209         PerlIOBase(f)->flags &=
2210            ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2211         while (PerlIOValid(n)) {
2212             const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2213             if (tab && tab->Close) {
2214                 if ((*tab->Close)(aTHX_ n) != 0)
2215                     code = -1;
2216                 break;
2217             }
2218             else {
2219                 PerlIOBase(n)->flags &=
2220                     ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2221             }
2222             n = PerlIONext(n);
2223         }
2224     }
2225     else {
2226         SETERRNO(EBADF, SS_IVCHAN);
2227     }
2228     return code;
2229 }
2230
2231 IV
2232 PerlIOBase_eof(pTHX_ PerlIO *f)
2233 {
2234     PERL_UNUSED_CONTEXT;
2235     if (PerlIOValid(f)) {
2236         return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2237     }
2238     return 1;
2239 }
2240
2241 IV
2242 PerlIOBase_error(pTHX_ PerlIO *f)
2243 {
2244     PERL_UNUSED_CONTEXT;
2245     if (PerlIOValid(f)) {
2246         return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2247     }
2248     return 1;
2249 }
2250
2251 void
2252 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2253 {
2254     if (PerlIOValid(f)) {
2255         PerlIO * const n = PerlIONext(f);
2256         PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2257         if (PerlIOValid(n))
2258             PerlIO_clearerr(n);
2259     }
2260 }
2261
2262 void
2263 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2264 {
2265     PERL_UNUSED_CONTEXT;
2266     if (PerlIOValid(f)) {
2267         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2268     }
2269 }
2270
2271 SV *
2272 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2273 {
2274     if (!arg)
2275         return NULL;
2276 #ifdef sv_dup
2277     if (param) {
2278         arg = sv_dup(arg, param);
2279         SvREFCNT_inc_simple_void_NN(arg);
2280         return arg;
2281     }
2282     else {
2283         return newSVsv(arg);
2284     }
2285 #else
2286     PERL_UNUSED_ARG(param);
2287     return newSVsv(arg);
2288 #endif
2289 }
2290
2291 PerlIO *
2292 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2293 {
2294     PerlIO * const nexto = PerlIONext(o);
2295     if (PerlIOValid(nexto)) {
2296         const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2297         if (tab && tab->Dup)
2298             f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2299         else
2300             f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2301     }
2302     if (f) {
2303         PerlIO_funcs * const self = PerlIOBase(o)->tab;
2304         SV *arg = NULL;
2305         char buf[8];
2306         PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2307                      self ? self->name : "(Null)",
2308                      (void*)f, (void*)o, (void*)param);
2309         if (self && self->Getarg)
2310             arg = (*self->Getarg)(aTHX_ o, param, flags);
2311         f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2312         if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2313             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2314         SvREFCNT_dec(arg);
2315     }
2316     return f;
2317 }
2318
2319 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2320
2321 /* Must be called with PL_perlio_mutex locked. */
2322 static void
2323 S_more_refcounted_fds(pTHX_ const int new_fd) {
2324     dVAR;
2325     const int old_max = PL_perlio_fd_refcnt_size;
2326     const int new_max = 16 + (new_fd & ~15);
2327     int *new_array;
2328
2329     PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2330                  old_max, new_fd, new_max);
2331
2332     if (new_fd < old_max) {
2333         return;
2334     }
2335
2336     assert (new_max > new_fd);
2337
2338     /* Use plain realloc() since we need this memory to be really
2339      * global and visible to all the interpreters and/or threads. */
2340     new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2341
2342     if (!new_array) {
2343 #ifdef USE_ITHREADS
2344         MUTEX_UNLOCK(&PL_perlio_mutex);
2345 #endif
2346         croak_no_mem();
2347     }
2348
2349     PL_perlio_fd_refcnt_size = new_max;
2350     PL_perlio_fd_refcnt = new_array;
2351
2352     PerlIO_debug("Zeroing %p, %d\n",
2353                  (void*)(new_array + old_max),
2354                  new_max - old_max);
2355
2356     Zero(new_array + old_max, new_max - old_max, int);
2357 }
2358
2359
2360 void
2361 PerlIO_init(pTHX)
2362 {
2363     /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2364     PERL_UNUSED_CONTEXT;
2365 }
2366
2367 void
2368 PerlIOUnix_refcnt_inc(int fd)
2369 {
2370     dTHX;
2371     if (fd >= 0) {
2372         dVAR;
2373
2374 #ifdef USE_ITHREADS
2375         MUTEX_LOCK(&PL_perlio_mutex);
2376 #endif
2377         if (fd >= PL_perlio_fd_refcnt_size)
2378             S_more_refcounted_fds(aTHX_ fd);
2379
2380         PL_perlio_fd_refcnt[fd]++;
2381         if (PL_perlio_fd_refcnt[fd] <= 0) {
2382             /* diag_listed_as: refcnt_inc: fd %d%s */
2383             Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2384                        fd, PL_perlio_fd_refcnt[fd]);
2385         }
2386         PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2387                      fd, PL_perlio_fd_refcnt[fd]);
2388
2389 #ifdef USE_ITHREADS
2390         MUTEX_UNLOCK(&PL_perlio_mutex);
2391 #endif
2392     } else {
2393         /* diag_listed_as: refcnt_inc: fd %d%s */
2394         Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2395     }
2396 }
2397
2398 int
2399 PerlIOUnix_refcnt_dec(int fd)
2400 {
2401     int cnt = 0;
2402     if (fd >= 0) {
2403         dVAR;
2404 #ifdef USE_ITHREADS
2405         MUTEX_LOCK(&PL_perlio_mutex);
2406 #endif
2407         if (fd >= PL_perlio_fd_refcnt_size) {
2408             /* diag_listed_as: refcnt_dec: fd %d%s */
2409             Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2410                        fd, PL_perlio_fd_refcnt_size);
2411         }
2412         if (PL_perlio_fd_refcnt[fd] <= 0) {
2413             /* diag_listed_as: refcnt_dec: fd %d%s */
2414             Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2415                        fd, PL_perlio_fd_refcnt[fd]);
2416         }
2417         cnt = --PL_perlio_fd_refcnt[fd];
2418         PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2419 #ifdef USE_ITHREADS
2420         MUTEX_UNLOCK(&PL_perlio_mutex);
2421 #endif
2422     } else {
2423         /* diag_listed_as: refcnt_dec: fd %d%s */
2424         Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2425     }
2426     return cnt;
2427 }
2428
2429 int
2430 PerlIOUnix_refcnt(int fd)
2431 {
2432     dTHX;
2433     int cnt = 0;
2434     if (fd >= 0) {
2435         dVAR;
2436 #ifdef USE_ITHREADS
2437         MUTEX_LOCK(&PL_perlio_mutex);
2438 #endif
2439         if (fd >= PL_perlio_fd_refcnt_size) {
2440             /* diag_listed_as: refcnt: fd %d%s */
2441             Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2442                        fd, PL_perlio_fd_refcnt_size);
2443         }
2444         if (PL_perlio_fd_refcnt[fd] <= 0) {
2445             /* diag_listed_as: refcnt: fd %d%s */
2446             Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2447                        fd, PL_perlio_fd_refcnt[fd]);
2448         }
2449         cnt = PL_perlio_fd_refcnt[fd];
2450 #ifdef USE_ITHREADS
2451         MUTEX_UNLOCK(&PL_perlio_mutex);
2452 #endif
2453     } else {
2454         /* diag_listed_as: refcnt: fd %d%s */
2455         Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2456     }
2457     return cnt;
2458 }
2459
2460 void
2461 PerlIO_cleanup(pTHX)
2462 {
2463     dVAR;
2464     int i;
2465 #ifdef USE_ITHREADS
2466     PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2467 #else
2468     PerlIO_debug("Cleanup layers\n");
2469 #endif
2470
2471     /* Raise STDIN..STDERR refcount so we don't close them */
2472     for (i=0; i < 3; i++)
2473         PerlIOUnix_refcnt_inc(i);
2474     PerlIO_cleantable(aTHX_ &PL_perlio);
2475     /* Restore STDIN..STDERR refcount */
2476     for (i=0; i < 3; i++)
2477         PerlIOUnix_refcnt_dec(i);
2478
2479     if (PL_known_layers) {
2480         PerlIO_list_free(aTHX_ PL_known_layers);
2481         PL_known_layers = NULL;
2482     }
2483     if (PL_def_layerlist) {
2484         PerlIO_list_free(aTHX_ PL_def_layerlist);
2485         PL_def_layerlist = NULL;
2486     }
2487 }
2488
2489 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2490 {
2491     dVAR;
2492 #if 0
2493 /* XXX we can't rely on an interpreter being present at this late stage,
2494    XXX so we can't use a function like PerlLIO_write that relies on one
2495    being present (at least in win32) :-(.
2496    Disable for now.
2497 */
2498 #ifdef DEBUGGING
2499     {
2500         /* By now all filehandles should have been closed, so any
2501          * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2502          * errors. */
2503 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2504 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2505         char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2506         int i;
2507         for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2508             if (PL_perlio_fd_refcnt[i]) {
2509                 const STRLEN len =
2510                     my_snprintf(buf, sizeof(buf),
2511                                 "PerlIO_teardown: fd %d refcnt=%d\n",
2512                                 i, PL_perlio_fd_refcnt[i]);
2513                 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2514             }
2515         }
2516     }
2517 #endif
2518 #endif
2519     /* Not bothering with PL_perlio_mutex since by now
2520      * all the interpreters are gone. */
2521     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2522         && PL_perlio_fd_refcnt) {
2523         free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2524         PL_perlio_fd_refcnt = NULL;
2525         PL_perlio_fd_refcnt_size = 0;
2526     }
2527 }
2528
2529 /*--------------------------------------------------------------------------------------*/
2530 /*
2531  * Bottom-most level for UNIX-like case
2532  */
2533
2534 typedef struct {
2535     struct _PerlIO base;        /* The generic part */
2536     int fd;                     /* UNIX like file descriptor */
2537     int oflags;                 /* open/fcntl flags */
2538 } PerlIOUnix;
2539
2540 static void
2541 S_lockcnt_dec(pTHX_ const void* f)
2542 {
2543     PerlIO_lockcnt((PerlIO*)f)--;
2544 }
2545
2546
2547 /* call the signal handler, and if that handler happens to clear
2548  * this handle, free what we can and return true */
2549
2550 static bool
2551 S_perlio_async_run(pTHX_ PerlIO* f) {
2552     ENTER;
2553     SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2554     PerlIO_lockcnt(f)++;
2555     PERL_ASYNC_CHECK();
2556     if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2557         LEAVE;
2558         return 0;
2559     }
2560     /* we've just run some perl-level code that could have done
2561      * anything, including closing the file or clearing this layer.
2562      * If so, free any lower layers that have already been
2563      * cleared, then return an error. */
2564     while (PerlIOValid(f) &&
2565             (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2566     {
2567         const PerlIOl *l = *f;
2568         *f = l->next;
2569         Safefree(l);
2570     }
2571     LEAVE;
2572     return 1;
2573 }
2574
2575 int
2576 PerlIOUnix_oflags(const char *mode)
2577 {
2578     int oflags = -1;
2579     if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2580         mode++;
2581     switch (*mode) {
2582     case 'r':
2583         oflags = O_RDONLY;
2584         if (*++mode == '+') {
2585             oflags = O_RDWR;
2586             mode++;
2587         }
2588         break;
2589
2590     case 'w':
2591         oflags = O_CREAT | O_TRUNC;
2592         if (*++mode == '+') {
2593             oflags |= O_RDWR;
2594             mode++;
2595         }
2596         else
2597             oflags |= O_WRONLY;
2598         break;
2599
2600     case 'a':
2601         oflags = O_CREAT | O_APPEND;
2602         if (*++mode == '+') {
2603             oflags |= O_RDWR;
2604             mode++;
2605         }
2606         else
2607             oflags |= O_WRONLY;
2608         break;
2609     }
2610     if (*mode == 'b') {
2611         oflags |= O_BINARY;
2612         oflags &= ~O_TEXT;
2613         mode++;
2614     }
2615     else if (*mode == 't') {
2616         oflags |= O_TEXT;
2617         oflags &= ~O_BINARY;
2618         mode++;
2619     }
2620     else {
2621 #ifdef PERLIO_USING_CRLF
2622         /*
2623          * If neither "t" nor "b" was specified, open the file
2624          * in O_BINARY mode.
2625          */
2626         oflags |= O_BINARY;
2627 #endif
2628     }
2629     if (*mode || oflags == -1) {
2630         SETERRNO(EINVAL, LIB_INVARG);
2631         oflags = -1;
2632     }
2633     return oflags;
2634 }
2635
2636 IV
2637 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2638 {
2639     PERL_UNUSED_CONTEXT;
2640     return PerlIOSelf(f, PerlIOUnix)->fd;
2641 }
2642
2643 static void
2644 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2645 {
2646     PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2647 #if defined(WIN32)
2648     Stat_t st;
2649     if (PerlLIO_fstat(fd, &st) == 0) {
2650         if (!S_ISREG(st.st_mode)) {
2651             PerlIO_debug("%d is not regular file\n",fd);
2652             PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2653         }
2654         else {
2655             PerlIO_debug("%d _is_ a regular file\n",fd);
2656         }
2657     }
2658 #endif
2659     s->fd = fd;
2660     s->oflags = imode;
2661     PerlIOUnix_refcnt_inc(fd);
2662     PERL_UNUSED_CONTEXT;
2663 }
2664
2665 IV
2666 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2667 {
2668     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2669     if (*PerlIONext(f)) {
2670         /* We never call down so do any pending stuff now */
2671         PerlIO_flush(PerlIONext(f));
2672         /*
2673          * XXX could (or should) we retrieve the oflags from the open file
2674          * handle rather than believing the "mode" we are passed in? XXX
2675          * Should the value on NULL mode be 0 or -1?
2676          */
2677         PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2678                          mode ? PerlIOUnix_oflags(mode) : -1);
2679     }
2680     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2681
2682     return code;
2683 }
2684
2685 IV
2686 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2687 {
2688     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2689     Off_t new_loc;
2690     PERL_UNUSED_CONTEXT;
2691     if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2692 #ifdef  ESPIPE
2693         SETERRNO(ESPIPE, LIB_INVARG);
2694 #else
2695         SETERRNO(EINVAL, LIB_INVARG);
2696 #endif
2697         return -1;
2698     }
2699     new_loc = PerlLIO_lseek(fd, offset, whence);
2700     if (new_loc == (Off_t) - 1)
2701         return -1;
2702     PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2703     return  0;
2704 }
2705
2706 PerlIO *
2707 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2708                 IV n, const char *mode, int fd, int imode,
2709                 int perm, PerlIO *f, int narg, SV **args)
2710 {
2711     if (PerlIOValid(f)) {
2712         if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2713             (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2714     }
2715     if (narg > 0) {
2716         if (*mode == IoTYPE_NUMERIC)
2717             mode++;
2718         else {
2719             imode = PerlIOUnix_oflags(mode);
2720 #ifdef VMS
2721             perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2722 #else
2723             perm = 0666;
2724 #endif
2725         }
2726         if (imode != -1) {
2727             const char *path = SvPV_nolen_const(*args);
2728             if (!IS_SAFE_PATHNAME(*args, "open"))
2729                 return NULL;
2730             fd = PerlLIO_open3(path, imode, perm);
2731         }
2732     }
2733     if (fd >= 0) {
2734         if (*mode == IoTYPE_IMPLICIT)
2735             mode++;
2736         if (!f) {
2737             f = PerlIO_allocate(aTHX);
2738         }
2739         if (!PerlIOValid(f)) {
2740             if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2741                 return NULL;
2742             }
2743         }
2744         PerlIOUnix_setfd(aTHX_ f, fd, imode);
2745         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2746         if (*mode == IoTYPE_APPEND)
2747             PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2748         return f;
2749     }
2750     else {
2751         if (f) {
2752             NOOP;
2753             /*
2754              * FIXME: pop layers ???
2755              */
2756         }
2757         return NULL;
2758     }
2759 }
2760
2761 PerlIO *
2762 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2763 {
2764     const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2765     int fd = os->fd;
2766     if (flags & PERLIO_DUP_FD) {
2767         fd = PerlLIO_dup(fd);
2768     }
2769     if (fd >= 0) {
2770         f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2771         if (f) {
2772             /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2773             PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2774             return f;
2775         }
2776     }
2777     return NULL;
2778 }
2779
2780
2781 SSize_t
2782 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2783 {
2784     dVAR;
2785     int fd;
2786     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2787         return -1;
2788     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2789 #ifdef PERLIO_STD_SPECIAL
2790     if (fd == 0)
2791         return PERLIO_STD_IN(fd, vbuf, count);
2792 #endif
2793     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2794          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2795         return 0;
2796     }
2797     while (1) {
2798         const SSize_t len = PerlLIO_read(fd, vbuf, count);
2799         if (len >= 0 || errno != EINTR) {
2800             if (len < 0) {
2801                 if (errno != EAGAIN) {
2802                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2803                 }
2804             }
2805             else if (len == 0 && count != 0) {
2806                 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2807                 SETERRNO(0,0);
2808             }
2809             return len;
2810         }
2811         /* EINTR */
2812         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2813             return -1;
2814     }
2815     /*NOTREACHED*/
2816 }
2817
2818 SSize_t
2819 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2820 {
2821     dVAR;
2822     int fd;
2823     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2824         return -1;
2825     fd = PerlIOSelf(f, PerlIOUnix)->fd;
2826 #ifdef PERLIO_STD_SPECIAL
2827     if (fd == 1 || fd == 2)
2828         return PERLIO_STD_OUT(fd, vbuf, count);
2829 #endif
2830     while (1) {
2831         const SSize_t len = PerlLIO_write(fd, vbuf, count);
2832         if (len >= 0 || errno != EINTR) {
2833             if (len < 0) {
2834                 if (errno != EAGAIN) {
2835                     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2836                 }
2837             }
2838             return len;
2839         }
2840         /* EINTR */
2841         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2842             return -1;
2843     }
2844     /*NOTREACHED*/
2845 }
2846
2847 Off_t
2848 PerlIOUnix_tell(pTHX_ PerlIO *f)
2849 {
2850     PERL_UNUSED_CONTEXT;
2851
2852     return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2853 }
2854
2855
2856 IV
2857 PerlIOUnix_close(pTHX_ PerlIO *f)
2858 {
2859     dVAR;
2860     const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2861     int code = 0;
2862     if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2863         if (PerlIOUnix_refcnt_dec(fd) > 0) {
2864             PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2865             return 0;
2866         }
2867     }
2868     else {
2869         SETERRNO(EBADF,SS_IVCHAN);
2870         return -1;
2871     }
2872     while (PerlLIO_close(fd) != 0) {
2873         if (errno != EINTR) {
2874             code = -1;
2875             break;
2876         }
2877         /* EINTR */
2878         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2879             return -1;
2880     }
2881     if (code == 0) {
2882         PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2883     }
2884     return code;
2885 }
2886
2887 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2888     sizeof(PerlIO_funcs),
2889     "unix",
2890     sizeof(PerlIOUnix),
2891     PERLIO_K_RAW,
2892     PerlIOUnix_pushed,
2893     PerlIOBase_popped,
2894     PerlIOUnix_open,
2895     PerlIOBase_binmode,         /* binmode */
2896     NULL,
2897     PerlIOUnix_fileno,
2898     PerlIOUnix_dup,
2899     PerlIOUnix_read,
2900     PerlIOBase_unread,
2901     PerlIOUnix_write,
2902     PerlIOUnix_seek,
2903     PerlIOUnix_tell,
2904     PerlIOUnix_close,
2905     PerlIOBase_noop_ok,         /* flush */
2906     PerlIOBase_noop_fail,       /* fill */
2907     PerlIOBase_eof,
2908     PerlIOBase_error,
2909     PerlIOBase_clearerr,
2910     PerlIOBase_setlinebuf,
2911     NULL,                       /* get_base */
2912     NULL,                       /* get_bufsiz */
2913     NULL,                       /* get_ptr */
2914     NULL,                       /* get_cnt */
2915     NULL,                       /* set_ptrcnt */
2916 };
2917
2918 /*--------------------------------------------------------------------------------------*/
2919 /*
2920  * stdio as a layer
2921  */
2922
2923 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2924 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2925    broken by the last second glibc 2.3 fix
2926  */
2927 #define STDIO_BUFFER_WRITABLE
2928 #endif
2929
2930
2931 typedef struct {
2932     struct _PerlIO base;
2933     FILE *stdio;                /* The stream */
2934 } PerlIOStdio;
2935
2936 IV
2937 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2938 {
2939     PERL_UNUSED_CONTEXT;
2940
2941     if (PerlIOValid(f)) {
2942         FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2943         if (s)
2944             return PerlSIO_fileno(s);
2945     }
2946     errno = EBADF;
2947     return -1;
2948 }
2949
2950 char *
2951 PerlIOStdio_mode(const char *mode, char *tmode)
2952 {
2953     char * const ret = tmode;
2954     if (mode) {
2955         while (*mode) {
2956             *tmode++ = *mode++;
2957         }
2958     }
2959 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2960     *tmode++ = 'b';
2961 #endif
2962     *tmode = '\0';
2963     return ret;
2964 }
2965
2966 IV
2967 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2968 {
2969     PerlIO *n;
2970     if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2971         PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2972         if (toptab == tab) {
2973             /* Top is already stdio - pop self (duplicate) and use original */
2974             PerlIO_pop(aTHX_ f);
2975             return 0;
2976         } else {
2977             const int fd = PerlIO_fileno(n);
2978             char tmode[8];
2979             FILE *stdio;
2980             if (fd >= 0 && (stdio  = PerlSIO_fdopen(fd,
2981                             mode = PerlIOStdio_mode(mode, tmode)))) {
2982                 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2983                 /* We never call down so do any pending stuff now */
2984                 PerlIO_flush(PerlIONext(f));
2985             }
2986             else {
2987                 return -1;
2988             }
2989         }
2990     }
2991     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2992 }
2993
2994
2995 PerlIO *
2996 PerlIO_importFILE(FILE *stdio, const char *mode)
2997 {
2998     dTHX;
2999     PerlIO *f = NULL;
3000     if (stdio) {
3001         PerlIOStdio *s;
3002         if (!mode || !*mode) {
3003             /* We need to probe to see how we can open the stream
3004                so start with read/write and then try write and read
3005                we dup() so that we can fclose without loosing the fd.
3006
3007                Note that the errno value set by a failing fdopen
3008                varies between stdio implementations.
3009              */
3010             const int fd = PerlLIO_dup(fileno(stdio));
3011             FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3012             if (!f2) {
3013                 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3014             }
3015             if (!f2) {
3016                 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3017             }
3018             if (!f2) {
3019                 /* Don't seem to be able to open */
3020                 PerlLIO_close(fd);
3021                 return f;
3022             }
3023             fclose(f2);
3024         }
3025         if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3026             s = PerlIOSelf(f, PerlIOStdio);
3027             s->stdio = stdio;
3028             PerlIOUnix_refcnt_inc(fileno(stdio));
3029         }
3030     }
3031     return f;
3032 }
3033
3034 PerlIO *
3035 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3036                  IV n, const char *mode, int fd, int imode,
3037                  int perm, PerlIO *f, int narg, SV **args)
3038 {
3039     char tmode[8];
3040     if (PerlIOValid(f)) {
3041         const char * const path = SvPV_nolen_const(*args);
3042         PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3043         FILE *stdio;
3044         if (!IS_SAFE_PATHNAME(*args, "open"))
3045             return NULL;
3046         PerlIOUnix_refcnt_dec(fileno(s->stdio));
3047         stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3048                             s->stdio);
3049         if (!s->stdio)
3050             return NULL;
3051         s->stdio = stdio;
3052         PerlIOUnix_refcnt_inc(fileno(s->stdio));
3053         return f;
3054     }
3055     else {
3056         if (narg > 0) {
3057             const char * const path = SvPV_nolen_const(*args);
3058             if (!IS_SAFE_PATHNAME(*args, "open"))
3059                 return NULL;
3060             if (*mode == IoTYPE_NUMERIC) {
3061                 mode++;
3062                 fd = PerlLIO_open3(path, imode, perm);
3063             }
3064             else {
3065                 FILE *stdio;
3066                 bool appended = FALSE;
3067 #ifdef __CYGWIN__
3068                 /* Cygwin wants its 'b' early. */
3069                 appended = TRUE;
3070                 mode = PerlIOStdio_mode(mode, tmode);
3071 #endif
3072                 stdio = PerlSIO_fopen(path, mode);
3073                 if (stdio) {
3074                     if (!f) {
3075                         f = PerlIO_allocate(aTHX);
3076                     }
3077                     if (!appended)
3078                         mode = PerlIOStdio_mode(mode, tmode);
3079                     f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3080                     if (f) {
3081                         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3082                         PerlIOUnix_refcnt_inc(fileno(stdio));
3083                     } else {
3084                         PerlSIO_fclose(stdio);
3085                     }
3086                     return f;
3087                 }
3088                 else {
3089                     return NULL;
3090                 }
3091             }
3092         }
3093         if (fd >= 0) {
3094             FILE *stdio = NULL;
3095             int init = 0;
3096             if (*mode == IoTYPE_IMPLICIT) {
3097                 init = 1;
3098                 mode++;
3099             }
3100             if (init) {
3101                 switch (fd) {
3102                 case 0:
3103                     stdio = PerlSIO_stdin;
3104                     break;
3105                 case 1:
3106                     stdio = PerlSIO_stdout;
3107                     break;
3108                 case 2:
3109                     stdio = PerlSIO_stderr;
3110                     break;
3111                 }
3112             }
3113             else {
3114                 stdio = PerlSIO_fdopen(fd, mode =
3115                                        PerlIOStdio_mode(mode, tmode));
3116             }
3117             if (stdio) {
3118                 if (!f) {
3119                     f = PerlIO_allocate(aTHX);
3120                 }
3121                 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3122                     PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3123                     PerlIOUnix_refcnt_inc(fileno(stdio));
3124                 }
3125                 return f;
3126             }
3127         }
3128     }
3129     return NULL;
3130 }
3131
3132 PerlIO *
3133 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3134 {
3135     /* This assumes no layers underneath - which is what
3136        happens, but is not how I remember it. NI-S 2001/10/16
3137      */
3138     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3139         FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3140         const int fd = fileno(stdio);
3141         char mode[8];
3142         if (flags & PERLIO_DUP_FD) {
3143             const int dfd = PerlLIO_dup(fileno(stdio));
3144             if (dfd >= 0) {
3145                 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3146                 goto set_this;
3147             }
3148             else {
3149                 NOOP;
3150                 /* FIXME: To avoid messy error recovery if dup fails
3151                    re-use the existing stdio as though flag was not set
3152                  */
3153             }
3154         }
3155         stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3156     set_this:
3157         PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3158         if(stdio) {
3159             PerlIOUnix_refcnt_inc(fileno(stdio));
3160         }
3161     }
3162     return f;
3163 }
3164
3165 static int
3166 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3167 {
3168     PERL_UNUSED_CONTEXT;
3169
3170     /* XXX this could use PerlIO_canset_fileno() and
3171      * PerlIO_set_fileno() support from Configure
3172      */
3173 #  if defined(__UCLIBC__)
3174     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3175     f->__filedes = -1;
3176     return 1;
3177 #  elif defined(__GLIBC__)
3178     /* There may be a better way for GLIBC:
3179         - libio.h defines a flag to not close() on cleanup
3180      */
3181     f->_fileno = -1;
3182     return 1;
3183 #  elif defined(__sun__)
3184     PERL_UNUSED_ARG(f);
3185     return 0;
3186 #  elif defined(__hpux)
3187     f->__fileH = 0xff;
3188     f->__fileL = 0xff;
3189     return 1;
3190    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3191       your platform does not have special entry try this one.
3192       [For OSF only have confirmation for Tru64 (alpha)
3193       but assume other OSFs will be similar.]
3194     */
3195 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3196     f->_file = -1;
3197     return 1;
3198 #  elif defined(__FreeBSD__)
3199     /* There may be a better way on FreeBSD:
3200         - we could insert a dummy func in the _close function entry
3201         f->_close = (int (*)(void *)) dummy_close;
3202      */
3203     f->_file = -1;
3204     return 1;
3205 #  elif defined(__OpenBSD__)
3206     /* There may be a better way on OpenBSD:
3207         - we could insert a dummy func in the _close function entry
3208         f->_close = (int (*)(void *)) dummy_close;
3209      */
3210     f->_file = -1;
3211     return 1;
3212 #  elif defined(__EMX__)
3213     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3214     f->_handle = -1;
3215     return 1;
3216 #  elif defined(__CYGWIN__)
3217     /* There may be a better way on CYGWIN:
3218         - we could insert a dummy func in the _close function entry
3219         f->_close = (int (*)(void *)) dummy_close;
3220      */
3221     f->_file = -1;
3222     return 1;
3223 #  elif defined(WIN32)
3224 #    if defined(UNDER_CE)
3225     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3226        structure at all
3227      */
3228 #    else
3229     f->_file = -1;
3230 #    endif
3231     return 1;
3232 #  else
3233 #if 0
3234     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3235        (which isn't thread safe) instead
3236      */
3237 #    error "Don't know how to set FILE.fileno on your platform"
3238 #endif
3239     PERL_UNUSED_ARG(f);
3240     return 0;
3241 #  endif
3242 }
3243
3244 IV
3245 PerlIOStdio_close(pTHX_ PerlIO *f)
3246 {
3247     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3248     if (!stdio) {
3249         errno = EBADF;
3250         return -1;
3251     }
3252     else {
3253         const int fd = fileno(stdio);
3254         int invalidate = 0;
3255         IV result = 0;
3256         int dupfd = -1;
3257         dSAVEDERRNO;
3258 #ifdef USE_ITHREADS
3259         dVAR;
3260 #endif
3261 #ifdef SOCKS5_VERSION_NAME
3262         /* Socks lib overrides close() but stdio isn't linked to
3263            that library (though we are) - so we must call close()
3264            on sockets on stdio's behalf.
3265          */
3266         int optval;
3267         Sock_size_t optlen = sizeof(int);
3268         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3269             invalidate = 1;
3270 #endif
3271         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3272            that a subsequent fileno() on it returns -1. Don't want to croak()
3273            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3274            trying to close an already closed handle which somehow it still has
3275            a reference to. (via.xs, I'm looking at you).  */
3276         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3277             /* File descriptor still in use */
3278             invalidate = 1;
3279         }
3280         if (invalidate) {
3281             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3282             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3283                 return 0;
3284             if (stdio == stdout || stdio == stderr)
3285                 return PerlIO_flush(f);
3286             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3287                Use Sarathy's trick from maint-5.6 to invalidate the
3288                fileno slot of the FILE *
3289             */
3290             result = PerlIO_flush(f);
3291             SAVE_ERRNO;
3292             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3293             if (!invalidate) {
3294 #ifdef USE_ITHREADS
3295                 MUTEX_LOCK(&PL_perlio_mutex);
3296                 /* Right. We need a mutex here because for a brief while we
3297                    will have the situation that fd is actually closed. Hence if
3298                    a second thread were to get into this block, its dup() would
3299                    likely return our fd as its dupfd. (after all, it is closed)
3300                    Then if we get to the dup2() first, we blat the fd back
3301                    (messing up its temporary as a side effect) only for it to
3302                    then close its dupfd (== our fd) in its close(dupfd) */
3303
3304                 /* There is, of course, a race condition, that any other thread
3305                    trying to input/output/whatever on this fd will be stuffed
3306                    for the duration of this little manoeuvrer. Perhaps we
3307                    should hold an IO mutex for the duration of every IO
3308                    operation if we know that invalidate doesn't work on this
3309                    platform, but that would suck, and could kill performance.
3310
3311                    Except that correctness trumps speed.
3312                    Advice from klortho #11912. */
3313 #endif
3314                 dupfd = PerlLIO_dup(fd);
3315 #ifdef USE_ITHREADS
3316                 if (dupfd < 0) {
3317                     MUTEX_UNLOCK(&PL_perlio_mutex);
3318                     /* Oh cXap. This isn't going to go well. Not sure if we can
3319                        recover from here, or if closing this particular FILE *
3320                        is a good idea now.  */
3321                 }
3322 #endif
3323             }
3324         } else {
3325             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3326         }
3327         result = PerlSIO_fclose(stdio);
3328         /* We treat error from stdio as success if we invalidated
3329            errno may NOT be expected EBADF
3330          */
3331         if (invalidate && result != 0) {
3332             RESTORE_ERRNO;
3333             result = 0;
3334         }
3335 #ifdef SOCKS5_VERSION_NAME
3336         /* in SOCKS' case, let close() determine return value */
3337         result = close(fd);
3338 #endif
3339         if (dupfd >= 0) {
3340             PerlLIO_dup2(dupfd,fd);
3341             PerlLIO_close(dupfd);
3342 #ifdef USE_ITHREADS
3343             MUTEX_UNLOCK(&PL_perlio_mutex);
3344 #endif
3345         }
3346         return result;
3347     }
3348 }
3349
3350 SSize_t
3351 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3352 {
3353     dVAR;
3354     FILE * s;
3355     SSize_t got = 0;
3356     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3357         return -1;
3358     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3359     for (;;) {
3360         if (count == 1) {
3361             STDCHAR *buf = (STDCHAR *) vbuf;
3362             /*
3363              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3364              * stdio does not do that for fread()
3365              */
3366             const int ch = PerlSIO_fgetc(s);
3367             if (ch != EOF) {
3368                 *buf = ch;
3369                 got = 1;
3370             }
3371         }
3372         else
3373             got = PerlSIO_fread(vbuf, 1, count, s);
3374         if (got == 0 && PerlSIO_ferror(s))
3375             got = -1;
3376         if (got >= 0 || errno != EINTR)
3377             break;
3378         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3379             return -1;
3380         SETERRNO(0,0);  /* just in case */
3381     }
3382     return got;
3383 }
3384
3385 SSize_t
3386 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3387 {
3388     SSize_t unread = 0;
3389     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3390
3391 #ifdef STDIO_BUFFER_WRITABLE
3392     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3393         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3394         STDCHAR *base = PerlIO_get_base(f);
3395         SSize_t cnt   = PerlIO_get_cnt(f);
3396         STDCHAR *ptr  = PerlIO_get_ptr(f);
3397         SSize_t avail = ptr - base;
3398         if (avail > 0) {
3399             if (avail > count) {
3400                 avail = count;
3401             }
3402             ptr -= avail;
3403             Move(buf-avail,ptr,avail,STDCHAR);
3404             count -= avail;
3405             unread += avail;
3406             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3407             if (PerlSIO_feof(s) && unread >= 0)
3408                 PerlSIO_clearerr(s);
3409         }
3410     }
3411     else
3412 #endif
3413     if (PerlIO_has_cntptr(f)) {
3414         /* We can get pointer to buffer but not its base
3415            Do ungetc() but check chars are ending up in the
3416            buffer
3417          */
3418         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3419         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3420         while (count > 0) {
3421             const int ch = *--buf & 0xFF;
3422             if (ungetc(ch,s) != ch) {
3423                 /* ungetc did not work */
3424                 break;
3425             }
3426             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3427                 /* Did not change pointer as expected */
3428                 fgetc(s);  /* get char back again */
3429                 break;
3430             }
3431             /* It worked ! */
3432             count--;
3433             unread++;
3434         }
3435     }
3436
3437     if (count > 0) {
3438         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3439     }
3440     return unread;
3441 }
3442
3443 SSize_t
3444 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3445 {
3446     dVAR;
3447     SSize_t got;
3448     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3449         return -1;
3450     for (;;) {
3451         got = PerlSIO_fwrite(vbuf, 1, count,
3452                               PerlIOSelf(f, PerlIOStdio)->stdio);
3453         if (got >= 0 || errno != EINTR)
3454             break;
3455         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3456             return -1;
3457         SETERRNO(0,0);  /* just in case */
3458     }
3459     return got;
3460 }
3461
3462 IV
3463 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3464 {
3465     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466     PERL_UNUSED_CONTEXT;
3467
3468     return PerlSIO_fseek(stdio, offset, whence);
3469 }
3470
3471 Off_t
3472 PerlIOStdio_tell(pTHX_ PerlIO *f)
3473 {
3474     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3475     PERL_UNUSED_CONTEXT;
3476
3477     return PerlSIO_ftell(stdio);
3478 }
3479
3480 IV
3481 PerlIOStdio_flush(pTHX_ PerlIO *f)
3482 {
3483     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3484     PERL_UNUSED_CONTEXT;
3485
3486     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3487         return PerlSIO_fflush(stdio);
3488     }
3489     else {
3490         NOOP;
3491 #if 0
3492         /*
3493          * FIXME: This discards ungetc() and pre-read stuff which is not
3494          * right if this is just a "sync" from a layer above Suspect right
3495          * design is to do _this_ but not have layer above flush this
3496          * layer read-to-read
3497          */
3498         /*
3499          * Not writeable - sync by attempting a seek
3500          */
3501         dSAVE_ERRNO;
3502         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3503             RESTORE_ERRNO;
3504 #endif
3505     }
3506     return 0;
3507 }
3508
3509 IV
3510 PerlIOStdio_eof(pTHX_ PerlIO *f)
3511 {
3512     PERL_UNUSED_CONTEXT;
3513
3514     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3515 }
3516
3517 IV
3518 PerlIOStdio_error(pTHX_ PerlIO *f)
3519 {
3520     PERL_UNUSED_CONTEXT;
3521
3522     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3523 }
3524
3525 void
3526 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3527 {
3528     PERL_UNUSED_CONTEXT;
3529
3530     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3531 }
3532
3533 void
3534 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3535 {
3536     PERL_UNUSED_CONTEXT;
3537
3538 #ifdef HAS_SETLINEBUF
3539     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3540 #else
3541     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3542 #endif
3543 }
3544
3545 #ifdef FILE_base
3546 STDCHAR *
3547 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3548 {
3549     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3550     return (STDCHAR*)PerlSIO_get_base(stdio);
3551 }
3552
3553 Size_t
3554 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3555 {
3556     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3557     return PerlSIO_get_bufsiz(stdio);
3558 }
3559 #endif
3560
3561 #ifdef USE_STDIO_PTR
3562 STDCHAR *
3563 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3564 {
3565     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3566     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3567 }
3568
3569 SSize_t
3570 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3571 {
3572     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3573     return PerlSIO_get_cnt(stdio);
3574 }
3575
3576 void
3577 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3578 {
3579     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3580     if (ptr != NULL) {
3581 #ifdef STDIO_PTR_LVALUE
3582         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3583 #ifdef STDIO_PTR_LVAL_SETS_CNT
3584         assert(PerlSIO_get_cnt(stdio) == (cnt));
3585 #endif
3586 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3587         /*
3588          * Setting ptr _does_ change cnt - we are done
3589          */
3590         return;
3591 #endif
3592 #else                           /* STDIO_PTR_LVALUE */
3593         PerlProc_abort();
3594 #endif                          /* STDIO_PTR_LVALUE */
3595     }
3596     /*
3597      * Now (or only) set cnt
3598      */
3599 #ifdef STDIO_CNT_LVALUE
3600     PerlSIO_set_cnt(stdio, cnt);
3601 #else                           /* STDIO_CNT_LVALUE */
3602 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3603     PerlSIO_set_ptr(stdio,
3604                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3605                                               cnt));
3606 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3607     PerlProc_abort();
3608 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3609 #endif                          /* STDIO_CNT_LVALUE */
3610 }
3611
3612
3613 #endif
3614
3615 IV
3616 PerlIOStdio_fill(pTHX_ PerlIO *f)
3617 {
3618     FILE * stdio;
3619     int c;
3620     PERL_UNUSED_CONTEXT;
3621     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3622         return -1;
3623     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3624
3625     /*
3626      * fflush()ing read-only streams can cause trouble on some stdio-s
3627      */
3628     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3629         if (PerlSIO_fflush(stdio) != 0)
3630             return EOF;
3631     }
3632     for (;;) {
3633         c = PerlSIO_fgetc(stdio);
3634         if (c != EOF)
3635             break;
3636         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3637             return EOF;
3638         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3639             return -1;
3640         SETERRNO(0,0);
3641     }
3642
3643 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3644
3645 #ifdef STDIO_BUFFER_WRITABLE
3646     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3647         /* Fake ungetc() to the real buffer in case system's ungetc
3648            goes elsewhere
3649          */
3650         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3651         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3652         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3653         if (ptr == base+1) {
3654             *--ptr = (STDCHAR) c;
3655             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3656             if (PerlSIO_feof(stdio))
3657                 PerlSIO_clearerr(stdio);
3658             return 0;
3659         }
3660     }
3661     else
3662 #endif
3663     if (PerlIO_has_cntptr(f)) {
3664         STDCHAR ch = c;
3665         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3666             return 0;
3667         }
3668     }
3669 #endif
3670
3671 #if defined(VMS)
3672     /* An ungetc()d char is handled separately from the regular
3673      * buffer, so we stuff it in the buffer ourselves.
3674      * Should never get called as should hit code above
3675      */
3676     *(--((*stdio)->_ptr)) = (unsigned char) c;
3677     (*stdio)->_cnt++;
3678 #else
3679     /* If buffer snoop scheme above fails fall back to
3680        using ungetc().
3681      */
3682     if (PerlSIO_ungetc(c, stdio) != c)
3683         return EOF;
3684 #endif
3685     return 0;
3686 }
3687
3688
3689
3690 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3691     sizeof(PerlIO_funcs),
3692     "stdio",
3693     sizeof(PerlIOStdio),
3694     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3695     PerlIOStdio_pushed,
3696     PerlIOBase_popped,
3697     PerlIOStdio_open,
3698     PerlIOBase_binmode,         /* binmode */
3699     NULL,
3700     PerlIOStdio_fileno,
3701     PerlIOStdio_dup,
3702     PerlIOStdio_read,
3703     PerlIOStdio_unread,
3704     PerlIOStdio_write,
3705     PerlIOStdio_seek,
3706     PerlIOStdio_tell,
3707     PerlIOStdio_close,
3708     PerlIOStdio_flush,
3709     PerlIOStdio_fill,
3710     PerlIOStdio_eof,
3711     PerlIOStdio_error,
3712     PerlIOStdio_clearerr,
3713     PerlIOStdio_setlinebuf,
3714 #ifdef FILE_base
3715     PerlIOStdio_get_base,
3716     PerlIOStdio_get_bufsiz,
3717 #else
3718     NULL,
3719     NULL,
3720 #endif
3721 #ifdef USE_STDIO_PTR
3722     PerlIOStdio_get_ptr,
3723     PerlIOStdio_get_cnt,
3724 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3725     PerlIOStdio_set_ptrcnt,
3726 #   else
3727     NULL,
3728 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3729 #else
3730     NULL,
3731     NULL,
3732     NULL,
3733 #endif /* USE_STDIO_PTR */
3734 };
3735
3736 /* Note that calls to PerlIO_exportFILE() are reversed using
3737  * PerlIO_releaseFILE(), not importFILE. */
3738 FILE *
3739 PerlIO_exportFILE(PerlIO * f, const char *mode)
3740 {
3741     dTHX;
3742     FILE *stdio = NULL;
3743     if (PerlIOValid(f)) {
3744         char buf[8];
3745         PerlIO_flush(f);
3746         if (!mode || !*mode) {
3747             mode = PerlIO_modestr(f, buf);
3748         }
3749         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3750         if (stdio) {
3751             PerlIOl *l = *f;
3752             PerlIO *f2;
3753             /* De-link any lower layers so new :stdio sticks */
3754             *f = NULL;
3755             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3756                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3757                 s->stdio = stdio;
3758                 PerlIOUnix_refcnt_inc(fileno(stdio));
3759                 /* Link previous lower layers under new one */
3760                 *PerlIONext(f) = l;
3761             }
3762             else {
3763                 /* restore layers list */
3764                 *f = l;
3765             }
3766         }
3767     }
3768     return stdio;
3769 }
3770
3771
3772 FILE *
3773 PerlIO_findFILE(PerlIO *f)
3774 {
3775     PerlIOl *l = *f;
3776     FILE *stdio;
3777     while (l) {
3778         if (l->tab == &PerlIO_stdio) {
3779             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3780             return s->stdio;
3781         }
3782         l = *PerlIONext(&l);
3783     }
3784     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3785     /* However, we're not really exporting a FILE * to someone else (who
3786        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3787        So we need to undo its reference count increase on the underlying file
3788        descriptor. We have to do this, because if the loop above returns you
3789        the FILE *, then *it* didn't increase any reference count. So there's
3790        only one way to be consistent. */
3791     stdio = PerlIO_exportFILE(f, NULL);
3792     if (stdio) {
3793         const int fd = fileno(stdio);
3794         if (fd >= 0)
3795             PerlIOUnix_refcnt_dec(fd);
3796     }
3797     return stdio;
3798 }
3799
3800 /* Use this to reverse PerlIO_exportFILE calls. */
3801 void
3802 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3803 {
3804     dVAR;
3805     PerlIOl *l;
3806     while ((l = *p)) {
3807         if (l->tab == &PerlIO_stdio) {
3808             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3809             if (s->stdio == f) { /* not in a loop */
3810                 const int fd = fileno(f);
3811                 if (fd >= 0)
3812                     PerlIOUnix_refcnt_dec(fd);
3813                 {
3814                     dTHX;
3815                     PerlIO_pop(aTHX_ p);
3816                 }
3817                 return;
3818             }
3819         }
3820         p = PerlIONext(p);
3821     }
3822     return;
3823 }
3824
3825 /*--------------------------------------------------------------------------------------*/
3826 /*
3827  * perlio buffer layer
3828  */
3829
3830 IV
3831 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3832 {
3833     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3834     const int fd = PerlIO_fileno(f);
3835     if (fd >= 0 && PerlLIO_isatty(fd)) {
3836         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3837     }
3838     if (*PerlIONext(f)) {
3839         const Off_t posn = PerlIO_tell(PerlIONext(f));
3840         if (posn != (Off_t) - 1) {
3841             b->posn = posn;
3842         }
3843     }
3844     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3845 }
3846
3847 PerlIO *
3848 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3849                IV n, const char *mode, int fd, int imode, int perm,
3850                PerlIO *f, int narg, SV **args)
3851 {
3852     if (PerlIOValid(f)) {
3853         PerlIO *next = PerlIONext(f);
3854         PerlIO_funcs *tab =
3855              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3856         if (tab && tab->Open)
3857              next =
3858                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3859                                next, narg, args);
3860         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3861             return NULL;
3862         }
3863     }
3864     else {
3865         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3866         int init = 0;
3867         if (*mode == IoTYPE_IMPLICIT) {
3868             init = 1;
3869             /*
3870              * mode++;
3871              */
3872         }
3873         if (tab && tab->Open)
3874              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3875                               f, narg, args);
3876         else
3877              SETERRNO(EINVAL, LIB_INVARG);
3878         if (f) {
3879             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3880                 /*
3881                  * if push fails during open, open fails. close will pop us.
3882                  */
3883                 PerlIO_close (f);
3884                 return NULL;
3885             } else {
3886                 fd = PerlIO_fileno(f);
3887                 if (init && fd == 2) {
3888                     /*
3889                      * Initial stderr is unbuffered
3890                      */
3891                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3892                 }
3893 #ifdef PERLIO_USING_CRLF
3894 #  ifdef PERLIO_IS_BINMODE_FD
3895                 if (PERLIO_IS_BINMODE_FD(fd))
3896                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3897                 else
3898 #  endif
3899                 /*
3900                  * do something about failing setmode()? --jhi
3901                  */
3902                 PerlLIO_setmode(fd, O_BINARY);
3903 #endif
3904 #ifdef VMS
3905                 /* Enable line buffering with record-oriented regular files
3906                  * so we don't introduce an extraneous record boundary when
3907                  * the buffer fills up.
3908                  */
3909                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3910                     Stat_t st;
3911                     if (PerlLIO_fstat(fd, &st) == 0
3912                         && S_ISREG(st.st_mode)
3913                         && (st.st_fab_rfm == FAB$C_VAR
3914                             || st.st_fab_rfm == FAB$C_VFC)) {
3915                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3916                     }
3917                 }
3918 #endif
3919             }
3920         }
3921     }
3922     return f;
3923 }
3924
3925 /*
3926  * This "flush" is akin to sfio's sync in that it handles files in either
3927  * read or write state.  For write state, we put the postponed data through
3928  * the next layers.  For read state, we seek() the next layers to the
3929  * offset given by current position in the buffer, and discard the buffer
3930  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3931  * in any case?).  Then the pass the stick further in chain.
3932  */
3933 IV
3934 PerlIOBuf_flush(pTHX_ PerlIO *f)
3935 {
3936     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3937     int code = 0;
3938     PerlIO *n = PerlIONext(f);
3939     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3940         /*
3941          * write() the buffer
3942          */
3943         const STDCHAR *buf = b->buf;
3944         const STDCHAR *p = buf;
3945         while (p < b->ptr) {
3946             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3947             if (count > 0) {
3948                 p += count;
3949             }
3950             else if (count < 0 || PerlIO_error(n)) {
3951                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3952                 code = -1;
3953                 break;
3954             }
3955         }
3956         b->posn += (p - buf);
3957     }
3958     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3959         STDCHAR *buf = PerlIO_get_base(f);
3960         /*
3961          * Note position change
3962          */
3963         b->posn += (b->ptr - buf);
3964         if (b->ptr < b->end) {
3965             /* We did not consume all of it - try and seek downstream to
3966                our logical position
3967              */
3968             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3969                 /* Reload n as some layers may pop themselves on seek */
3970                 b->posn = PerlIO_tell(n = PerlIONext(f));
3971             }
3972             else {
3973                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3974                    data is lost for good - so return saying "ok" having undone
3975                    the position adjust
3976                  */
3977                 b->posn -= (b->ptr - buf);
3978                 return code;
3979             }
3980         }
3981     }
3982     b->ptr = b->end = b->buf;
3983     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3984     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3985     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3986         code = -1;
3987     return code;
3988 }
3989
3990 /* This discards the content of the buffer after b->ptr, and rereads
3991  * the buffer from the position off in the layer downstream; here off
3992  * is at offset corresponding to b->ptr - b->buf.
3993  */
3994 IV
3995 PerlIOBuf_fill(pTHX_ PerlIO *f)
3996 {
3997     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3998     PerlIO *n = PerlIONext(f);
3999     SSize_t avail;
4000     /*
4001      * Down-stream flush is defined not to loose read data so is harmless.
4002      * we would not normally be fill'ing if there was data left in anycase.
4003      */
4004     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
4005         return -1;
4006     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4007         PerlIOBase_flush_linebuf(aTHX);
4008
4009     if (!b->buf)
4010         PerlIO_get_base(f);     /* allocate via vtable */
4011
4012     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4013
4014     b->ptr = b->end = b->buf;
4015
4016     if (!PerlIOValid(n)) {
4017         PerlIOBase(f)->flags |= PERLIO_F_EOF;
4018         return -1;
4019     }
4020
4021     if (PerlIO_fast_gets(n)) {
4022         /*
4023          * Layer below is also buffered. We do _NOT_ want to call its
4024          * ->Read() because that will loop till it gets what we asked for
4025          * which may hang on a pipe etc. Instead take anything it has to
4026          * hand, or ask it to fill _once_.
4027          */
4028         avail = PerlIO_get_cnt(n);
4029         if (avail <= 0) {
4030             avail = PerlIO_fill(n);
4031             if (avail == 0)
4032                 avail = PerlIO_get_cnt(n);
4033             else {
4034                 if (!PerlIO_error(n) && PerlIO_eof(n))
4035                     avail = 0;
4036             }
4037         }
4038         if (avail > 0) {
4039             STDCHAR *ptr = PerlIO_get_ptr(n);
4040             const SSize_t cnt = avail;
4041             if (avail > (SSize_t)b->bufsiz)
4042                 avail = b->bufsiz;
4043             Copy(ptr, b->buf, avail, STDCHAR);
4044             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4045         }
4046     }
4047     else {
4048         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4049     }
4050     if (avail <= 0) {
4051         if (avail == 0)
4052             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4053         else
4054             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4055         return -1;
4056     }
4057     b->end = b->buf + avail;
4058     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4059     return 0;
4060 }
4061
4062 SSize_t
4063 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4064 {
4065     if (PerlIOValid(f)) {
4066         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4067         if (!b->ptr)
4068             PerlIO_get_base(f);
4069         return PerlIOBase_read(aTHX_ f, vbuf, count);
4070     }
4071     return 0;
4072 }
4073
4074 SSize_t
4075 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4076 {
4077     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4078     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4079     SSize_t unread = 0;
4080     SSize_t avail;
4081     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4082         PerlIO_flush(f);
4083     if (!b->buf)
4084         PerlIO_get_base(f);
4085     if (b->buf) {
4086         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4087             /*
4088              * Buffer is already a read buffer, we can overwrite any chars
4089              * which have been read back to buffer start
4090              */
4091             avail = (b->ptr - b->buf);
4092         }
4093         else {
4094             /*
4095              * Buffer is idle, set it up so whole buffer is available for
4096              * unread
4097              */
4098             avail = b->bufsiz;
4099             b->end = b->buf + avail;
4100             b->ptr = b->end;
4101             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4102             /*
4103              * Buffer extends _back_ from where we are now
4104              */
4105             b->posn -= b->bufsiz;
4106         }
4107         if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4108             /*
4109              * If we have space for more than count, just move count
4110              */
4111             avail = count;
4112         }
4113         if (avail > 0) {
4114             b->ptr -= avail;
4115             buf -= avail;
4116             /*
4117              * In simple stdio-like ungetc() case chars will be already
4118              * there
4119              */
4120             if (buf != b->ptr) {
4121                 Copy(buf, b->ptr, avail, STDCHAR);
4122             }
4123             count -= avail;
4124             unread += avail;
4125             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4126         }
4127     }
4128     if (count > 0) {
4129         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4130     }
4131     return unread;
4132 }
4133
4134 SSize_t
4135 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4136 {
4137     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4138     const STDCHAR *buf = (const STDCHAR *) vbuf;
4139     const STDCHAR *flushptr = buf;
4140     Size_t written = 0;
4141     if (!b->buf)
4142         PerlIO_get_base(f);
4143     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4144         return 0;
4145     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4146         if (PerlIO_flush(f) != 0) {
4147             return 0;
4148         }
4149     }
4150     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4151         flushptr = buf + count;
4152         while (flushptr > buf && *(flushptr - 1) != '\n')
4153             --flushptr;
4154     }
4155     while (count > 0) {
4156         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4157         if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4158             avail = count;
4159         if (flushptr > buf && flushptr <= buf + avail)
4160             avail = flushptr - buf;
4161         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4162         if (avail) {
4163             Copy(buf, b->ptr, avail, STDCHAR);
4164             count -= avail;
4165             buf += avail;
4166             written += avail;
4167             b->ptr += avail;
4168             if (buf == flushptr)
4169                 PerlIO_flush(f);
4170         }
4171         if (b->ptr >= (b->buf + b->bufsiz))
4172             if (PerlIO_flush(f) == -1)
4173                 return -1;
4174     }
4175     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4176         PerlIO_flush(f);
4177     return written;
4178 }
4179
4180 IV
4181 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4182 {
4183     IV code;
4184     if ((code = PerlIO_flush(f)) == 0) {
4185         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4186         code = PerlIO_seek(PerlIONext(f), offset, whence);
4187         if (code == 0) {
4188             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4189             b->posn = PerlIO_tell(PerlIONext(f));
4190         }
4191     }
4192     return code;
4193 }
4194
4195 Off_t
4196 PerlIOBuf_tell(pTHX_ PerlIO *f)
4197 {
4198     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4199     /*
4200      * b->posn is file position where b->buf was read, or will be written
4201      */
4202     Off_t posn = b->posn;
4203     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4204         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4205 #if 1
4206         /* As O_APPEND files are normally shared in some sense it is better
4207            to flush :
4208          */
4209         PerlIO_flush(f);
4210 #else
4211         /* when file is NOT shared then this is sufficient */
4212         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4213 #endif
4214         posn = b->posn = PerlIO_tell(PerlIONext(f));
4215     }
4216     if (b->buf) {
4217         /*
4218          * If buffer is valid adjust position by amount in buffer
4219          */
4220         posn += (b->ptr - b->buf);
4221     }
4222     return posn;
4223 }
4224
4225 IV
4226 PerlIOBuf_popped(pTHX_ PerlIO *f)
4227 {
4228     const IV code = PerlIOBase_popped(aTHX_ f);
4229     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4230     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4231         Safefree(b->buf);
4232     }
4233     b->ptr = b->end = b->buf = NULL;
4234     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4235     return code;
4236 }
4237
4238 IV
4239 PerlIOBuf_close(pTHX_ PerlIO *f)
4240 {
4241     const IV code = PerlIOBase_close(aTHX_ f);
4242     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4243     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4244         Safefree(b->buf);
4245     }
4246     b->ptr = b->end = b->buf = NULL;
4247     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4248     return code;
4249 }
4250
4251 STDCHAR *
4252 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4253 {
4254     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4255     if (!b->buf)
4256         PerlIO_get_base(f);
4257     return b->ptr;
4258 }
4259
4260 SSize_t
4261 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4262 {
4263     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4264     if (!b->buf)
4265         PerlIO_get_base(f);
4266     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4267         return (b->end - b->ptr);
4268     return 0;
4269 }
4270
4271 STDCHAR *
4272 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4273 {
4274     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4275     PERL_UNUSED_CONTEXT;
4276
4277     if (!b->buf) {
4278         if (!b->bufsiz)
4279             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4280         Newxz(b->buf,b->bufsiz, STDCHAR);
4281         if (!b->buf) {
4282             b->buf = (STDCHAR *) & b->oneword;
4283             b->bufsiz = sizeof(b->oneword);
4284         }
4285         b->end = b->ptr = b->buf;
4286     }
4287     return b->buf;
4288 }
4289
4290 Size_t
4291 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4292 {
4293     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4294     if (!b->buf)
4295         PerlIO_get_base(f);
4296     return (b->end - b->buf);
4297 }
4298
4299 void
4300 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4301 {
4302     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4303 #ifndef DEBUGGING
4304     PERL_UNUSED_ARG(cnt);
4305 #endif
4306     if (!b->buf)
4307         PerlIO_get_base(f);
4308     b->ptr = ptr;
4309     assert(PerlIO_get_cnt(f) == cnt);
4310     assert(b->ptr >= b->buf);
4311     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4312 }
4313
4314 PerlIO *
4315 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4316 {
4317  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4318 }
4319
4320
4321
4322 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4323     sizeof(PerlIO_funcs),
4324     "perlio",
4325     sizeof(PerlIOBuf),
4326     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4327     PerlIOBuf_pushed,
4328     PerlIOBuf_popped,
4329     PerlIOBuf_open,
4330     PerlIOBase_binmode,         /* binmode */
4331     NULL,
4332     PerlIOBase_fileno,
4333     PerlIOBuf_dup,
4334     PerlIOBuf_read,
4335     PerlIOBuf_unread,
4336     PerlIOBuf_write,
4337     PerlIOBuf_seek,
4338     PerlIOBuf_tell,
4339     PerlIOBuf_close,
4340     PerlIOBuf_flush,
4341     PerlIOBuf_fill,
4342     PerlIOBase_eof,
4343     PerlIOBase_error,
4344     PerlIOBase_clearerr,
4345     PerlIOBase_setlinebuf,
4346     PerlIOBuf_get_base,
4347     PerlIOBuf_bufsiz,
4348     PerlIOBuf_get_ptr,
4349     PerlIOBuf_get_cnt,
4350     PerlIOBuf_set_ptrcnt,
4351 };
4352
4353 /*--------------------------------------------------------------------------------------*/
4354 /*
4355  * Temp layer to hold unread chars when cannot do it any other way
4356  */
4357
4358 IV
4359 PerlIOPending_fill(pTHX_ PerlIO *f)
4360 {
4361     /*
4362      * Should never happen
4363      */
4364     PerlIO_flush(f);
4365     return 0;
4366 }
4367
4368 IV
4369 PerlIOPending_close(pTHX_ PerlIO *f)
4370 {
4371     /*
4372      * A tad tricky - flush pops us, then we close new top
4373      */
4374     PerlIO_flush(f);
4375     return PerlIO_close(f);
4376 }
4377
4378 IV
4379 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4380 {
4381     /*
4382      * A tad tricky - flush pops us, then we seek new top
4383      */
4384     PerlIO_flush(f);
4385     return PerlIO_seek(f, offset, whence);
4386 }
4387
4388
4389 IV
4390 PerlIOPending_flush(pTHX_ PerlIO *f)
4391 {
4392     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4393     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4394         Safefree(b->buf);
4395         b->buf = NULL;
4396     }
4397     PerlIO_pop(aTHX_ f);
4398     return 0;
4399 }
4400
4401 void
4402 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4403 {
4404     if (cnt <= 0) {
4405         PerlIO_flush(f);
4406     }
4407     else {
4408         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4409     }
4410 }
4411
4412 IV
4413 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4414 {
4415     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4416     PerlIOl * const l = PerlIOBase(f);
4417     /*
4418      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4419      * etc. get muddled when it changes mid-string when we auto-pop.
4420      */
4421     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4422         (PerlIOBase(PerlIONext(f))->
4423          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4424     return code;
4425 }
4426
4427 SSize_t
4428 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4429 {
4430     SSize_t avail = PerlIO_get_cnt(f);
4431     SSize_t got = 0;
4432     if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4433         avail = count;
4434     if (avail > 0)
4435         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4436     if (got >= 0 && got < (SSize_t)count) {
4437         const SSize_t more =
4438             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4439         if (more >= 0 || got == 0)
4440             got += more;
4441     }
4442     return got;
4443 }
4444
4445 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4446     sizeof(PerlIO_funcs),
4447     "pending",
4448     sizeof(PerlIOBuf),
4449     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4450     PerlIOPending_pushed,
4451     PerlIOBuf_popped,
4452     NULL,
4453     PerlIOBase_binmode,         /* binmode */
4454     NULL,
4455     PerlIOBase_fileno,
4456     PerlIOBuf_dup,
4457     PerlIOPending_read,
4458     PerlIOBuf_unread,
4459     PerlIOBuf_write,
4460     PerlIOPending_seek,
4461     PerlIOBuf_tell,
4462     PerlIOPending_close,
4463     PerlIOPending_flush,
4464     PerlIOPending_fill,
4465     PerlIOBase_eof,
4466     PerlIOBase_error,
4467     PerlIOBase_clearerr,
4468     PerlIOBase_setlinebuf,
4469     PerlIOBuf_get_base,
4470     PerlIOBuf_bufsiz,
4471     PerlIOBuf_get_ptr,
4472     PerlIOBuf_get_cnt,
4473     PerlIOPending_set_ptrcnt,
4474 };
4475
4476
4477
4478 /*--------------------------------------------------------------------------------------*/
4479 /*
4480  * crlf - translation On read translate CR,LF to "\n" we do this by
4481  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4482  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4483  *
4484  * c->nl points on the first byte of CR LF pair when it is temporarily
4485  * replaced by LF, or to the last CR of the buffer.  In the former case
4486  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4487  * that it ends at c->nl; these two cases can be distinguished by
4488  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4489  * _unread() and _flush() calls.
4490  * It only matters for read operations.
4491  */
4492
4493 typedef struct {
4494     PerlIOBuf base;             /* PerlIOBuf stuff */
4495     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4496                                  * buffer */
4497 } PerlIOCrlf;
4498
4499 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4500  * Otherwise the :crlf layer would always revert back to
4501  * raw mode.
4502  */
4503 static void
4504 S_inherit_utf8_flag(PerlIO *f)
4505 {
4506     PerlIO *g = PerlIONext(f);
4507     if (PerlIOValid(g)) {
4508         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4509             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4510         }
4511     }
4512 }
4513
4514 IV
4515 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4516 {
4517     IV code;
4518     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4519     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4520 #if 0
4521     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4522                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4523                  PerlIOBase(f)->flags);
4524 #endif
4525     {
4526       /* If the old top layer is a CRLF layer, reactivate it (if
4527        * necessary) and remove this new layer from the stack */
4528          PerlIO *g = PerlIONext(f);
4529          if (PerlIOValid(g)) {
4530               PerlIOl *b = PerlIOBase(g);
4531               if (b && b->tab == &PerlIO_crlf) {
4532                    if (!(b->flags & PERLIO_F_CRLF))
4533                         b->flags |= PERLIO_F_CRLF;
4534                    S_inherit_utf8_flag(g);
4535                    PerlIO_pop(aTHX_ f);
4536                    return code;
4537               }
4538          }
4539     }
4540     S_inherit_utf8_flag(f);
4541     return code;
4542 }
4543
4544
4545 SSize_t
4546 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4547 {
4548     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4549     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4550         *(c->nl) = NATIVE_0xd;
4551         c->nl = NULL;
4552     }
4553     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4554         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4555     else {
4556         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4557         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4558         SSize_t unread = 0;
4559         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4560             PerlIO_flush(f);
4561         if (!b->buf)
4562             PerlIO_get_base(f);
4563         if (b->buf) {
4564             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4565                 b->end = b->ptr = b->buf + b->bufsiz;
4566                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4567                 b->posn -= b->bufsiz;
4568             }
4569             while (count > 0 && b->ptr > b->buf) {
4570                 const int ch = *--buf;
4571                 if (ch == '\n') {
4572                     if (b->ptr - 2 >= b->buf) {
4573                         *--(b->ptr) = NATIVE_0xa;
4574                         *--(b->ptr) = NATIVE_0xd;
4575                         unread++;
4576                         count--;
4577                     }
4578                     else {
4579                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4580                         *--(b->ptr) = NATIVE_0xa;   /* Works even if 0xa ==
4581                                                        '\r' */
4582                         unread++;
4583                         count--;
4584                     }
4585                 }
4586                 else {
4587                     *--(b->ptr) = ch;
4588                     unread++;
4589                     count--;
4590                 }
4591             }
4592         }
4593         if (count > 0)
4594             unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4595         return unread;
4596     }
4597 }
4598
4599 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4600 SSize_t
4601 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4602 {
4603     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4604     if (!b->buf)
4605         PerlIO_get_base(f);
4606     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4607         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4608         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4609             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4610           scan:
4611             while (nl < b->end && *nl != NATIVE_0xd)
4612                 nl++;
4613             if (nl < b->end && *nl == NATIVE_0xd) {
4614               test:
4615                 if (nl + 1 < b->end) {
4616                     if (nl[1] == NATIVE_0xa) {
4617                         *nl = '\n';
4618                         c->nl = nl;
4619                     }
4620                     else {
4621                         /*
4622                          * Not CR,LF but just CR
4623                          */
4624                         nl++;
4625                         goto scan;
4626                     }
4627                 }
4628                 else {
4629                     /*
4630                      * Blast - found CR as last char in buffer
4631                      */
4632
4633                     if (b->ptr < nl) {
4634                         /*
4635                          * They may not care, defer work as long as
4636                          * possible
4637                          */
4638                         c->nl = nl;
4639                         return (nl - b->ptr);
4640                     }
4641                     else {
4642                         int code;
4643                         b->ptr++;       /* say we have read it as far as
4644                                          * flush() is concerned */
4645                         b->buf++;       /* Leave space in front of buffer */
4646                         /* Note as we have moved buf up flush's
4647                            posn += ptr-buf
4648                            will naturally make posn point at CR
4649                          */
4650                         b->bufsiz--;    /* Buffer is thus smaller */
4651                         code = PerlIO_fill(f);  /* Fetch some more */
4652                         b->bufsiz++;    /* Restore size for next time */
4653                         b->buf--;       /* Point at space */
4654                         b->ptr = nl = b->buf;   /* Which is what we hand
4655                                                  * off */
4656                         *nl = NATIVE_0xd;      /* Fill in the CR */
4657                         if (code == 0)
4658                             goto test;  /* fill() call worked */
4659                         /*
4660                          * CR at EOF - just fall through
4661                          */
4662                         /* Should we clear EOF though ??? */
4663                     }
4664                 }
4665             }
4666         }
4667         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4668     }
4669     return 0;
4670 }
4671
4672 void
4673 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4674 {
4675     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4676     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4677     if (!b->buf)
4678         PerlIO_get_base(f);
4679     if (!ptr) {
4680         if (c->nl) {
4681             ptr = c->nl + 1;
4682             if (ptr == b->end && *c->nl == NATIVE_0xd) {
4683                 /* Deferred CR at end of buffer case - we lied about count */
4684                 ptr--;
4685             }
4686         }
4687         else {
4688             ptr = b->end;
4689         }
4690         ptr -= cnt;
4691     }
4692     else {
4693         NOOP;
4694 #if 0
4695         /*
4696          * Test code - delete when it works ...
4697          */
4698         IV flags = PerlIOBase(f)->flags;
4699         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4700         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4701           /* Deferred CR at end of buffer case - we lied about count */
4702           chk--;
4703         }
4704         chk -= cnt;
4705
4706         if (ptr != chk ) {
4707             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4708                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4709                        flags, c->nl, b->end, cnt);
4710         }
4711 #endif
4712     }
4713     if (c->nl) {
4714         if (ptr > c->nl) {
4715             /*
4716              * They have taken what we lied about
4717              */
4718             *(c->nl) = NATIVE_0xd;
4719             c->nl = NULL;
4720             ptr++;
4721         }
4722     }
4723     b->ptr = ptr;
4724     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4725 }
4726
4727 SSize_t
4728 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4729 {
4730     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4731         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4732     else {
4733         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4734         const STDCHAR *buf = (const STDCHAR *) vbuf;
4735         const STDCHAR * const ebuf = buf + count;
4736         if (!b->buf)
4737             PerlIO_get_base(f);
4738         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4739             return 0;
4740         while (buf < ebuf) {
4741             const STDCHAR * const eptr = b->buf + b->bufsiz;
4742             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4743             while (buf < ebuf && b->ptr < eptr) {
4744                 if (*buf == '\n') {
4745                     if ((b->ptr + 2) > eptr) {
4746                         /*
4747                          * Not room for both
4748                          */
4749                         PerlIO_flush(f);
4750                         break;
4751                     }
4752                     else {
4753                         *(b->ptr)++ = NATIVE_0xd;      /* CR */
4754                         *(b->ptr)++ = NATIVE_0xa;      /* LF */
4755                         buf++;
4756                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4757                             PerlIO_flush(f);
4758                             break;
4759                         }
4760                     }
4761                 }
4762                 else {
4763                     *(b->ptr)++ = *buf++;
4764                 }
4765                 if (b->ptr >= eptr) {
4766                     PerlIO_flush(f);
4767                     break;
4768                 }
4769             }
4770         }
4771         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4772             PerlIO_flush(f);
4773         return (buf - (STDCHAR *) vbuf);
4774     }
4775 }
4776
4777 IV
4778 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4779 {
4780     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4781     if (c->nl) {
4782         *(c->nl) = NATIVE_0xd;
4783         c->nl = NULL;
4784     }
4785     return PerlIOBuf_flush(aTHX_ f);
4786 }
4787
4788 IV
4789 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4790 {
4791     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4792         /* In text mode - flush any pending stuff and flip it */
4793         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4794 #ifndef PERLIO_USING_CRLF
4795         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4796         PerlIO_pop(aTHX_ f);
4797 #endif
4798     }
4799     return 0;
4800 }
4801
4802 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4803     sizeof(PerlIO_funcs),
4804     "crlf",
4805     sizeof(PerlIOCrlf),
4806     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4807     PerlIOCrlf_pushed,
4808     PerlIOBuf_popped,         /* popped */
4809     PerlIOBuf_open,
4810     PerlIOCrlf_binmode,       /* binmode */
4811     NULL,
4812     PerlIOBase_fileno,
4813     PerlIOBuf_dup,
4814     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4815     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4816     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4817     PerlIOBuf_seek,
4818     PerlIOBuf_tell,
4819     PerlIOBuf_close,
4820     PerlIOCrlf_flush,
4821     PerlIOBuf_fill,
4822     PerlIOBase_eof,
4823     PerlIOBase_error,
4824     PerlIOBase_clearerr,
4825     PerlIOBase_setlinebuf,
4826     PerlIOBuf_get_base,
4827     PerlIOBuf_bufsiz,
4828     PerlIOBuf_get_ptr,
4829     PerlIOCrlf_get_cnt,
4830     PerlIOCrlf_set_ptrcnt,
4831 };
4832
4833 PerlIO *
4834 Perl_PerlIO_stdin(pTHX)
4835 {
4836     dVAR;
4837     if (!PL_perlio) {
4838         PerlIO_stdstreams(aTHX);
4839     }
4840     return (PerlIO*)&PL_perlio[1];
4841 }
4842
4843 PerlIO *
4844 Perl_PerlIO_stdout(pTHX)
4845 {
4846     dVAR;
4847     if (!PL_perlio) {
4848         PerlIO_stdstreams(aTHX);
4849     }
4850     return (PerlIO*)&PL_perlio[2];
4851 }
4852
4853 PerlIO *
4854 Perl_PerlIO_stderr(pTHX)
4855 {
4856     dVAR;
4857     if (!PL_perlio) {
4858         PerlIO_stdstreams(aTHX);
4859     }
4860     return (PerlIO*)&PL_perlio[3];
4861 }
4862
4863 /*--------------------------------------------------------------------------------------*/
4864
4865 char *
4866 PerlIO_getname(PerlIO *f, char *buf)
4867 {
4868 #ifdef VMS
4869     dTHX;
4870     char *name = NULL;
4871     bool exported = FALSE;
4872     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4873     if (!stdio) {
4874         stdio = PerlIO_exportFILE(f,0);
4875         exported = TRUE;
4876     }
4877     if (stdio) {
4878         name = fgetname(stdio, buf);
4879         if (exported) PerlIO_releaseFILE(f,stdio);
4880     }
4881     return name;
4882 #else
4883     PERL_UNUSED_ARG(f);
4884     PERL_UNUSED_ARG(buf);
4885     Perl_croak_nocontext("Don't know how to get file name");
4886     return NULL;
4887 #endif
4888 }
4889
4890
4891 /*--------------------------------------------------------------------------------------*/
4892 /*
4893  * Functions which can be called on any kind of PerlIO implemented in
4894  * terms of above
4895  */
4896
4897 #undef PerlIO_fdopen
4898 PerlIO *
4899 PerlIO_fdopen(int fd, const char *mode)
4900 {
4901     dTHX;
4902     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4903 }
4904
4905 #undef PerlIO_open
4906 PerlIO *
4907 PerlIO_open(const char *path, const char *mode)
4908 {
4909     dTHX;
4910     SV *name = sv_2mortal(newSVpv(path, 0));
4911     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4912 }
4913
4914 #undef Perlio_reopen
4915 PerlIO *
4916 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4917 {
4918     dTHX;
4919     SV *name = sv_2mortal(newSVpv(path,0));
4920     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4921 }
4922
4923 #undef PerlIO_getc
4924 int
4925 PerlIO_getc(PerlIO *f)
4926 {
4927     dTHX;
4928     STDCHAR buf[1];
4929     if ( 1 == PerlIO_read(f, buf, 1) ) {
4930         return (unsigned char) buf[0];
4931     }
4932     return EOF;
4933 }
4934
4935 #undef PerlIO_ungetc
4936 int
4937 PerlIO_ungetc(PerlIO *f, int ch)
4938 {
4939     dTHX;
4940     if (ch != EOF) {
4941         STDCHAR buf = ch;
4942         if (PerlIO_unread(f, &buf, 1) == 1)
4943             return ch;
4944     }
4945     return EOF;
4946 }
4947
4948 #undef PerlIO_putc
4949 int
4950 PerlIO_putc(PerlIO *f, int ch)
4951 {
4952     dTHX;
4953     STDCHAR buf = ch;
4954     return PerlIO_write(f, &buf, 1);
4955 }
4956
4957 #undef PerlIO_puts
4958 int
4959 PerlIO_puts(PerlIO *f, const char *s)
4960 {
4961     dTHX;
4962     return PerlIO_write(f, s, strlen(s));
4963 }
4964
4965 #undef PerlIO_rewind
4966 void
4967 PerlIO_rewind(PerlIO *f)
4968 {
4969     dTHX;
4970     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4971     PerlIO_clearerr(f);
4972 }
4973
4974 #undef PerlIO_vprintf
4975 int
4976 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4977 {
4978     dTHX;
4979     SV * sv;
4980     const char *s;
4981     STRLEN len;
4982     SSize_t wrote;
4983 #ifdef NEED_VA_COPY
4984     va_list apc;
4985     Perl_va_copy(ap, apc);
4986     sv = vnewSVpvf(fmt, &apc);
4987 #else
4988     sv = vnewSVpvf(fmt, &ap);
4989 #endif
4990     s = SvPV_const(sv, len);
4991     wrote = PerlIO_write(f, s, len);
4992     SvREFCNT_dec(sv);
4993     return wrote;
4994 }
4995
4996 #undef PerlIO_printf
4997 int
4998 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4999 {
5000     va_list ap;
5001     int result;
5002     va_start(ap, fmt);
5003     result = PerlIO_vprintf(f, fmt, ap);
5004     va_end(ap);
5005     return result;
5006 }
5007
5008 #undef PerlIO_stdoutf
5009 int
5010 PerlIO_stdoutf(const char *fmt, ...)
5011 {
5012     dTHX;
5013     va_list ap;
5014     int result;
5015     va_start(ap, fmt);
5016     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5017     va_end(ap);
5018     return result;
5019 }
5020
5021 #undef PerlIO_tmpfile
5022 PerlIO *
5023 PerlIO_tmpfile(void)
5024 {
5025 #ifndef WIN32
5026      dTHX;
5027 #endif
5028      PerlIO *f = NULL;
5029 #ifdef WIN32
5030      const int fd = win32_tmpfd();
5031      if (fd >= 0)
5032           f = PerlIO_fdopen(fd, "w+b");
5033 #else /* WIN32 */
5034 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5035      int fd = -1;
5036      char tempname[] = "/tmp/PerlIO_XXXXXX";
5037      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5038      SV * sv = NULL;
5039      /*
5040       * I have no idea how portable mkstemp() is ... NI-S
5041       */
5042      if (tmpdir && *tmpdir) {
5043          /* if TMPDIR is set and not empty, we try that first */
5044          sv = newSVpv(tmpdir, 0);
5045          sv_catpv(sv, tempname + 4);
5046          fd = mkstemp(SvPVX(sv));
5047      }
5048      if (fd < 0) {
5049          sv = NULL;
5050          /* else we try /tmp */
5051          fd = mkstemp(tempname);
5052      }
5053      if (fd >= 0) {
5054           f = PerlIO_fdopen(fd, "w+");
5055           if (f)
5056                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5057           PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5058      }
5059      SvREFCNT_dec(sv);
5060 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5061      FILE * const stdio = PerlSIO_tmpfile();
5062
5063      if (stdio)
5064           f = PerlIO_fdopen(fileno(stdio), "w+");
5065
5066 #    endif /* else HAS_MKSTEMP */
5067 #endif /* else WIN32 */
5068      return f;
5069 }
5070
5071 #undef HAS_FSETPOS
5072 #undef HAS_FGETPOS
5073
5074 #endif                          /* USE_SFIO */
5075 #endif                          /* PERLIO_IS_STDIO */
5076
5077 /*======================================================================================*/
5078 /*
5079  * Now some functions in terms of above which may be needed even if we are
5080  * not in true PerlIO mode
5081  */
5082 const char *
5083 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5084 {
5085     dVAR;
5086     const char *direction = NULL;
5087     SV *layers;
5088     /*
5089      * Need to supply default layer info from open.pm
5090      */
5091
5092     if (!PL_curcop)
5093         return NULL;
5094
5095     if (mode && mode[0] != 'r') {
5096         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5097             direction = "open>";
5098     } else {
5099         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5100             direction = "open<";
5101     }
5102     if (!direction)
5103         return NULL;
5104
5105     layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5106
5107     assert(layers);
5108     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5109 }
5110
5111
5112 #ifndef HAS_FSETPOS
5113 #undef PerlIO_setpos
5114 int
5115 PerlIO_setpos(PerlIO *f, SV *pos)
5116 {
5117     if (SvOK(pos)) {
5118         STRLEN len;
5119         dTHX;
5120         const Off_t * const posn = (Off_t *) SvPV(pos, len);
5121         if (f && len == sizeof(Off_t))
5122             return PerlIO_seek(f, *posn, SEEK_SET);
5123     }
5124     SETERRNO(EINVAL, SS_IVCHAN);
5125     return -1;
5126 }
5127 #else
5128 #undef PerlIO_setpos
5129 int
5130 PerlIO_setpos(PerlIO *f, SV *pos)
5131 {
5132     dTHX;
5133     if (SvOK(pos)) {
5134         STRLEN len;
5135         Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5136         if (f && len == sizeof(Fpos_t)) {
5137 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5138             return fsetpos64(f, fpos);
5139 #else
5140             return fsetpos(f, fpos);
5141 #endif
5142         }
5143     }
5144     SETERRNO(EINVAL, SS_IVCHAN);
5145     return -1;
5146 }
5147 #endif
5148
5149 #ifndef HAS_FGETPOS
5150 #undef PerlIO_getpos
5151 int
5152 PerlIO_getpos(PerlIO *f, SV *pos)
5153 {
5154     dTHX;
5155     Off_t posn = PerlIO_tell(f);
5156     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5157     return (posn == (Off_t) - 1) ? -1 : 0;
5158 }
5159 #else
5160 #undef PerlIO_getpos
5161 int
5162 PerlIO_getpos(PerlIO *f, SV *pos)
5163 {
5164     dTHX;
5165     Fpos_t fpos;
5166     int code;
5167 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5168     code = fgetpos64(f, &fpos);
5169 #else
5170     code = fgetpos(f, &fpos);
5171 #endif
5172     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5173     return code;
5174 }
5175 #endif
5176
5177 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5178
5179 int
5180 vprintf(char *pat, char *args)
5181 {
5182     _doprnt(pat, args, stdout);
5183     return 0;                   /* wrong, but perl doesn't use the return
5184                                  * value */
5185 }
5186
5187 int
5188 vfprintf(FILE *fd, char *pat, char *args)
5189 {
5190     _doprnt(pat, args, fd);
5191     return 0;                   /* wrong, but perl doesn't use the return
5192                                  * value */
5193 }
5194
5195 #endif
5196
5197 #ifndef PerlIO_vsprintf
5198 int
5199 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5200 {
5201     dTHX;
5202     const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5203     PERL_UNUSED_CONTEXT;
5204
5205 #ifndef PERL_MY_VSNPRINTF_GUARDED
5206     if (val < 0 || (n > 0 ? val >= n : 0)) {
5207         Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5208     }
5209 #endif
5210     return val;
5211 }
5212 #endif
5213
5214 #ifndef PerlIO_sprintf
5215 int
5216 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5217 {
5218     va_list ap;
5219     int result;
5220     va_start(ap, fmt);
5221     result = PerlIO_vsprintf(s, n, fmt, ap);
5222     va_end(ap);
5223     return result;
5224 }
5225 #endif
5226
5227 /*
5228  * Local variables:
5229  * c-indentation-style: bsd
5230  * c-basic-offset: 4
5231  * indent-tabs-mode: nil
5232  * End:
5233  *
5234  * ex: set ts=8 sts=4 sw=4 et:
5235  */