perlio.c

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