perlio.c

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