perlio.c

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