perlio.c

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