perlio.c

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