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