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