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