perlio.c

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