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(HAS_FDCLOSE)
3130     return fdclose(f, NULL) == 0 ? 1 : 0;
3131 #  elif defined(__UCLIBC__)
3132     /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3133     f->__filedes = -1;
3134     return 1;
3135 #  elif defined(__GLIBC__)
3136     /* There may be a better way for GLIBC:
3137         - libio.h defines a flag to not close() on cleanup
3138      */
3139     f->_fileno = -1;
3140     return 1;
3141 #  elif defined(__sun)
3142     PERL_UNUSED_ARG(f);
3143     return 0;
3144 #  elif defined(__hpux)
3145     f->__fileH = 0xff;
3146     f->__fileL = 0xff;
3147     return 1;
3148    /* Next one ->_file seems to be a reasonable fallback, i.e. if
3149       your platform does not have special entry try this one.
3150       [For OSF only have confirmation for Tru64 (alpha)
3151       but assume other OSFs will be similar.]
3152     */
3153 #  elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3154     f->_file = -1;
3155     return 1;
3156 #  elif defined(__FreeBSD__)
3157     /* There may be a better way on FreeBSD:
3158         - we could insert a dummy func in the _close function entry
3159         f->_close = (int (*)(void *)) dummy_close;
3160      */
3161     f->_file = -1;
3162     return 1;
3163 #  elif defined(__OpenBSD__)
3164     /* There may be a better way on OpenBSD:
3165         - we could insert a dummy func in the _close function entry
3166         f->_close = (int (*)(void *)) dummy_close;
3167      */
3168     f->_file = -1;
3169     return 1;
3170 #  elif defined(__EMX__)
3171     /* f->_flags &= ~_IOOPEN; */        /* Will leak stream->_buffer */
3172     f->_handle = -1;
3173     return 1;
3174 #  elif defined(__CYGWIN__)
3175     /* There may be a better way on CYGWIN:
3176         - we could insert a dummy func in the _close function entry
3177         f->_close = (int (*)(void *)) dummy_close;
3178      */
3179     f->_file = -1;
3180     return 1;
3181 #  elif defined(WIN32)
3182 #    if defined(UNDER_CE)
3183     /* WIN_CE does not have access to FILE internals, it hardly has FILE
3184        structure at all
3185      */
3186 #    else
3187     f->_file = -1;
3188 #    endif
3189     return 1;
3190 #  else
3191 #if 0
3192     /* Sarathy's code did this - we fall back to a dup/dup2 hack
3193        (which isn't thread safe) instead
3194      */
3195 #    error "Don't know how to set FILE.fileno on your platform"
3196 #endif
3197     PERL_UNUSED_ARG(f);
3198     return 0;
3199 #  endif
3200 }
3201
3202 IV
3203 PerlIOStdio_close(pTHX_ PerlIO *f)
3204 {
3205     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3206     if (!stdio) {
3207         errno = EBADF;
3208         return -1;
3209     }
3210     else {
3211         const int fd = fileno(stdio);
3212         int invalidate = 0;
3213         IV result = 0;
3214         int dupfd = -1;
3215         dSAVEDERRNO;
3216 #ifdef USE_ITHREADS
3217         dVAR;
3218 #endif
3219 #ifdef SOCKS5_VERSION_NAME
3220         /* Socks lib overrides close() but stdio isn't linked to
3221            that library (though we are) - so we must call close()
3222            on sockets on stdio's behalf.
3223          */
3224         int optval;
3225         Sock_size_t optlen = sizeof(int);
3226         if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3227             invalidate = 1;
3228 #endif
3229         /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3230            that a subsequent fileno() on it returns -1. Don't want to croak()
3231            from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3232            trying to close an already closed handle which somehow it still has
3233            a reference to. (via.xs, I'm looking at you).  */
3234         if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3235             /* File descriptor still in use */
3236             invalidate = 1;
3237         }
3238         if (invalidate) {
3239             /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3240             if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3241                 return 0;
3242             if (stdio == stdout || stdio == stderr)
3243                 return PerlIO_flush(f);
3244         }
3245 #ifdef USE_ITHREADS
3246         MUTEX_LOCK(&PL_perlio_mutex);
3247         /* Right. We need a mutex here because for a brief while we
3248            will have the situation that fd is actually closed. Hence if
3249            a second thread were to get into this block, its dup() would
3250            likely return our fd as its dupfd. (after all, it is closed)
3251            Then if we get to the dup2() first, we blat the fd back
3252            (messing up its temporary as a side effect) only for it to
3253            then close its dupfd (== our fd) in its close(dupfd) */
3254
3255         /* There is, of course, a race condition, that any other thread
3256            trying to input/output/whatever on this fd will be stuffed
3257            for the duration of this little manoeuvrer. Perhaps we
3258            should hold an IO mutex for the duration of every IO
3259            operation if we know that invalidate doesn't work on this
3260            platform, but that would suck, and could kill performance.
3261
3262            Except that correctness trumps speed.
3263            Advice from klortho #11912. */
3264 #endif
3265         if (invalidate) {
3266             /* Tricky - must fclose(stdio) to free memory but not close(fd)
3267                Use Sarathy's trick from maint-5.6 to invalidate the
3268                fileno slot of the FILE *
3269             */
3270             result = PerlIO_flush(f);
3271             SAVE_ERRNO;
3272             invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3273             if (!invalidate) {
3274                 dupfd = PerlLIO_dup(fd);
3275 #ifdef USE_ITHREADS
3276                 if (dupfd < 0) {
3277                     /* Oh cXap. This isn't going to go well. Not sure if we can
3278                        recover from here, or if closing this particular FILE *
3279                        is a good idea now.  */
3280                 }
3281 #endif
3282             }
3283         } else {
3284             SAVE_ERRNO;   /* This is here only to silence compiler warnings */
3285         }
3286         result = PerlSIO_fclose(stdio);
3287         /* We treat error from stdio as success if we invalidated
3288            errno may NOT be expected EBADF
3289          */
3290         if (invalidate && result != 0) {
3291             RESTORE_ERRNO;
3292             result = 0;
3293         }
3294 #ifdef SOCKS5_VERSION_NAME
3295         /* in SOCKS' case, let close() determine return value */
3296         result = close(fd);
3297 #endif
3298         if (dupfd >= 0) {
3299             PerlLIO_dup2(dupfd,fd);
3300             PerlLIO_close(dupfd);
3301         }
3302 #ifdef USE_ITHREADS
3303         MUTEX_UNLOCK(&PL_perlio_mutex);
3304 #endif
3305         return result;
3306     }
3307 }
3308
3309 SSize_t
3310 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3311 {
3312     FILE * s;
3313     SSize_t got = 0;
3314     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3315         return -1;
3316     s = PerlIOSelf(f, PerlIOStdio)->stdio;
3317     for (;;) {
3318         if (count == 1) {
3319             STDCHAR *buf = (STDCHAR *) vbuf;
3320             /*
3321              * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3322              * stdio does not do that for fread()
3323              */
3324             const int ch = PerlSIO_fgetc(s);
3325             if (ch != EOF) {
3326                 *buf = ch;
3327                 got = 1;
3328             }
3329         }
3330         else
3331             got = PerlSIO_fread(vbuf, 1, count, s);
3332         if (got == 0 && PerlSIO_ferror(s))
3333             got = -1;
3334         if (got >= 0 || errno != EINTR)
3335             break;
3336         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3337             return -1;
3338         SETERRNO(0,0);  /* just in case */
3339     }
3340 #ifdef __sgi
3341     /* Under some circumstances IRIX stdio fgetc() and fread()
3342      * set the errno to ENOENT, which makes no sense according
3343      * to either IRIX or POSIX.  [rt.perl.org #123977] */
3344     if (errno == ENOENT) SETERRNO(0,0);
3345 #endif
3346     return got;
3347 }
3348
3349 SSize_t
3350 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3351 {
3352     SSize_t unread = 0;
3353     FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3354
3355 #ifdef STDIO_BUFFER_WRITABLE
3356     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3357         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3358         STDCHAR *base = PerlIO_get_base(f);
3359         SSize_t cnt   = PerlIO_get_cnt(f);
3360         STDCHAR *ptr  = PerlIO_get_ptr(f);
3361         SSize_t avail = ptr - base;
3362         if (avail > 0) {
3363             if (avail > count) {
3364                 avail = count;
3365             }
3366             ptr -= avail;
3367             Move(buf-avail,ptr,avail,STDCHAR);
3368             count -= avail;
3369             unread += avail;
3370             PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3371             if (PerlSIO_feof(s) && unread >= 0)
3372                 PerlSIO_clearerr(s);
3373         }
3374     }
3375     else
3376 #endif
3377     if (PerlIO_has_cntptr(f)) {
3378         /* We can get pointer to buffer but not its base
3379            Do ungetc() but check chars are ending up in the
3380            buffer
3381          */
3382         STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3383         STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3384         while (count > 0) {
3385             const int ch = *--buf & 0xFF;
3386             if (ungetc(ch,s) != ch) {
3387                 /* ungetc did not work */
3388                 break;
3389             }
3390             if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3391                 /* Did not change pointer as expected */
3392                 if (fgetc(s) != EOF)  /* get char back again */
3393                     break;
3394             }
3395             /* It worked ! */
3396             count--;
3397             unread++;
3398         }
3399     }
3400
3401     if (count > 0) {
3402         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3403     }
3404     return unread;
3405 }
3406
3407 SSize_t
3408 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3409 {
3410     SSize_t got;
3411     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3412         return -1;
3413     for (;;) {
3414         got = PerlSIO_fwrite(vbuf, 1, count,
3415                               PerlIOSelf(f, PerlIOStdio)->stdio);
3416         if (got >= 0 || errno != EINTR)
3417             break;
3418         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3419             return -1;
3420         SETERRNO(0,0);  /* just in case */
3421     }
3422     return got;
3423 }
3424
3425 IV
3426 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3427 {
3428     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3429     PERL_UNUSED_CONTEXT;
3430
3431     return PerlSIO_fseek(stdio, offset, whence);
3432 }
3433
3434 Off_t
3435 PerlIOStdio_tell(pTHX_ PerlIO *f)
3436 {
3437     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3438     PERL_UNUSED_CONTEXT;
3439
3440     return PerlSIO_ftell(stdio);
3441 }
3442
3443 IV
3444 PerlIOStdio_flush(pTHX_ PerlIO *f)
3445 {
3446     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3447     PERL_UNUSED_CONTEXT;
3448
3449     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3450         return PerlSIO_fflush(stdio);
3451     }
3452     else {
3453         NOOP;
3454 #if 0
3455         /*
3456          * FIXME: This discards ungetc() and pre-read stuff which is not
3457          * right if this is just a "sync" from a layer above Suspect right
3458          * design is to do _this_ but not have layer above flush this
3459          * layer read-to-read
3460          */
3461         /*
3462          * Not writeable - sync by attempting a seek
3463          */
3464         dSAVE_ERRNO;
3465         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3466             RESTORE_ERRNO;
3467 #endif
3468     }
3469     return 0;
3470 }
3471
3472 IV
3473 PerlIOStdio_eof(pTHX_ PerlIO *f)
3474 {
3475     PERL_UNUSED_CONTEXT;
3476
3477     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3478 }
3479
3480 IV
3481 PerlIOStdio_error(pTHX_ PerlIO *f)
3482 {
3483     PERL_UNUSED_CONTEXT;
3484
3485     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3486 }
3487
3488 void
3489 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3490 {
3491     PERL_UNUSED_CONTEXT;
3492
3493     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3494 }
3495
3496 void
3497 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3498 {
3499     PERL_UNUSED_CONTEXT;
3500
3501 #ifdef HAS_SETLINEBUF
3502     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3503 #else
3504     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3505 #endif
3506 }
3507
3508 #ifdef FILE_base
3509 STDCHAR *
3510 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3511 {
3512     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3513     return (STDCHAR*)PerlSIO_get_base(stdio);
3514 }
3515
3516 Size_t
3517 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3518 {
3519     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3520     return PerlSIO_get_bufsiz(stdio);
3521 }
3522 #endif
3523
3524 #ifdef USE_STDIO_PTR
3525 STDCHAR *
3526 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3527 {
3528     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3529     return (STDCHAR*)PerlSIO_get_ptr(stdio);
3530 }
3531
3532 SSize_t
3533 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3534 {
3535     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3536     return PerlSIO_get_cnt(stdio);
3537 }
3538
3539 void
3540 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3541 {
3542     FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3543     if (ptr != NULL) {
3544 #ifdef STDIO_PTR_LVALUE
3545         /* This is a long-standing infamous mess.  The root of the
3546          * problem is that one cannot know the signedness of char, and
3547          * more precisely the signedness of FILE._ptr.  The following
3548          * things have been tried, and they have all failed (across
3549          * different compilers (remember that core needs to to build
3550          * also with c++) and compiler options:
3551          *
3552          * - casting the RHS to (void*) -- works in *some* places
3553          * - casting the LHS to (void*) -- totally unportable
3554          *
3555          * So let's try silencing the warning at least for gcc. */
3556         GCC_DIAG_IGNORE(-Wpointer-sign);
3557         PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3558         GCC_DIAG_RESTORE;
3559 #ifdef STDIO_PTR_LVAL_SETS_CNT
3560         assert(PerlSIO_get_cnt(stdio) == (cnt));
3561 #endif
3562 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3563         /*
3564          * Setting ptr _does_ change cnt - we are done
3565          */
3566         return;
3567 #endif
3568 #else                           /* STDIO_PTR_LVALUE */
3569         PerlProc_abort();
3570 #endif                          /* STDIO_PTR_LVALUE */
3571     }
3572     /*
3573      * Now (or only) set cnt
3574      */
3575 #ifdef STDIO_CNT_LVALUE
3576     PerlSIO_set_cnt(stdio, cnt);
3577 #else                           /* STDIO_CNT_LVALUE */
3578 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3579     PerlSIO_set_ptr(stdio,
3580                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3581                                               cnt));
3582 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
3583     PerlProc_abort();
3584 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
3585 #endif                          /* STDIO_CNT_LVALUE */
3586 }
3587
3588
3589 #endif
3590
3591 IV
3592 PerlIOStdio_fill(pTHX_ PerlIO *f)
3593 {
3594     FILE * stdio;
3595     int c;
3596     PERL_UNUSED_CONTEXT;
3597     if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3598         return -1;
3599     stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3600
3601     /*
3602      * fflush()ing read-only streams can cause trouble on some stdio-s
3603      */
3604     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3605         if (PerlSIO_fflush(stdio) != 0)
3606             return EOF;
3607     }
3608     for (;;) {
3609         c = PerlSIO_fgetc(stdio);
3610         if (c != EOF)
3611             break;
3612         if (! PerlSIO_ferror(stdio) || errno != EINTR)
3613             return EOF;
3614         if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3615             return -1;
3616         SETERRNO(0,0);
3617     }
3618
3619 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3620
3621 #ifdef STDIO_BUFFER_WRITABLE
3622     if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3623         /* Fake ungetc() to the real buffer in case system's ungetc
3624            goes elsewhere
3625          */
3626         STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3627         SSize_t cnt   = PerlSIO_get_cnt(stdio);
3628         STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
3629         if (ptr == base+1) {
3630             *--ptr = (STDCHAR) c;
3631             PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3632             if (PerlSIO_feof(stdio))
3633                 PerlSIO_clearerr(stdio);
3634             return 0;
3635         }
3636     }
3637     else
3638 #endif
3639     if (PerlIO_has_cntptr(f)) {
3640         STDCHAR ch = c;
3641         if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3642             return 0;
3643         }
3644     }
3645 #endif
3646
3647     /* If buffer snoop scheme above fails fall back to
3648        using ungetc().
3649      */
3650     if (PerlSIO_ungetc(c, stdio) != c)
3651         return EOF;
3652
3653     return 0;
3654 }
3655
3656
3657
3658 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3659     sizeof(PerlIO_funcs),
3660     "stdio",
3661     sizeof(PerlIOStdio),
3662     PERLIO_K_BUFFERED|PERLIO_K_RAW,
3663     PerlIOStdio_pushed,
3664     PerlIOBase_popped,
3665     PerlIOStdio_open,
3666     PerlIOBase_binmode,         /* binmode */
3667     NULL,
3668     PerlIOStdio_fileno,
3669     PerlIOStdio_dup,
3670     PerlIOStdio_read,
3671     PerlIOStdio_unread,
3672     PerlIOStdio_write,
3673     PerlIOStdio_seek,
3674     PerlIOStdio_tell,
3675     PerlIOStdio_close,
3676     PerlIOStdio_flush,
3677     PerlIOStdio_fill,
3678     PerlIOStdio_eof,
3679     PerlIOStdio_error,
3680     PerlIOStdio_clearerr,
3681     PerlIOStdio_setlinebuf,
3682 #ifdef FILE_base
3683     PerlIOStdio_get_base,
3684     PerlIOStdio_get_bufsiz,
3685 #else
3686     NULL,
3687     NULL,
3688 #endif
3689 #ifdef USE_STDIO_PTR
3690     PerlIOStdio_get_ptr,
3691     PerlIOStdio_get_cnt,
3692 #   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3693     PerlIOStdio_set_ptrcnt,
3694 #   else
3695     NULL,
3696 #   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3697 #else
3698     NULL,
3699     NULL,
3700     NULL,
3701 #endif /* USE_STDIO_PTR */
3702 };
3703
3704 /* Note that calls to PerlIO_exportFILE() are reversed using
3705  * PerlIO_releaseFILE(), not importFILE. */
3706 FILE *
3707 PerlIO_exportFILE(PerlIO * f, const char *mode)
3708 {
3709     dTHX;
3710     FILE *stdio = NULL;
3711     if (PerlIOValid(f)) {
3712         char buf[8];
3713         int fd = PerlIO_fileno(f);
3714         if (fd < 0) {
3715             return NULL;
3716         }
3717         PerlIO_flush(f);
3718         if (!mode || !*mode) {
3719             mode = PerlIO_modestr(f, buf);
3720         }
3721         stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3722         if (stdio) {
3723             PerlIOl *l = *f;
3724             PerlIO *f2;
3725             /* De-link any lower layers so new :stdio sticks */
3726             *f = NULL;
3727             if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3728                 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3729                 s->stdio = stdio;
3730                 PerlIOUnix_refcnt_inc(fileno(stdio));
3731                 /* Link previous lower layers under new one */
3732                 *PerlIONext(f) = l;
3733             }
3734             else {
3735                 /* restore layers list */
3736                 *f = l;
3737             }
3738         }
3739     }
3740     return stdio;
3741 }
3742
3743
3744 FILE *
3745 PerlIO_findFILE(PerlIO *f)
3746 {
3747     PerlIOl *l = *f;
3748     FILE *stdio;
3749     while (l) {
3750         if (l->tab == &PerlIO_stdio) {
3751             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3752             return s->stdio;
3753         }
3754         l = *PerlIONext(&l);
3755     }
3756     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3757     /* However, we're not really exporting a FILE * to someone else (who
3758        becomes responsible for closing it, or calling PerlIO_releaseFILE())
3759        So we need to undo its reference count increase on the underlying file
3760        descriptor. We have to do this, because if the loop above returns you
3761        the FILE *, then *it* didn't increase any reference count. So there's
3762        only one way to be consistent. */
3763     stdio = PerlIO_exportFILE(f, NULL);
3764     if (stdio) {
3765         const int fd = fileno(stdio);
3766         if (fd >= 0)
3767             PerlIOUnix_refcnt_dec(fd);
3768     }
3769     return stdio;
3770 }
3771
3772 /* Use this to reverse PerlIO_exportFILE calls. */
3773 void
3774 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3775 {
3776     PerlIOl *l;
3777     while ((l = *p)) {
3778         if (l->tab == &PerlIO_stdio) {
3779             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3780             if (s->stdio == f) { /* not in a loop */
3781                 const int fd = fileno(f);
3782                 if (fd >= 0)
3783                     PerlIOUnix_refcnt_dec(fd);
3784                 {
3785                     dTHX;
3786                     PerlIO_pop(aTHX_ p);
3787                 }
3788                 return;
3789             }
3790         }
3791         p = PerlIONext(p);
3792     }
3793     return;
3794 }
3795
3796 /*--------------------------------------------------------------------------------------*/
3797 /*
3798  * perlio buffer layer
3799  */
3800
3801 IV
3802 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3803 {
3804     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3805     const int fd = PerlIO_fileno(f);
3806     if (fd >= 0 && PerlLIO_isatty(fd)) {
3807         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3808     }
3809     if (*PerlIONext(f)) {
3810         const Off_t posn = PerlIO_tell(PerlIONext(f));
3811         if (posn != (Off_t) - 1) {
3812             b->posn = posn;
3813         }
3814     }
3815     return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3816 }
3817
3818 PerlIO *
3819 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3820                IV n, const char *mode, int fd, int imode, int perm,
3821                PerlIO *f, int narg, SV **args)
3822 {
3823     if (PerlIOValid(f)) {
3824         PerlIO *next = PerlIONext(f);
3825         PerlIO_funcs *tab =
3826              PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3827         if (tab && tab->Open)
3828              next =
3829                   (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3830                                next, narg, args);
3831         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3832             return NULL;
3833         }
3834     }
3835     else {
3836         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3837         int init = 0;
3838         if (*mode == IoTYPE_IMPLICIT) {
3839             init = 1;
3840             /*
3841              * mode++;
3842              */
3843         }
3844         if (tab && tab->Open)
3845              f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3846                               f, narg, args);
3847         else
3848              SETERRNO(EINVAL, LIB_INVARG);
3849         if (f) {
3850             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3851                 /*
3852                  * if push fails during open, open fails. close will pop us.
3853                  */
3854                 PerlIO_close (f);
3855                 return NULL;
3856             } else {
3857                 fd = PerlIO_fileno(f);
3858                 if (init && fd == 2) {
3859                     /*
3860                      * Initial stderr is unbuffered
3861                      */
3862                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3863                 }
3864 #ifdef PERLIO_USING_CRLF
3865 #  ifdef PERLIO_IS_BINMODE_FD
3866                 if (PERLIO_IS_BINMODE_FD(fd))
3867                     PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, NULL);
3868                 else
3869 #  endif
3870                 /*
3871                  * do something about failing setmode()? --jhi
3872                  */
3873                 PerlLIO_setmode(fd, O_BINARY);
3874 #endif
3875 #ifdef VMS
3876                 /* Enable line buffering with record-oriented regular files
3877                  * so we don't introduce an extraneous record boundary when
3878                  * the buffer fills up.
3879                  */
3880                 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3881                     Stat_t st;
3882                     if (PerlLIO_fstat(fd, &st) == 0
3883                         && S_ISREG(st.st_mode)
3884                         && (st.st_fab_rfm == FAB$C_VAR
3885                             || st.st_fab_rfm == FAB$C_VFC)) {
3886                         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3887                     }
3888                 }
3889 #endif
3890             }
3891         }
3892     }
3893     return f;
3894 }
3895
3896 /*
3897  * This "flush" is akin to sfio's sync in that it handles files in either
3898  * read or write state.  For write state, we put the postponed data through
3899  * the next layers.  For read state, we seek() the next layers to the
3900  * offset given by current position in the buffer, and discard the buffer
3901  * state (XXXX supposed to be for seek()able buffers only, but now it is done
3902  * in any case?).  Then the pass the stick further in chain.
3903  */
3904 IV
3905 PerlIOBuf_flush(pTHX_ PerlIO *f)
3906 {
3907     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3908     int code = 0;
3909     PerlIO *n = PerlIONext(f);
3910     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3911         /*
3912          * write() the buffer
3913          */
3914         const STDCHAR *buf = b->buf;
3915         const STDCHAR *p = buf;
3916         while (p < b->ptr) {
3917             SSize_t count = PerlIO_write(n, p, b->ptr - p);
3918             if (count > 0) {
3919                 p += count;
3920             }
3921             else if (count < 0 || PerlIO_error(n)) {
3922                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3923                 PerlIO_save_errno(f);
3924                 code = -1;
3925                 break;
3926             }
3927         }
3928         b->posn += (p - buf);
3929     }
3930     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3931         STDCHAR *buf = PerlIO_get_base(f);
3932         /*
3933          * Note position change
3934          */
3935         b->posn += (b->ptr - buf);
3936         if (b->ptr < b->end) {
3937             /* We did not consume all of it - try and seek downstream to
3938                our logical position
3939              */
3940             if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3941                 /* Reload n as some layers may pop themselves on seek */
3942                 b->posn = PerlIO_tell(n = PerlIONext(f));
3943             }
3944             else {
3945                 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3946                    data is lost for good - so return saying "ok" having undone
3947                    the position adjust
3948                  */
3949                 b->posn -= (b->ptr - buf);
3950                 return code;
3951             }
3952         }
3953     }
3954     b->ptr = b->end = b->buf;
3955     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3956     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3957     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3958         code = -1;
3959     return code;
3960 }
3961
3962 /* This discards the content of the buffer after b->ptr, and rereads
3963  * the buffer from the position off in the layer downstream; here off
3964  * is at offset corresponding to b->ptr - b->buf.
3965  */
3966 IV
3967 PerlIOBuf_fill(pTHX_ PerlIO *f)
3968 {
3969     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3970     PerlIO *n = PerlIONext(f);
3971     SSize_t avail;
3972     /*
3973      * Down-stream flush is defined not to loose read data so is harmless.
3974      * we would not normally be fill'ing if there was data left in anycase.
3975      */
3976     if (PerlIO_flush(f) != 0)   /* XXXX Check that its seek() succeeded?! */
3977         return -1;
3978     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3979         PerlIOBase_flush_linebuf(aTHX);
3980
3981     if (!b->buf)
3982         PerlIO_get_base(f);     /* allocate via vtable */
3983
3984     assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3985
3986     b->ptr = b->end = b->buf;
3987
3988     if (!PerlIOValid(n)) {
3989         PerlIOBase(f)->flags |= PERLIO_F_EOF;
3990         return -1;
3991     }
3992
3993     if (PerlIO_fast_gets(n)) {
3994         /*
3995          * Layer below is also buffered. We do _NOT_ want to call its
3996          * ->Read() because that will loop till it gets what we asked for
3997          * which may hang on a pipe etc. Instead take anything it has to
3998          * hand, or ask it to fill _once_.
3999          */
4000         avail = PerlIO_get_cnt(n);
4001         if (avail <= 0) {
4002             avail = PerlIO_fill(n);
4003             if (avail == 0)
4004                 avail = PerlIO_get_cnt(n);
4005             else {
4006                 if (!PerlIO_error(n) && PerlIO_eof(n))
4007                     avail = 0;
4008             }
4009         }
4010         if (avail > 0) {
4011             STDCHAR *ptr = PerlIO_get_ptr(n);
4012             const SSize_t cnt = avail;
4013             if (avail > (SSize_t)b->bufsiz)
4014                 avail = b->bufsiz;
4015             Copy(ptr, b->buf, avail, STDCHAR);
4016             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4017         }
4018     }
4019     else {
4020         avail = PerlIO_read(n, b->ptr, b->bufsiz);
4021     }
4022     if (avail <= 0) {
4023         if (avail == 0)
4024             PerlIOBase(f)->flags |= PERLIO_F_EOF;
4025         else
4026         {
4027             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4028             PerlIO_save_errno(f);
4029         }
4030         return -1;
4031     }
4032     b->end = b->buf + avail;
4033     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4034     return 0;
4035 }
4036
4037 SSize_t
4038 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4039 {
4040     if (PerlIOValid(f)) {
4041         const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4042         if (!b->ptr)
4043             PerlIO_get_base(f);
4044         return PerlIOBase_read(aTHX_ f, vbuf, count);
4045     }
4046     return 0;
4047 }
4048
4049 SSize_t
4050 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4051 {
4052     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4053     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4054     SSize_t unread = 0;
4055     SSize_t avail;
4056     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4057         PerlIO_flush(f);
4058     if (!b->buf)
4059         PerlIO_get_base(f);
4060     if (b->buf) {
4061         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4062             /*
4063              * Buffer is already a read buffer, we can overwrite any chars
4064              * which have been read back to buffer start
4065              */
4066             avail = (b->ptr - b->buf);
4067         }
4068         else {
4069             /*
4070              * Buffer is idle, set it up so whole buffer is available for
4071              * unread
4072              */
4073             avail = b->bufsiz;
4074             b->end = b->buf + avail;
4075             b->ptr = b->end;
4076             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4077             /*
4078              * Buffer extends _back_ from where we are now
4079              */
4080             b->posn -= b->bufsiz;
4081         }
4082         if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4083             /*
4084              * If we have space for more than count, just move count
4085              */
4086             avail = count;
4087         }
4088         if (avail > 0) {
4089             b->ptr -= avail;
4090             buf -= avail;
4091             /*
4092              * In simple stdio-like ungetc() case chars will be already
4093              * there
4094              */
4095             if (buf != b->ptr) {
4096                 Copy(buf, b->ptr, avail, STDCHAR);
4097             }
4098             count -= avail;
4099             unread += avail;
4100             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4101         }
4102     }
4103     if (count > 0) {
4104         unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4105     }
4106     return unread;
4107 }
4108
4109 SSize_t
4110 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4111 {
4112     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4113     const STDCHAR *buf = (const STDCHAR *) vbuf;
4114     const STDCHAR *flushptr = buf;
4115     Size_t written = 0;
4116     if (!b->buf)
4117         PerlIO_get_base(f);
4118     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4119         return 0;
4120     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4121         if (PerlIO_flush(f) != 0) {
4122             return 0;
4123         }
4124     }
4125     if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4126         flushptr = buf + count;
4127         while (flushptr > buf && *(flushptr - 1) != '\n')
4128             --flushptr;
4129     }
4130     while (count > 0) {
4131         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4132         if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4133             avail = count;
4134         if (flushptr > buf && flushptr <= buf + avail)
4135             avail = flushptr - buf;
4136         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4137         if (avail) {
4138             Copy(buf, b->ptr, avail, STDCHAR);
4139             count -= avail;
4140             buf += avail;
4141             written += avail;
4142             b->ptr += avail;
4143             if (buf == flushptr)
4144                 PerlIO_flush(f);
4145         }
4146         if (b->ptr >= (b->buf + b->bufsiz))
4147             if (PerlIO_flush(f) == -1)
4148                 return -1;
4149     }
4150     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4151         PerlIO_flush(f);
4152     return written;
4153 }
4154
4155 IV
4156 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4157 {
4158     IV code;
4159     if ((code = PerlIO_flush(f)) == 0) {
4160         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4161         code = PerlIO_seek(PerlIONext(f), offset, whence);
4162         if (code == 0) {
4163             PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4164             b->posn = PerlIO_tell(PerlIONext(f));
4165         }
4166     }
4167     return code;
4168 }
4169
4170 Off_t
4171 PerlIOBuf_tell(pTHX_ PerlIO *f)
4172 {
4173     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4174     /*
4175      * b->posn is file position where b->buf was read, or will be written
4176      */
4177     Off_t posn = b->posn;
4178     if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4179         (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4180 #if 1
4181         /* As O_APPEND files are normally shared in some sense it is better
4182            to flush :
4183          */
4184         PerlIO_flush(f);
4185 #else
4186         /* when file is NOT shared then this is sufficient */
4187         PerlIO_seek(PerlIONext(f),0, SEEK_END);
4188 #endif
4189         posn = b->posn = PerlIO_tell(PerlIONext(f));
4190     }
4191     if (b->buf) {
4192         /*
4193          * If buffer is valid adjust position by amount in buffer
4194          */
4195         posn += (b->ptr - b->buf);
4196     }
4197     return posn;
4198 }
4199
4200 IV
4201 PerlIOBuf_popped(pTHX_ PerlIO *f)
4202 {
4203     const IV code = PerlIOBase_popped(aTHX_ f);
4204     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4205     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4206         Safefree(b->buf);
4207     }
4208     b->ptr = b->end = b->buf = NULL;
4209     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4210     return code;
4211 }
4212
4213 IV
4214 PerlIOBuf_close(pTHX_ PerlIO *f)
4215 {
4216     const IV code = PerlIOBase_close(aTHX_ f);
4217     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4218     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4219         Safefree(b->buf);
4220     }
4221     b->ptr = b->end = b->buf = NULL;
4222     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4223     return code;
4224 }
4225
4226 STDCHAR *
4227 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4228 {
4229     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4230     if (!b->buf)
4231         PerlIO_get_base(f);
4232     return b->ptr;
4233 }
4234
4235 SSize_t
4236 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4237 {
4238     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4239     if (!b->buf)
4240         PerlIO_get_base(f);
4241     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4242         return (b->end - b->ptr);
4243     return 0;
4244 }
4245
4246 STDCHAR *
4247 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4248 {
4249     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4250     PERL_UNUSED_CONTEXT;
4251
4252     if (!b->buf) {
4253         if (!b->bufsiz)
4254             b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4255         Newxz(b->buf,b->bufsiz, STDCHAR);
4256         if (!b->buf) {
4257             b->buf = (STDCHAR *) & b->oneword;
4258             b->bufsiz = sizeof(b->oneword);
4259         }
4260         b->end = b->ptr = b->buf;
4261     }
4262     return b->buf;
4263 }
4264
4265 Size_t
4266 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4267 {
4268     const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4269     if (!b->buf)
4270         PerlIO_get_base(f);
4271     return (b->end - b->buf);
4272 }
4273
4274 void
4275 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4276 {
4277     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4278 #ifndef DEBUGGING
4279     PERL_UNUSED_ARG(cnt);
4280 #endif
4281     if (!b->buf)
4282         PerlIO_get_base(f);
4283     b->ptr = ptr;
4284     assert(PerlIO_get_cnt(f) == cnt);
4285     assert(b->ptr >= b->buf);
4286     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4287 }
4288
4289 PerlIO *
4290 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4291 {
4292  return PerlIOBase_dup(aTHX_ f, o, param, flags);
4293 }
4294
4295
4296
4297 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4298     sizeof(PerlIO_funcs),
4299     "perlio",
4300     sizeof(PerlIOBuf),
4301     PERLIO_K_BUFFERED|PERLIO_K_RAW,
4302     PerlIOBuf_pushed,
4303     PerlIOBuf_popped,
4304     PerlIOBuf_open,
4305     PerlIOBase_binmode,         /* binmode */
4306     NULL,
4307     PerlIOBase_fileno,
4308     PerlIOBuf_dup,
4309     PerlIOBuf_read,
4310     PerlIOBuf_unread,
4311     PerlIOBuf_write,
4312     PerlIOBuf_seek,
4313     PerlIOBuf_tell,
4314     PerlIOBuf_close,
4315     PerlIOBuf_flush,
4316     PerlIOBuf_fill,
4317     PerlIOBase_eof,
4318     PerlIOBase_error,
4319     PerlIOBase_clearerr,
4320     PerlIOBase_setlinebuf,
4321     PerlIOBuf_get_base,
4322     PerlIOBuf_bufsiz,
4323     PerlIOBuf_get_ptr,
4324     PerlIOBuf_get_cnt,
4325     PerlIOBuf_set_ptrcnt,
4326 };
4327
4328 /*--------------------------------------------------------------------------------------*/
4329 /*
4330  * Temp layer to hold unread chars when cannot do it any other way
4331  */
4332
4333 IV
4334 PerlIOPending_fill(pTHX_ PerlIO *f)
4335 {
4336     /*
4337      * Should never happen
4338      */
4339     PerlIO_flush(f);
4340     return 0;
4341 }
4342
4343 IV
4344 PerlIOPending_close(pTHX_ PerlIO *f)
4345 {
4346     /*
4347      * A tad tricky - flush pops us, then we close new top
4348      */
4349     PerlIO_flush(f);
4350     return PerlIO_close(f);
4351 }
4352
4353 IV
4354 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4355 {
4356     /*
4357      * A tad tricky - flush pops us, then we seek new top
4358      */
4359     PerlIO_flush(f);
4360     return PerlIO_seek(f, offset, whence);
4361 }
4362
4363
4364 IV
4365 PerlIOPending_flush(pTHX_ PerlIO *f)
4366 {
4367     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4368     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4369         Safefree(b->buf);
4370         b->buf = NULL;
4371     }
4372     PerlIO_pop(aTHX_ f);
4373     return 0;
4374 }
4375
4376 void
4377 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4378 {
4379     if (cnt <= 0) {
4380         PerlIO_flush(f);
4381     }
4382     else {
4383         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4384     }
4385 }
4386
4387 IV
4388 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4389 {
4390     const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4391     PerlIOl * const l = PerlIOBase(f);
4392     /*
4393      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4394      * etc. get muddled when it changes mid-string when we auto-pop.
4395      */
4396     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4397         (PerlIOBase(PerlIONext(f))->
4398          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4399     return code;
4400 }
4401
4402 SSize_t
4403 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4404 {
4405     SSize_t avail = PerlIO_get_cnt(f);
4406     SSize_t got = 0;
4407     if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4408         avail = count;
4409     if (avail > 0)
4410         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4411     if (got >= 0 && got < (SSize_t)count) {
4412         const SSize_t more =
4413             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4414         if (more >= 0 || got == 0)
4415             got += more;
4416     }
4417     return got;
4418 }
4419
4420 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4421     sizeof(PerlIO_funcs),
4422     "pending",
4423     sizeof(PerlIOBuf),
4424     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
4425     PerlIOPending_pushed,
4426     PerlIOBuf_popped,
4427     NULL,
4428     PerlIOBase_binmode,         /* binmode */
4429     NULL,
4430     PerlIOBase_fileno,
4431     PerlIOBuf_dup,
4432     PerlIOPending_read,
4433     PerlIOBuf_unread,
4434     PerlIOBuf_write,
4435     PerlIOPending_seek,
4436     PerlIOBuf_tell,
4437     PerlIOPending_close,
4438     PerlIOPending_flush,
4439     PerlIOPending_fill,
4440     PerlIOBase_eof,
4441     PerlIOBase_error,
4442     PerlIOBase_clearerr,
4443     PerlIOBase_setlinebuf,
4444     PerlIOBuf_get_base,
4445     PerlIOBuf_bufsiz,
4446     PerlIOBuf_get_ptr,
4447     PerlIOBuf_get_cnt,
4448     PerlIOPending_set_ptrcnt,
4449 };
4450
4451
4452
4453 /*--------------------------------------------------------------------------------------*/
4454 /*
4455  * crlf - translation On read translate CR,LF to "\n" we do this by
4456  * overriding ptr/cnt entries to hand back a line at a time and keeping a
4457  * record of which nl we "lied" about. On write translate "\n" to CR,LF
4458  *
4459  * c->nl points on the first byte of CR LF pair when it is temporarily
4460  * replaced by LF, or to the last CR of the buffer.  In the former case
4461  * the caller thinks that the buffer ends at c->nl + 1, in the latter
4462  * that it ends at c->nl; these two cases can be distinguished by
4463  * *c->nl.  c->nl is set during _getcnt() call, and unset during
4464  * _unread() and _flush() calls.
4465  * It only matters for read operations.
4466  */
4467
4468 typedef struct {
4469     PerlIOBuf base;             /* PerlIOBuf stuff */
4470     STDCHAR *nl;                /* Position of crlf we "lied" about in the
4471                                  * buffer */
4472 } PerlIOCrlf;
4473
4474 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4475  * Otherwise the :crlf layer would always revert back to
4476  * raw mode.
4477  */
4478 static void
4479 S_inherit_utf8_flag(PerlIO *f)
4480 {
4481     PerlIO *g = PerlIONext(f);
4482     if (PerlIOValid(g)) {
4483         if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4484             PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4485         }
4486     }
4487 }
4488
4489 IV
4490 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4491 {
4492     IV code;
4493     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4494     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4495 #if 0
4496     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4497                  (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4498                  PerlIOBase(f)->flags);
4499 #endif
4500     {
4501       /* If the old top layer is a CRLF layer, reactivate it (if
4502        * necessary) and remove this new layer from the stack */
4503          PerlIO *g = PerlIONext(f);
4504          if (PerlIOValid(g)) {
4505               PerlIOl *b = PerlIOBase(g);
4506               if (b && b->tab == &PerlIO_crlf) {
4507                    if (!(b->flags & PERLIO_F_CRLF))
4508                         b->flags |= PERLIO_F_CRLF;
4509                    S_inherit_utf8_flag(g);
4510                    PerlIO_pop(aTHX_ f);
4511                    return code;
4512               }
4513          }
4514     }
4515     S_inherit_utf8_flag(f);
4516     return code;
4517 }
4518
4519
4520 SSize_t
4521 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4522 {
4523     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4524     if (c->nl) {        /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4525         *(c->nl) = NATIVE_0xd;
4526         c->nl = NULL;
4527     }
4528     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4529         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4530     else {
4531         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4532         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4533         SSize_t unread = 0;
4534         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4535             PerlIO_flush(f);
4536         if (!b->buf)
4537             PerlIO_get_base(f);
4538         if (b->buf) {
4539             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4540                 b->end = b->ptr = b->buf + b->bufsiz;
4541                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4542                 b->posn -= b->bufsiz;
4543             }
4544             while (count > 0 && b->ptr > b->buf) {
4545                 const int ch = *--buf;
4546                 if (ch == '\n') {
4547                     if (b->ptr - 2 >= b->buf) {
4548                         *--(b->ptr) = NATIVE_0xa;
4549                         *--(b->ptr) = NATIVE_0xd;
4550                         unread++;
4551                         count--;
4552                     }
4553                     else {
4554                     /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4555                         *--(b->ptr) = NATIVE_0xa;   /* Works even if 0xa ==
4556                                                        '\r' */
4557                         unread++;
4558                         count--;
4559                     }
4560                 }
4561                 else {
4562                     *--(b->ptr) = ch;
4563                     unread++;
4564                     count--;
4565                 }
4566             }
4567         }
4568         if (count > 0)
4569             unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4570         return unread;
4571     }
4572 }
4573
4574 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4575 SSize_t
4576 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4577 {
4578     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4579     if (!b->buf)
4580         PerlIO_get_base(f);
4581     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4582         PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4583         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4584             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4585           scan:
4586             while (nl < b->end && *nl != NATIVE_0xd)
4587                 nl++;
4588             if (nl < b->end && *nl == NATIVE_0xd) {
4589               test:
4590                 if (nl + 1 < b->end) {
4591                     if (nl[1] == NATIVE_0xa) {
4592                         *nl = '\n';
4593                         c->nl = nl;
4594                     }
4595                     else {
4596                         /*
4597                          * Not CR,LF but just CR
4598                          */
4599                         nl++;
4600                         goto scan;
4601                     }
4602                 }
4603                 else {
4604                     /*
4605                      * Blast - found CR as last char in buffer
4606                      */
4607
4608                     if (b->ptr < nl) {
4609                         /*
4610                          * They may not care, defer work as long as
4611                          * possible
4612                          */
4613                         c->nl = nl;
4614                         return (nl - b->ptr);
4615                     }
4616                     else {
4617                         int code;
4618                         b->ptr++;       /* say we have read it as far as
4619                                          * flush() is concerned */
4620                         b->buf++;       /* Leave space in front of buffer */
4621                         /* Note as we have moved buf up flush's
4622                            posn += ptr-buf
4623                            will naturally make posn point at CR
4624                          */
4625                         b->bufsiz--;    /* Buffer is thus smaller */
4626                         code = PerlIO_fill(f);  /* Fetch some more */
4627                         b->bufsiz++;    /* Restore size for next time */
4628                         b->buf--;       /* Point at space */
4629                         b->ptr = nl = b->buf;   /* Which is what we hand
4630                                                  * off */
4631                         *nl = NATIVE_0xd;      /* Fill in the CR */
4632                         if (code == 0)
4633                             goto test;  /* fill() call worked */
4634                         /*
4635                          * CR at EOF - just fall through
4636                          */
4637                         /* Should we clear EOF though ??? */
4638                     }
4639                 }
4640             }
4641         }
4642         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4643     }
4644     return 0;
4645 }
4646
4647 void
4648 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4649 {
4650     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4651     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4652     if (!b->buf)
4653         PerlIO_get_base(f);
4654     if (!ptr) {
4655         if (c->nl) {
4656             ptr = c->nl + 1;
4657             if (ptr == b->end && *c->nl == NATIVE_0xd) {
4658                 /* Deferred CR at end of buffer case - we lied about count */
4659                 ptr--;
4660             }
4661         }
4662         else {
4663             ptr = b->end;
4664         }
4665         ptr -= cnt;
4666     }
4667     else {
4668         NOOP;
4669 #if 0
4670         /*
4671          * Test code - delete when it works ...
4672          */
4673         IV flags = PerlIOBase(f)->flags;
4674         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4675         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4676           /* Deferred CR at end of buffer case - we lied about count */
4677           chk--;
4678         }
4679         chk -= cnt;
4680
4681         if (ptr != chk ) {
4682             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4683                        " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4684                        flags, c->nl, b->end, cnt);
4685         }
4686 #endif
4687     }
4688     if (c->nl) {
4689         if (ptr > c->nl) {
4690             /*
4691              * They have taken what we lied about
4692              */
4693             *(c->nl) = NATIVE_0xd;
4694             c->nl = NULL;
4695             ptr++;
4696         }
4697     }
4698     b->ptr = ptr;
4699     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4700 }
4701
4702 SSize_t
4703 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4704 {
4705     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4706         return PerlIOBuf_write(aTHX_ f, vbuf, count);
4707     else {
4708         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4709         const STDCHAR *buf = (const STDCHAR *) vbuf;
4710         const STDCHAR * const ebuf = buf + count;
4711         if (!b->buf)
4712             PerlIO_get_base(f);
4713         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4714             return 0;
4715         while (buf < ebuf) {
4716             const STDCHAR * const eptr = b->buf + b->bufsiz;
4717             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4718             while (buf < ebuf && b->ptr < eptr) {
4719                 if (*buf == '\n') {
4720                     if ((b->ptr + 2) > eptr) {
4721                         /*
4722                          * Not room for both
4723                          */
4724                         PerlIO_flush(f);
4725                         break;
4726                     }
4727                     else {
4728                         *(b->ptr)++ = NATIVE_0xd;      /* CR */
4729                         *(b->ptr)++ = NATIVE_0xa;      /* LF */
4730                         buf++;
4731                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4732                             PerlIO_flush(f);
4733                             break;
4734                         }
4735                     }
4736                 }
4737                 else {
4738                     *(b->ptr)++ = *buf++;
4739                 }
4740                 if (b->ptr >= eptr) {
4741                     PerlIO_flush(f);
4742                     break;
4743                 }
4744             }
4745         }
4746         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4747             PerlIO_flush(f);
4748         return (buf - (STDCHAR *) vbuf);
4749     }
4750 }
4751
4752 IV
4753 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4754 {
4755     PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4756     if (c->nl) {
4757         *(c->nl) = NATIVE_0xd;
4758         c->nl = NULL;
4759     }
4760     return PerlIOBuf_flush(aTHX_ f);
4761 }
4762
4763 IV
4764 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4765 {
4766     if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4767         /* In text mode - flush any pending stuff and flip it */
4768         PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4769 #ifndef PERLIO_USING_CRLF
4770         /* CRLF is unusual case - if this is just the :crlf layer pop it */
4771         PerlIO_pop(aTHX_ f);
4772 #endif
4773     }
4774     return 0;
4775 }
4776
4777 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4778     sizeof(PerlIO_funcs),
4779     "crlf",
4780     sizeof(PerlIOCrlf),
4781     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4782     PerlIOCrlf_pushed,
4783     PerlIOBuf_popped,         /* popped */
4784     PerlIOBuf_open,
4785     PerlIOCrlf_binmode,       /* binmode */
4786     NULL,
4787     PerlIOBase_fileno,
4788     PerlIOBuf_dup,
4789     PerlIOBuf_read,             /* generic read works with ptr/cnt lies */
4790     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
4791     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
4792     PerlIOBuf_seek,
4793     PerlIOBuf_tell,
4794     PerlIOBuf_close,
4795     PerlIOCrlf_flush,
4796     PerlIOBuf_fill,
4797     PerlIOBase_eof,
4798     PerlIOBase_error,
4799     PerlIOBase_clearerr,
4800     PerlIOBase_setlinebuf,
4801     PerlIOBuf_get_base,
4802     PerlIOBuf_bufsiz,
4803     PerlIOBuf_get_ptr,
4804     PerlIOCrlf_get_cnt,
4805     PerlIOCrlf_set_ptrcnt,
4806 };
4807
4808 PerlIO *
4809 Perl_PerlIO_stdin(pTHX)
4810 {
4811     if (!PL_perlio) {
4812         PerlIO_stdstreams(aTHX);
4813     }
4814     return (PerlIO*)&PL_perlio[1];
4815 }
4816
4817 PerlIO *
4818 Perl_PerlIO_stdout(pTHX)
4819 {
4820     if (!PL_perlio) {
4821         PerlIO_stdstreams(aTHX);
4822     }
4823     return (PerlIO*)&PL_perlio[2];
4824 }
4825
4826 PerlIO *
4827 Perl_PerlIO_stderr(pTHX)
4828 {
4829     if (!PL_perlio) {
4830         PerlIO_stdstreams(aTHX);
4831     }
4832     return (PerlIO*)&PL_perlio[3];
4833 }
4834
4835 /*--------------------------------------------------------------------------------------*/
4836
4837 char *
4838 PerlIO_getname(PerlIO *f, char *buf)
4839 {
4840 #ifdef VMS
4841     dTHX;
4842     char *name = NULL;
4843     bool exported = FALSE;
4844     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4845     if (!stdio) {
4846         stdio = PerlIO_exportFILE(f,0);
4847         exported = TRUE;
4848     }
4849     if (stdio) {
4850         name = fgetname(stdio, buf);
4851         if (exported) PerlIO_releaseFILE(f,stdio);
4852     }
4853     return name;
4854 #else
4855     PERL_UNUSED_ARG(f);
4856     PERL_UNUSED_ARG(buf);
4857     Perl_croak_nocontext("Don't know how to get file name");
4858     return NULL;
4859 #endif
4860 }
4861
4862
4863 /*--------------------------------------------------------------------------------------*/
4864 /*
4865  * Functions which can be called on any kind of PerlIO implemented in
4866  * terms of above
4867  */
4868
4869 #undef PerlIO_fdopen
4870 PerlIO *
4871 PerlIO_fdopen(int fd, const char *mode)
4872 {
4873     dTHX;
4874     return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4875 }
4876
4877 #undef PerlIO_open
4878 PerlIO *
4879 PerlIO_open(const char *path, const char *mode)
4880 {
4881     dTHX;
4882     SV *name = sv_2mortal(newSVpv(path, 0));
4883     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4884 }
4885
4886 #undef Perlio_reopen
4887 PerlIO *
4888 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4889 {
4890     dTHX;
4891     SV *name = sv_2mortal(newSVpv(path,0));
4892     return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4893 }
4894
4895 #undef PerlIO_getc
4896 int
4897 PerlIO_getc(PerlIO *f)
4898 {
4899     dTHX;
4900     STDCHAR buf[1];
4901     if ( 1 == PerlIO_read(f, buf, 1) ) {
4902         return (unsigned char) buf[0];
4903     }
4904     return EOF;
4905 }
4906
4907 #undef PerlIO_ungetc
4908 int
4909 PerlIO_ungetc(PerlIO *f, int ch)
4910 {
4911     dTHX;
4912     if (ch != EOF) {
4913         STDCHAR buf = ch;
4914         if (PerlIO_unread(f, &buf, 1) == 1)
4915             return ch;
4916     }
4917     return EOF;
4918 }
4919
4920 #undef PerlIO_putc
4921 int
4922 PerlIO_putc(PerlIO *f, int ch)
4923 {
4924     dTHX;
4925     STDCHAR buf = ch;
4926     return PerlIO_write(f, &buf, 1);
4927 }
4928
4929 #undef PerlIO_puts
4930 int
4931 PerlIO_puts(PerlIO *f, const char *s)
4932 {
4933     dTHX;
4934     return PerlIO_write(f, s, strlen(s));
4935 }
4936
4937 #undef PerlIO_rewind
4938 void
4939 PerlIO_rewind(PerlIO *f)
4940 {
4941     dTHX;
4942     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4943     PerlIO_clearerr(f);
4944 }
4945
4946 #undef PerlIO_vprintf
4947 int
4948 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4949 {
4950     dTHX;
4951     SV * sv;
4952     const char *s;
4953     STRLEN len;
4954     SSize_t wrote;
4955 #ifdef NEED_VA_COPY
4956     va_list apc;
4957     Perl_va_copy(ap, apc);
4958     sv = vnewSVpvf(fmt, &apc);
4959     va_end(apc);
4960 #else
4961     sv = vnewSVpvf(fmt, &ap);
4962 #endif
4963     s = SvPV_const(sv, len);
4964     wrote = PerlIO_write(f, s, len);
4965     SvREFCNT_dec(sv);
4966     return wrote;
4967 }
4968
4969 #undef PerlIO_printf
4970 int
4971 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4972 {
4973     va_list ap;
4974     int result;
4975     va_start(ap, fmt);
4976     result = PerlIO_vprintf(f, fmt, ap);
4977     va_end(ap);
4978     return result;
4979 }
4980
4981 #undef PerlIO_stdoutf
4982 int
4983 PerlIO_stdoutf(const char *fmt, ...)
4984 {
4985     dTHX;
4986     va_list ap;
4987     int result;
4988     va_start(ap, fmt);
4989     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4990     va_end(ap);
4991     return result;
4992 }
4993
4994 #undef PerlIO_tmpfile
4995 PerlIO *
4996 PerlIO_tmpfile(void)
4997 {
4998 #ifndef WIN32
4999      dTHX;
5000 #endif
5001      PerlIO *f = NULL;
5002 #ifdef WIN32
5003      const int fd = win32_tmpfd();
5004      if (fd >= 0)
5005           f = PerlIO_fdopen(fd, "w+b");
5006 #else /* WIN32 */
5007 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5008      int fd = -1;
5009      char tempname[] = "/tmp/PerlIO_XXXXXX";
5010      const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5011      SV * sv = NULL;
5012      int old_umask = umask(0177);
5013      /*
5014       * I have no idea how portable mkstemp() is ... NI-S
5015       */
5016      if (tmpdir && *tmpdir) {
5017          /* if TMPDIR is set and not empty, we try that first */
5018          sv = newSVpv(tmpdir, 0);
5019          sv_catpv(sv, tempname + 4);
5020          fd = mkstemp(SvPVX(sv));
5021      }
5022      if (fd < 0) {
5023          SvREFCNT_dec(sv);
5024          sv = NULL;
5025          /* else we try /tmp */
5026          fd = mkstemp(tempname);
5027      }
5028      if (fd < 0) {
5029          /* Try cwd */
5030          sv = newSVpvs(".");
5031          sv_catpv(sv, tempname + 4);
5032          fd = mkstemp(SvPVX(sv));
5033      }
5034      umask(old_umask);
5035      if (fd >= 0) {
5036           f = PerlIO_fdopen(fd, "w+");
5037           if (f)
5038                PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5039           PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5040      }
5041      SvREFCNT_dec(sv);
5042 #    else       /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5043      FILE * const stdio = PerlSIO_tmpfile();
5044
5045      if (stdio)
5046           f = PerlIO_fdopen(fileno(stdio), "w+");
5047
5048 #    endif /* else HAS_MKSTEMP */
5049 #endif /* else WIN32 */
5050      return f;
5051 }
5052
5053 void
5054 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5055 {
5056     if (!PerlIOValid(f))
5057         return;
5058     PerlIOBase(f)->err = errno;
5059 #ifdef VMS
5060     PerlIOBase(f)->os_err = vaxc$errno;
5061 #elif defined(OS2)
5062     PerlIOBase(f)->os_err = Perl_rc;
5063 #elif defined(WIN32)
5064     PerlIOBase(f)->os_err = GetLastError();
5065 #endif
5066 }
5067
5068 void
5069 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5070 {
5071     if (!PerlIOValid(f))
5072         return;
5073     SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5074 #ifdef OS2
5075     Perl_rc = PerlIOBase(f)->os_err);
5076 #elif defined(WIN32)
5077     SetLastError(PerlIOBase(f)->os_err);
5078 #endif
5079 }
5080
5081 #undef HAS_FSETPOS
5082 #undef HAS_FGETPOS
5083
5084
5085 /*======================================================================================*/
5086 /*
5087  * Now some functions in terms of above which may be needed even if we are
5088  * not in true PerlIO mode
5089  */
5090 const char *
5091 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5092 {
5093     const char *direction = NULL;
5094     SV *layers;
5095     /*
5096      * Need to supply default layer info from open.pm
5097      */
5098
5099     if (!PL_curcop)
5100         return NULL;
5101
5102     if (mode && mode[0] != 'r') {
5103         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5104             direction = "open>";
5105     } else {
5106         if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5107             direction = "open<";
5108     }
5109     if (!direction)
5110         return NULL;
5111
5112     layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5113
5114     assert(layers);
5115     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5116 }
5117
5118
5119 #ifndef HAS_FSETPOS
5120 #undef PerlIO_setpos
5121 int
5122 PerlIO_setpos(PerlIO *f, SV *pos)
5123 {
5124     if (SvOK(pos)) {
5125         if (f) {
5126             dTHX;
5127             STRLEN len;
5128             const Off_t * const posn = (Off_t *) SvPV(pos, len);
5129             if(len == sizeof(Off_t))
5130                 return PerlIO_seek(f, *posn, SEEK_SET);
5131         }
5132     }
5133     SETERRNO(EINVAL, SS_IVCHAN);
5134     return -1;
5135 }
5136 #else
5137 #undef PerlIO_setpos
5138 int
5139 PerlIO_setpos(PerlIO *f, SV *pos)
5140 {
5141     if (SvOK(pos)) {
5142         if (f) {
5143             dTHX;
5144             STRLEN len;
5145             Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5146             if(len == sizeof(Fpos_t))
5147 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5148                 return fsetpos64(f, fpos);
5149 #else
5150                 return fsetpos(f, fpos);
5151 #endif
5152         }
5153     }
5154     SETERRNO(EINVAL, SS_IVCHAN);
5155     return -1;
5156 }
5157 #endif
5158
5159 #ifndef HAS_FGETPOS
5160 #undef PerlIO_getpos
5161 int
5162 PerlIO_getpos(PerlIO *f, SV *pos)
5163 {
5164     dTHX;
5165     Off_t posn = PerlIO_tell(f);
5166     sv_setpvn(pos, (char *) &posn, sizeof(posn));
5167     return (posn == (Off_t) - 1) ? -1 : 0;
5168 }
5169 #else
5170 #undef PerlIO_getpos
5171 int
5172 PerlIO_getpos(PerlIO *f, SV *pos)
5173 {
5174     dTHX;
5175     Fpos_t fpos;
5176     int code;
5177 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5178     code = fgetpos64(f, &fpos);
5179 #else
5180     code = fgetpos(f, &fpos);
5181 #endif
5182     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5183     return code;
5184 }
5185 #endif
5186
5187 #if !defined(HAS_VPRINTF)
5188
5189 int
5190 vprintf(char *pat, char *args)
5191 {
5192     _doprnt(pat, args, stdout);
5193     return 0;                   /* wrong, but perl doesn't use the return
5194                                  * value */
5195 }
5196
5197 int
5198 vfprintf(FILE *fd, char *pat, char *args)
5199 {
5200     _doprnt(pat, args, fd);
5201     return 0;                   /* wrong, but perl doesn't use the return
5202                                  * value */
5203 }
5204
5205 #endif
5206
5207 /* print a failure format string message to stderr and fail exit the process
5208    using only libc without depending on any perl data structures being
5209    initialized.
5210 */
5211
5212 void
5213 Perl_noperl_die(const char* pat, ...)
5214 {
5215     va_list(arglist);
5216     PERL_ARGS_ASSERT_NOPERL_DIE;
5217     va_start(arglist, pat);
5218     vfprintf(stderr, pat, arglist);
5219     va_end(arglist);
5220     exit(1);
5221 }
5222
5223 /*
5224  * ex: set ts=8 sts=4 sw=4 et:
5225  */