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         PerlIO_flush(f);
2541         return 0;
2542     }
2543     return (
2544 #ifdef SOCKS5_VERSION_NAME
2545                (getsockopt
2546                 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2547                  &optlen) <
2548                 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2549 #else
2550                PerlSIO_fclose(stdio)
2551 #endif
2552         );
2553
2554 }
2555
2556
2557
2558 SSize_t
2559 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2560 {
2561     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2562     SSize_t got = 0;
2563     if (count == 1) {
2564         STDCHAR *buf = (STDCHAR *) vbuf;
2565         /*
2566          * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2567          * stdio does not do that for fread()
2568          */
2569         int ch = PerlSIO_fgetc(s);
2570         if (ch != EOF) {
2571             *buf = ch;
2572             got = 1;
2573         }
2574     }
2575     else
2576         got = PerlSIO_fread(vbuf, 1, count, s);
2577     return got;
2578 }
2579
2580 SSize_t
2581 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2582 {
2583     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2584     STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2585     SSize_t unread = 0;
2586     while (count > 0) {
2587         int ch = *buf-- & 0xff;
2588         if (PerlSIO_ungetc(ch, s) != ch)
2589             break;
2590         unread++;
2591         count--;
2592     }
2593     return unread;
2594 }
2595
2596 SSize_t
2597 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2598 {
2599     return PerlSIO_fwrite(vbuf, 1, count,
2600                           PerlIOSelf(f, PerlIOStdio)->stdio);
2601 }
2602
2603 IV
2604 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2605 {
2606     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2607     return PerlSIO_fseek(stdio, offset, whence);
2608 }
2609
2610 Off_t
2611 PerlIOStdio_tell(pTHX_ PerlIO *f)
2612 {
2613     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2614     return PerlSIO_ftell(stdio);
2615 }
2616
2617 IV
2618 PerlIOStdio_flush(pTHX_ PerlIO *f)
2619 {
2620     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2621     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2622         return PerlSIO_fflush(stdio);
2623     }
2624     else {
2625 #if 0
2626         /*
2627          * FIXME: This discards ungetc() and pre-read stuff which is not
2628          * right if this is just a "sync" from a layer above Suspect right
2629          * design is to do _this_ but not have layer above flush this
2630          * layer read-to-read
2631          */
2632         /*
2633          * Not writeable - sync by attempting a seek
2634          */
2635         int err = errno;
2636         if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2637             errno = err;
2638 #endif
2639     }
2640     return 0;
2641 }
2642
2643 IV
2644 PerlIOStdio_fill(pTHX_ PerlIO *f)
2645 {
2646     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2647     int c;
2648     /*
2649      * fflush()ing read-only streams can cause trouble on some stdio-s
2650      */
2651     if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2652         if (PerlSIO_fflush(stdio) != 0)
2653             return EOF;
2654     }
2655     c = PerlSIO_fgetc(stdio);
2656     if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2657         return EOF;
2658     return 0;
2659 }
2660
2661 IV
2662 PerlIOStdio_eof(pTHX_ PerlIO *f)
2663 {
2664     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2665 }
2666
2667 IV
2668 PerlIOStdio_error(pTHX_ PerlIO *f)
2669 {
2670     return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2671 }
2672
2673 void
2674 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2675 {
2676     PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2677 }
2678
2679 void
2680 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2681 {
2682 #ifdef HAS_SETLINEBUF
2683     PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2684 #else
2685     PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2686 #endif
2687 }
2688
2689 #ifdef FILE_base
2690 STDCHAR *
2691 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2692 {
2693     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2694     return (STDCHAR*)PerlSIO_get_base(stdio);
2695 }
2696
2697 Size_t
2698 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2699 {
2700     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2701     return PerlSIO_get_bufsiz(stdio);
2702 }
2703 #endif
2704
2705 #ifdef USE_STDIO_PTR
2706 STDCHAR *
2707 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2708 {
2709     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2710     return (STDCHAR*)PerlSIO_get_ptr(stdio);
2711 }
2712
2713 SSize_t
2714 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2715 {
2716     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2717     return PerlSIO_get_cnt(stdio);
2718 }
2719
2720 void
2721 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2722 {
2723     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2724     if (ptr != NULL) {
2725 #ifdef STDIO_PTR_LVALUE
2726         PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2727 #ifdef STDIO_PTR_LVAL_SETS_CNT
2728         if (PerlSIO_get_cnt(stdio) != (cnt)) {
2729             assert(PerlSIO_get_cnt(stdio) == (cnt));
2730         }
2731 #endif
2732 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2733         /*
2734          * Setting ptr _does_ change cnt - we are done
2735          */
2736         return;
2737 #endif
2738 #else                           /* STDIO_PTR_LVALUE */
2739         PerlProc_abort();
2740 #endif                          /* STDIO_PTR_LVALUE */
2741     }
2742     /*
2743      * Now (or only) set cnt
2744      */
2745 #ifdef STDIO_CNT_LVALUE
2746     PerlSIO_set_cnt(stdio, cnt);
2747 #else                           /* STDIO_CNT_LVALUE */
2748 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2749     PerlSIO_set_ptr(stdio,
2750                     PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2751                                               cnt));
2752 #else                           /* STDIO_PTR_LVAL_SETS_CNT */
2753     PerlProc_abort();
2754 #endif                          /* STDIO_PTR_LVAL_SETS_CNT */
2755 #endif                          /* STDIO_CNT_LVALUE */
2756 }
2757
2758 #endif
2759
2760 PerlIO_funcs PerlIO_stdio = {
2761     "stdio",
2762     sizeof(PerlIOStdio),
2763     PERLIO_K_BUFFERED,
2764     PerlIOBase_pushed,
2765     PerlIOBase_noop_ok,
2766     PerlIOStdio_open,
2767     NULL,
2768     PerlIOStdio_fileno,
2769     PerlIOStdio_dup,
2770     PerlIOStdio_read,
2771     PerlIOStdio_unread,
2772     PerlIOStdio_write,
2773     PerlIOStdio_seek,
2774     PerlIOStdio_tell,
2775     PerlIOStdio_close,
2776     PerlIOStdio_flush,
2777     PerlIOStdio_fill,
2778     PerlIOStdio_eof,
2779     PerlIOStdio_error,
2780     PerlIOStdio_clearerr,
2781     PerlIOStdio_setlinebuf,
2782 #ifdef FILE_base
2783     PerlIOStdio_get_base,
2784     PerlIOStdio_get_bufsiz,
2785 #else
2786     NULL,
2787     NULL,
2788 #endif
2789 #ifdef USE_STDIO_PTR
2790     PerlIOStdio_get_ptr,
2791     PerlIOStdio_get_cnt,
2792 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2793     PerlIOStdio_set_ptrcnt
2794 #else                           /* STDIO_PTR_LVALUE */
2795     NULL
2796 #endif                          /* STDIO_PTR_LVALUE */
2797 #else                           /* USE_STDIO_PTR */
2798     NULL,
2799     NULL,
2800     NULL
2801 #endif                          /* USE_STDIO_PTR */
2802 };
2803
2804 FILE *
2805 PerlIO_exportFILE(PerlIO *f, int fl)
2806 {
2807     dTHX;
2808     FILE *stdio;
2809     PerlIO_flush(f);
2810     stdio = fdopen(PerlIO_fileno(f), "r+");
2811     if (stdio) {
2812         PerlIOStdio *s =
2813             PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2814                        PerlIOStdio);
2815         s->stdio = stdio;
2816     }
2817     return stdio;
2818 }
2819
2820 FILE *
2821 PerlIO_findFILE(PerlIO *f)
2822 {
2823     PerlIOl *l = *f;
2824     while (l) {
2825         if (l->tab == &PerlIO_stdio) {
2826             PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2827             return s->stdio;
2828         }
2829         l = *PerlIONext(&l);
2830     }
2831     return PerlIO_exportFILE(f, 0);
2832 }
2833
2834 void
2835 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2836 {
2837 }
2838
2839 /*--------------------------------------------------------------------------------------*/
2840 /*
2841  * perlio buffer layer
2842  */
2843
2844 IV
2845 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2846 {
2847     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2848     int fd = PerlIO_fileno(f);
2849     Off_t posn;
2850     if (fd >= 0 && PerlLIO_isatty(fd)) {
2851         PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2852     }
2853     posn = PerlIO_tell(PerlIONext(f));
2854     if (posn != (Off_t) - 1) {
2855         b->posn = posn;
2856     }
2857     return PerlIOBase_pushed(aTHX_ f, mode, arg);
2858 }
2859
2860 PerlIO *
2861 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2862                IV n, const char *mode, int fd, int imode, int perm,
2863                PerlIO *f, int narg, SV **args)
2864 {
2865     if (PerlIOValid(f)) {
2866         PerlIO *next = PerlIONext(f);
2867         PerlIO_funcs *tab =  PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2868         next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2869                           next, narg, args);
2870         if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
2871             return NULL;
2872         }
2873     }
2874     else {
2875         PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2876         int init = 0;
2877         if (*mode == 'I') {
2878             init = 1;
2879             /*
2880              * mode++;
2881              */
2882         }
2883         f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2884                           NULL, narg, args);
2885         if (f) {
2886             if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2887                 /*
2888                  * if push fails during open, open fails. close will pop us.
2889                  */
2890                 PerlIO_close (f);
2891                 return NULL;
2892             } else {
2893                 fd = PerlIO_fileno(f);
2894                 if (init && fd == 2) {
2895                     /*
2896                      * Initial stderr is unbuffered
2897                      */
2898                     PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2899                 }
2900 #ifdef PERLIO_USING_CRLF
2901 #  ifdef PERLIO_IS_BINMODE_FD
2902                 if (PERLIO_IS_BINMODE_FD(fd))
2903                     PerlIO_binmode(f,  '<'/*not used*/, O_BINARY, Nullch);
2904                 else
2905 #  endif
2906                 /*
2907                  * do something about failing setmode()? --jhi
2908                  */
2909                 PerlLIO_setmode(fd, O_BINARY);
2910 #endif
2911             }
2912         }
2913     }
2914     return f;
2915 }
2916
2917 /*
2918  * This "flush" is akin to sfio's sync in that it handles files in either
2919  * read or write state
2920  */
2921 IV
2922 PerlIOBuf_flush(pTHX_ PerlIO *f)
2923 {
2924     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2925     int code = 0;
2926     PerlIO *n = PerlIONext(f);
2927     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2928         /*
2929          * write() the buffer
2930          */
2931         STDCHAR *buf = b->buf;
2932         STDCHAR *p = buf;
2933         while (p < b->ptr) {
2934             SSize_t count = PerlIO_write(n, p, b->ptr - p);
2935             if (count > 0) {
2936                 p += count;
2937             }
2938             else if (count < 0 || PerlIO_error(n)) {
2939                 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2940                 code = -1;
2941                 break;
2942             }
2943         }
2944         b->posn += (p - buf);
2945     }
2946     else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2947         STDCHAR *buf = PerlIO_get_base(f);
2948         /*
2949          * Note position change
2950          */
2951         b->posn += (b->ptr - buf);
2952         if (b->ptr < b->end) {
2953             /*
2954              * We did not consume all of it
2955              */
2956             if (PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
2957                 /* Reload n as some layers may pop themselves on seek */
2958                 b->posn = PerlIO_tell(n = PerlIONext(f));
2959             }
2960         }
2961     }
2962     b->ptr = b->end = b->buf;
2963     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2964     /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
2965     /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
2966     if (PerlIOValid(n) && PerlIO_flush(n) != 0)
2967         code = -1;
2968     return code;
2969 }
2970
2971 IV
2972 PerlIOBuf_fill(pTHX_ PerlIO *f)
2973 {
2974     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2975     PerlIO *n = PerlIONext(f);
2976     SSize_t avail;
2977     /*
2978      * FIXME: doing the down-stream flush maybe sub-optimal if it causes
2979      * pre-read data in stdio buffer to be discarded.
2980      * However, skipping the flush also skips _our_ hosekeeping
2981      * and breaks tell tests. So we do the flush.
2982      */
2983     if (PerlIO_flush(f) != 0)
2984         return -1;
2985     if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2986         PerlIOBase_flush_linebuf(aTHX);
2987
2988     if (!b->buf)
2989         PerlIO_get_base(f);     /* allocate via vtable */
2990
2991     b->ptr = b->end = b->buf;
2992     if (PerlIO_fast_gets(n)) {
2993         /*
2994          * Layer below is also buffered. We do _NOT_ want to call its
2995          * ->Read() because that will loop till it gets what we asked for
2996          * which may hang on a pipe etc. Instead take anything it has to
2997          * hand, or ask it to fill _once_.
2998          */
2999         avail = PerlIO_get_cnt(n);
3000         if (avail <= 0) {
3001             avail = PerlIO_fill(n);
3002             if (avail == 0)
3003                 avail = PerlIO_get_cnt(n);
3004             else {
3005                 if (!PerlIO_error(n) && PerlIO_eof(n))
3006                     avail = 0;
3007             }
3008         }
3009         if (avail > 0) {
3010             STDCHAR *ptr = PerlIO_get_ptr(n);
3011             SSize_t cnt = avail;
3012             if (avail > b->bufsiz)
3013                 avail = b->bufsiz;
3014             Copy(ptr, b->buf, avail, STDCHAR);
3015             PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3016         }
3017     }
3018     else {
3019         avail = PerlIO_read(n, b->ptr, b->bufsiz);
3020     }
3021     if (avail <= 0) {
3022         if (avail == 0)
3023             PerlIOBase(f)->flags |= PERLIO_F_EOF;
3024         else
3025             PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3026         return -1;
3027     }
3028     b->end = b->buf + avail;
3029     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3030     return 0;
3031 }
3032
3033 SSize_t
3034 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3035 {
3036     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3037     if (PerlIOValid(f)) {
3038         if (!b->ptr)
3039             PerlIO_get_base(f);
3040         return PerlIOBase_read(aTHX_ f, vbuf, count);
3041     }
3042     return 0;
3043 }
3044
3045 SSize_t
3046 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3047 {
3048     const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3049     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3050     SSize_t unread = 0;
3051     SSize_t avail;
3052     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3053         PerlIO_flush(f);
3054     if (!b->buf)
3055         PerlIO_get_base(f);
3056     if (b->buf) {
3057         if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3058             /*
3059              * Buffer is already a read buffer, we can overwrite any chars
3060              * which have been read back to buffer start
3061              */
3062             avail = (b->ptr - b->buf);
3063         }
3064         else {
3065             /*
3066              * Buffer is idle, set it up so whole buffer is available for
3067              * unread
3068              */
3069             avail = b->bufsiz;
3070             b->end = b->buf + avail;
3071             b->ptr = b->end;
3072             PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3073             /*
3074              * Buffer extends _back_ from where we are now
3075              */
3076             b->posn -= b->bufsiz;
3077         }
3078         if (avail > (SSize_t) count) {
3079             /*
3080              * If we have space for more than count, just move count
3081              */
3082             avail = count;
3083         }
3084         if (avail > 0) {
3085             b->ptr -= avail;
3086             buf -= avail;
3087             /*
3088              * In simple stdio-like ungetc() case chars will be already
3089              * there
3090              */
3091             if (buf != b->ptr) {
3092                 Copy(buf, b->ptr, avail, STDCHAR);
3093             }
3094             count -= avail;
3095             unread += avail;
3096             PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3097         }
3098     }
3099     return unread;
3100 }
3101
3102 SSize_t
3103 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3104 {
3105     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3106     const STDCHAR *buf = (const STDCHAR *) vbuf;
3107     Size_t written = 0;
3108     if (!b->buf)
3109         PerlIO_get_base(f);
3110     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3111         return 0;
3112     while (count > 0) {
3113         SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3114         if ((SSize_t) count < avail)
3115             avail = count;
3116         PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3117         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3118             while (avail > 0) {
3119                 int ch = *buf++;
3120                 *(b->ptr)++ = ch;
3121                 count--;
3122                 avail--;
3123                 written++;
3124                 if (ch == '\n') {
3125                     PerlIO_flush(f);
3126                     break;
3127                 }
3128             }
3129         }
3130         else {
3131             if (avail) {
3132                 Copy(buf, b->ptr, avail, STDCHAR);
3133                 count -= avail;
3134                 buf += avail;
3135                 written += avail;
3136                 b->ptr += avail;
3137             }
3138         }
3139         if (b->ptr >= (b->buf + b->bufsiz))
3140             PerlIO_flush(f);
3141     }
3142     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3143         PerlIO_flush(f);
3144     return written;
3145 }
3146
3147 IV
3148 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3149 {
3150     IV code;
3151     if ((code = PerlIO_flush(f)) == 0) {
3152         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3153         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3154         code = PerlIO_seek(PerlIONext(f), offset, whence);
3155         if (code == 0) {
3156             b->posn = PerlIO_tell(PerlIONext(f));
3157         }
3158     }
3159     return code;
3160 }
3161
3162 Off_t
3163 PerlIOBuf_tell(pTHX_ PerlIO *f)
3164 {
3165     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3166     /*
3167      * b->posn is file position where b->buf was read, or will be written
3168      */
3169     Off_t posn = b->posn;
3170     if (b->buf) {
3171         /*
3172          * If buffer is valid adjust position by amount in buffer
3173          */
3174         posn += (b->ptr - b->buf);
3175     }
3176     return posn;
3177 }
3178
3179 IV
3180 PerlIOBuf_close(pTHX_ PerlIO *f)
3181 {
3182     IV code = PerlIOBase_close(aTHX_ f);
3183     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3184     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3185         Safefree(b->buf);
3186     }
3187     b->buf = NULL;
3188     b->ptr = b->end = b->buf;
3189     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3190     return code;
3191 }
3192
3193 STDCHAR *
3194 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3195 {
3196     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3197     if (!b->buf)
3198         PerlIO_get_base(f);
3199     return b->ptr;
3200 }
3201
3202 SSize_t
3203 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3204 {
3205     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3206     if (!b->buf)
3207         PerlIO_get_base(f);
3208     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3209         return (b->end - b->ptr);
3210     return 0;
3211 }
3212
3213 STDCHAR *
3214 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3215 {
3216     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3217     if (!b->buf) {
3218         if (!b->bufsiz)
3219             b->bufsiz = 4096;
3220         b->buf =
3221         Newz('B',b->buf,b->bufsiz, STDCHAR);
3222         if (!b->buf) {
3223             b->buf = (STDCHAR *) & b->oneword;
3224             b->bufsiz = sizeof(b->oneword);
3225         }
3226         b->ptr = b->buf;
3227         b->end = b->ptr;
3228     }
3229     return b->buf;
3230 }
3231
3232 Size_t
3233 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3234 {
3235     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3236     if (!b->buf)
3237         PerlIO_get_base(f);
3238     return (b->end - b->buf);
3239 }
3240
3241 void
3242 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3243 {
3244     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3245     if (!b->buf)
3246         PerlIO_get_base(f);
3247     b->ptr = ptr;
3248     if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3249         assert(PerlIO_get_cnt(f) == cnt);
3250         assert(b->ptr >= b->buf);
3251     }
3252     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3253 }
3254
3255 PerlIO *
3256 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3257 {
3258  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3259 }
3260
3261
3262
3263 PerlIO_funcs PerlIO_perlio = {
3264     "perlio",
3265     sizeof(PerlIOBuf),
3266     PERLIO_K_BUFFERED,
3267     PerlIOBuf_pushed,
3268     PerlIOBase_noop_ok,
3269     PerlIOBuf_open,
3270     NULL,
3271     PerlIOBase_fileno,
3272     PerlIOBuf_dup,
3273     PerlIOBuf_read,
3274     PerlIOBuf_unread,
3275     PerlIOBuf_write,
3276     PerlIOBuf_seek,
3277     PerlIOBuf_tell,
3278     PerlIOBuf_close,
3279     PerlIOBuf_flush,
3280     PerlIOBuf_fill,
3281     PerlIOBase_eof,
3282     PerlIOBase_error,
3283     PerlIOBase_clearerr,
3284     PerlIOBase_setlinebuf,
3285     PerlIOBuf_get_base,
3286     PerlIOBuf_bufsiz,
3287     PerlIOBuf_get_ptr,
3288     PerlIOBuf_get_cnt,
3289     PerlIOBuf_set_ptrcnt,
3290 };
3291
3292 /*--------------------------------------------------------------------------------------*/
3293 /*
3294  * Temp layer to hold unread chars when cannot do it any other way
3295  */
3296
3297 IV
3298 PerlIOPending_fill(pTHX_ PerlIO *f)
3299 {
3300     /*
3301      * Should never happen
3302      */
3303     PerlIO_flush(f);
3304     return 0;
3305 }
3306
3307 IV
3308 PerlIOPending_close(pTHX_ PerlIO *f)
3309 {
3310     /*
3311      * A tad tricky - flush pops us, then we close new top
3312      */
3313     PerlIO_flush(f);
3314     return PerlIO_close(f);
3315 }
3316
3317 IV
3318 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3319 {
3320     /*
3321      * A tad tricky - flush pops us, then we seek new top
3322      */
3323     PerlIO_flush(f);
3324     return PerlIO_seek(f, offset, whence);
3325 }
3326
3327
3328 IV
3329 PerlIOPending_flush(pTHX_ PerlIO *f)
3330 {
3331     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3332     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3333         Safefree(b->buf);
3334         b->buf = NULL;
3335     }
3336     PerlIO_pop(aTHX_ f);
3337     return 0;
3338 }
3339
3340 void
3341 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3342 {
3343     if (cnt <= 0) {
3344         PerlIO_flush(f);
3345     }
3346     else {
3347         PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3348     }
3349 }
3350
3351 IV
3352 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3353 {
3354     IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3355     PerlIOl *l = PerlIOBase(f);
3356     /*
3357      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3358      * etc. get muddled when it changes mid-string when we auto-pop.
3359      */
3360     l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3361         (PerlIOBase(PerlIONext(f))->
3362          flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3363     return code;
3364 }
3365
3366 SSize_t
3367 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3368 {
3369     SSize_t avail = PerlIO_get_cnt(f);
3370     SSize_t got = 0;
3371     if (count < avail)
3372         avail = count;
3373     if (avail > 0)
3374         got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3375     if (got >= 0 && got < count) {
3376         SSize_t more =
3377             PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3378         if (more >= 0 || got == 0)
3379             got += more;
3380     }
3381     return got;
3382 }
3383
3384 PerlIO_funcs PerlIO_pending = {
3385     "pending",
3386     sizeof(PerlIOBuf),
3387     PERLIO_K_BUFFERED,
3388     PerlIOPending_pushed,
3389     PerlIOBase_noop_ok,
3390     NULL,
3391     NULL,
3392     PerlIOBase_fileno,
3393     PerlIOBuf_dup,
3394     PerlIOPending_read,
3395     PerlIOBuf_unread,
3396     PerlIOBuf_write,
3397     PerlIOPending_seek,
3398     PerlIOBuf_tell,
3399     PerlIOPending_close,
3400     PerlIOPending_flush,
3401     PerlIOPending_fill,
3402     PerlIOBase_eof,
3403     PerlIOBase_error,
3404     PerlIOBase_clearerr,
3405     PerlIOBase_setlinebuf,
3406     PerlIOBuf_get_base,
3407     PerlIOBuf_bufsiz,
3408     PerlIOBuf_get_ptr,
3409     PerlIOBuf_get_cnt,
3410     PerlIOPending_set_ptrcnt,
3411 };
3412
3413
3414
3415 /*--------------------------------------------------------------------------------------*/
3416 /*
3417  * crlf - translation On read translate CR,LF to "\n" we do this by
3418  * overriding ptr/cnt entries to hand back a line at a time and keeping a
3419  * record of which nl we "lied" about. On write translate "\n" to CR,LF
3420  */
3421
3422 typedef struct {
3423     PerlIOBuf base;             /* PerlIOBuf stuff */
3424     STDCHAR *nl;                /* Position of crlf we "lied" about in the
3425                                  * buffer */
3426 } PerlIOCrlf;
3427
3428 IV
3429 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3430 {
3431     IV code;
3432     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3433     code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3434 #if 0
3435     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3436                  f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3437                  PerlIOBase(f)->flags);
3438 #endif
3439     return code;
3440 }
3441
3442
3443 SSize_t
3444 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3445 {
3446     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3447     if (c->nl) {
3448         *(c->nl) = 0xd;
3449         c->nl = NULL;
3450     }
3451     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3452         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3453     else {
3454         const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3455         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3456         SSize_t unread = 0;
3457         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3458             PerlIO_flush(f);
3459         if (!b->buf)
3460             PerlIO_get_base(f);
3461         if (b->buf) {
3462             if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3463                 b->end = b->ptr = b->buf + b->bufsiz;
3464                 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3465                 b->posn -= b->bufsiz;
3466             }
3467             while (count > 0 && b->ptr > b->buf) {
3468                 int ch = *--buf;
3469                 if (ch == '\n') {
3470                     if (b->ptr - 2 >= b->buf) {
3471                         *--(b->ptr) = 0xa;
3472                         *--(b->ptr) = 0xd;
3473                         unread++;
3474                         count--;
3475                     }
3476                     else {
3477                         buf++;
3478                         break;
3479                     }
3480                 }
3481                 else {
3482                     *--(b->ptr) = ch;
3483                     unread++;
3484                     count--;
3485                 }
3486             }
3487         }
3488         return unread;
3489     }
3490 }
3491
3492 SSize_t
3493 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3494 {
3495     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3496     if (!b->buf)
3497         PerlIO_get_base(f);
3498     if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3499         PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3500         if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3501             STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3502           scan:
3503             while (nl < b->end && *nl != 0xd)
3504                 nl++;
3505             if (nl < b->end && *nl == 0xd) {
3506               test:
3507                 if (nl + 1 < b->end) {
3508                     if (nl[1] == 0xa) {
3509                         *nl = '\n';
3510                         c->nl = nl;
3511                     }
3512                     else {
3513                         /*
3514                          * Not CR,LF but just CR
3515                          */
3516                         nl++;
3517                         goto scan;
3518                     }
3519                 }
3520                 else {
3521                     /*
3522                      * Blast - found CR as last char in buffer
3523                      */
3524
3525                     if (b->ptr < nl) {
3526                         /*
3527                          * They may not care, defer work as long as
3528                          * possible
3529                          */
3530                         c->nl = nl;
3531                         return (nl - b->ptr);
3532                     }
3533                     else {
3534                         int code;
3535                         b->ptr++;       /* say we have read it as far as
3536                                          * flush() is concerned */
3537                         b->buf++;       /* Leave space in front of buffer */
3538                         b->bufsiz--;    /* Buffer is thus smaller */
3539                         code = PerlIO_fill(f);  /* Fetch some more */
3540                         b->bufsiz++;    /* Restore size for next time */
3541                         b->buf--;       /* Point at space */
3542                         b->ptr = nl = b->buf;   /* Which is what we hand
3543                                                  * off */
3544                         b->posn--;      /* Buffer starts here */
3545                         *nl = 0xd;      /* Fill in the CR */
3546                         if (code == 0)
3547                             goto test;  /* fill() call worked */
3548                         /*
3549                          * CR at EOF - just fall through
3550                          */
3551                         /* Should we clear EOF though ??? */
3552                     }
3553                 }
3554             }
3555         }
3556         return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3557     }
3558     return 0;
3559 }
3560
3561 void
3562 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3563 {
3564     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3565     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3566     IV flags = PerlIOBase(f)->flags;
3567     if (!b->buf)
3568         PerlIO_get_base(f);
3569     if (!ptr) {
3570         if (c->nl) {
3571             ptr = c->nl + 1;
3572             if (ptr == b->end && *c->nl == 0xd) {
3573                 /* Defered CR at end of buffer case - we lied about count */
3574                 ptr--;
3575             }
3576         }
3577         else {
3578             ptr = b->end;
3579         }
3580         ptr -= cnt;
3581     }
3582     else {
3583 #if 1
3584         /*
3585          * Test code - delete when it works ...
3586          */
3587         STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3588         if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3589           /* Defered CR at end of buffer case - we lied about count */
3590           chk--;
3591         }
3592         chk -= cnt;
3593
3594         if (ptr != chk ) {
3595             Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3596                        " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3597                        b->end, cnt);
3598         }
3599 #endif
3600     }
3601     if (c->nl) {
3602         if (ptr > c->nl) {
3603             /*
3604              * They have taken what we lied about
3605              */
3606             *(c->nl) = 0xd;
3607             c->nl = NULL;
3608             ptr++;
3609         }
3610     }
3611     b->ptr = ptr;
3612     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3613 }
3614
3615 SSize_t
3616 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3617 {
3618     if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3619         return PerlIOBuf_write(aTHX_ f, vbuf, count);
3620     else {
3621         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3622         const STDCHAR *buf = (const STDCHAR *) vbuf;
3623         const STDCHAR *ebuf = buf + count;
3624         if (!b->buf)
3625             PerlIO_get_base(f);
3626         if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3627             return 0;
3628         while (buf < ebuf) {
3629             STDCHAR *eptr = b->buf + b->bufsiz;
3630             PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3631             while (buf < ebuf && b->ptr < eptr) {
3632                 if (*buf == '\n') {
3633                     if ((b->ptr + 2) > eptr) {
3634                         /*
3635                          * Not room for both
3636                          */
3637                         PerlIO_flush(f);
3638                         break;
3639                     }
3640                     else {
3641                         *(b->ptr)++ = 0xd;      /* CR */
3642                         *(b->ptr)++ = 0xa;      /* LF */
3643                         buf++;
3644                         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3645                             PerlIO_flush(f);
3646                             break;
3647                         }
3648                     }
3649                 }
3650                 else {
3651                     int ch = *buf++;
3652                     *(b->ptr)++ = ch;
3653                 }
3654                 if (b->ptr >= eptr) {
3655                     PerlIO_flush(f);
3656                     break;
3657                 }
3658             }
3659         }
3660         if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3661             PerlIO_flush(f);
3662         return (buf - (STDCHAR *) vbuf);
3663     }
3664 }
3665
3666 IV
3667 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3668 {
3669     PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3670     if (c->nl) {
3671         *(c->nl) = 0xd;
3672         c->nl = NULL;
3673     }
3674     return PerlIOBuf_flush(aTHX_ f);
3675 }
3676
3677 PerlIO_funcs PerlIO_crlf = {
3678     "crlf",
3679     sizeof(PerlIOCrlf),
3680     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3681     PerlIOCrlf_pushed,
3682     PerlIOBase_noop_ok,         /* popped */
3683     PerlIOBuf_open,
3684     NULL,
3685     PerlIOBase_fileno,
3686     PerlIOBuf_dup,
3687     PerlIOBuf_read,             /* generic read works with ptr/cnt lies
3688                                  * ... */
3689     PerlIOCrlf_unread,          /* Put CR,LF in buffer for each '\n' */
3690     PerlIOCrlf_write,           /* Put CR,LF in buffer for each '\n' */
3691     PerlIOBuf_seek,
3692     PerlIOBuf_tell,
3693     PerlIOBuf_close,
3694     PerlIOCrlf_flush,
3695     PerlIOBuf_fill,
3696     PerlIOBase_eof,
3697     PerlIOBase_error,
3698     PerlIOBase_clearerr,
3699     PerlIOBase_setlinebuf,
3700     PerlIOBuf_get_base,
3701     PerlIOBuf_bufsiz,
3702     PerlIOBuf_get_ptr,
3703     PerlIOCrlf_get_cnt,
3704     PerlIOCrlf_set_ptrcnt,
3705 };
3706
3707 #ifdef HAS_MMAP
3708 /*--------------------------------------------------------------------------------------*/
3709 /*
3710  * mmap as "buffer" layer
3711  */
3712
3713 typedef struct {
3714     PerlIOBuf base;             /* PerlIOBuf stuff */
3715     Mmap_t mptr;                /* Mapped address */
3716     Size_t len;                 /* mapped length */
3717     STDCHAR *bbuf;              /* malloced buffer if map fails */
3718 } PerlIOMmap;
3719
3720 static size_t page_size = 0;
3721
3722 IV
3723 PerlIOMmap_map(pTHX_ PerlIO *f)
3724 {
3725     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3726     IV flags = PerlIOBase(f)->flags;
3727     IV code = 0;
3728     if (m->len)
3729         abort();
3730     if (flags & PERLIO_F_CANREAD) {
3731         PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3732         int fd = PerlIO_fileno(f);
3733         Stat_t st;
3734         code = Fstat(fd, &st);
3735         if (code == 0 && S_ISREG(st.st_mode)) {
3736             SSize_t len = st.st_size - b->posn;
3737             if (len > 0) {
3738                 Off_t posn;
3739                 if (!page_size) {
3740 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3741                     {
3742                         SETERRNO(0, SS$_NORMAL);
3743 #   ifdef _SC_PAGESIZE
3744                         page_size = sysconf(_SC_PAGESIZE);
3745 #   else
3746                         page_size = sysconf(_SC_PAGE_SIZE);
3747 #   endif
3748                         if ((long) page_size < 0) {
3749                             if (errno) {
3750                                 SV *error = ERRSV;
3751                                 char *msg;
3752                                 STRLEN n_a;
3753                                 (void) SvUPGRADE(error, SVt_PV);
3754                                 msg = SvPVx(error, n_a);
3755                                 Perl_croak(aTHX_ "panic: sysconf: %s",
3756                                            msg);
3757                             }
3758                             else
3759                                 Perl_croak(aTHX_
3760                                            "panic: sysconf: pagesize unknown");
3761                         }
3762                     }
3763 #else
3764 #   ifdef HAS_GETPAGESIZE
3765                     page_size = getpagesize();
3766 #   else
3767 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3768                     page_size = PAGESIZE;       /* compiletime, bad */
3769 #       endif
3770 #   endif
3771 #endif
3772                     if ((IV) page_size <= 0)
3773                         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3774                                    (IV) page_size);
3775                 }
3776                 if (b->posn < 0) {
3777                     /*
3778                      * This is a hack - should never happen - open should
3779                      * have set it !
3780                      */
3781                     b->posn = PerlIO_tell(PerlIONext(f));
3782                 }
3783                 posn = (b->posn / page_size) * page_size;
3784                 len = st.st_size - posn;
3785                 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3786                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3787 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3788                     madvise(m->mptr, len, MADV_SEQUENTIAL);
3789 #endif
3790 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3791                     madvise(m->mptr, len, MADV_WILLNEED);
3792 #endif
3793                     PerlIOBase(f)->flags =
3794                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3795                     b->end = ((STDCHAR *) m->mptr) + len;
3796                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3797                     b->ptr = b->buf;
3798                     m->len = len;
3799                 }
3800                 else {
3801                     b->buf = NULL;
3802                 }
3803             }
3804             else {
3805                 PerlIOBase(f)->flags =
3806                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3807                 b->buf = NULL;
3808                 b->ptr = b->end = b->ptr;
3809                 code = -1;
3810             }
3811         }
3812     }
3813     return code;
3814 }
3815
3816 IV
3817 PerlIOMmap_unmap(pTHX_ PerlIO *f)
3818 {
3819     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3820     PerlIOBuf *b = &m->base;
3821     IV code = 0;
3822     if (m->len) {
3823         if (b->buf) {
3824             code = munmap(m->mptr, m->len);
3825             b->buf = NULL;
3826             m->len = 0;
3827             m->mptr = NULL;
3828             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3829                 code = -1;
3830         }
3831         b->ptr = b->end = b->buf;
3832         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3833     }
3834     return code;
3835 }
3836
3837 STDCHAR *
3838 PerlIOMmap_get_base(pTHX_ PerlIO *f)
3839 {
3840     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3841     PerlIOBuf *b = &m->base;
3842     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3843         /*
3844          * Already have a readbuffer in progress
3845          */
3846         return b->buf;
3847     }
3848     if (b->buf) {
3849         /*
3850          * We have a write buffer or flushed PerlIOBuf read buffer
3851          */
3852         m->bbuf = b->buf;       /* save it in case we need it again */
3853         b->buf = NULL;          /* Clear to trigger below */
3854     }
3855     if (!b->buf) {
3856         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
3857         if (!b->buf) {
3858             /*
3859              * Map did not work - recover PerlIOBuf buffer if we have one
3860              */
3861             b->buf = m->bbuf;
3862         }
3863     }
3864     b->ptr = b->end = b->buf;
3865     if (b->buf)
3866         return b->buf;
3867     return PerlIOBuf_get_base(aTHX_ f);
3868 }
3869
3870 SSize_t
3871 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3872 {
3873     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3874     PerlIOBuf *b = &m->base;
3875     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3876         PerlIO_flush(f);
3877     if (b->ptr && (b->ptr - count) >= b->buf
3878         && memEQ(b->ptr - count, vbuf, count)) {
3879         b->ptr -= count;
3880         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3881         return count;
3882     }
3883     if (m->len) {
3884         /*
3885          * Loose the unwritable mapped buffer
3886          */
3887         PerlIO_flush(f);
3888         /*
3889          * If flush took the "buffer" see if we have one from before
3890          */
3891         if (!b->buf && m->bbuf)
3892             b->buf = m->bbuf;
3893         if (!b->buf) {
3894             PerlIOBuf_get_base(aTHX_ f);
3895             m->bbuf = b->buf;
3896         }
3897     }
3898     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3899 }
3900
3901 SSize_t
3902 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3903 {
3904     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3905     PerlIOBuf *b = &m->base;
3906     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3907         /*
3908          * No, or wrong sort of, buffer
3909          */
3910         if (m->len) {
3911             if (PerlIOMmap_unmap(aTHX_ f) != 0)
3912                 return 0;
3913         }
3914         /*
3915          * If unmap took the "buffer" see if we have one from before
3916          */
3917         if (!b->buf && m->bbuf)
3918             b->buf = m->bbuf;
3919         if (!b->buf) {
3920             PerlIOBuf_get_base(aTHX_ f);
3921             m->bbuf = b->buf;
3922         }
3923     }
3924     return PerlIOBuf_write(aTHX_ f, vbuf, count);
3925 }
3926
3927 IV
3928 PerlIOMmap_flush(pTHX_ PerlIO *f)
3929 {
3930     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3931     PerlIOBuf *b = &m->base;
3932     IV code = PerlIOBuf_flush(aTHX_ f);
3933     /*
3934      * Now we are "synced" at PerlIOBuf level
3935      */
3936     if (b->buf) {
3937         if (m->len) {
3938             /*
3939              * Unmap the buffer
3940              */
3941             if (PerlIOMmap_unmap(aTHX_ f) != 0)
3942                 code = -1;
3943         }
3944         else {
3945             /*
3946              * We seem to have a PerlIOBuf buffer which was not mapped
3947              * remember it in case we need one later
3948              */
3949             m->bbuf = b->buf;
3950         }
3951     }
3952     return code;
3953 }
3954
3955 IV
3956 PerlIOMmap_fill(pTHX_ PerlIO *f)
3957 {
3958     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3959     IV code = PerlIO_flush(f);
3960     if (code == 0 && !b->buf) {
3961         code = PerlIOMmap_map(aTHX_ f);
3962     }
3963     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3964         code = PerlIOBuf_fill(aTHX_ f);
3965     }
3966     return code;
3967 }
3968
3969 IV
3970 PerlIOMmap_close(pTHX_ PerlIO *f)
3971 {
3972     PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3973     PerlIOBuf *b = &m->base;
3974     IV code = PerlIO_flush(f);
3975     if (m->bbuf) {
3976         b->buf = m->bbuf;
3977         m->bbuf = NULL;
3978         b->ptr = b->end = b->buf;
3979     }
3980     if (PerlIOBuf_close(aTHX_ f) != 0)
3981         code = -1;
3982     return code;
3983 }
3984
3985 PerlIO *
3986 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3987 {
3988  return PerlIOBase_dup(aTHX_ f, o, param, flags);
3989 }
3990
3991
3992 PerlIO_funcs PerlIO_mmap = {
3993     "mmap",
3994     sizeof(PerlIOMmap),
3995     PERLIO_K_BUFFERED,
3996     PerlIOBuf_pushed,
3997     PerlIOBase_noop_ok,
3998     PerlIOBuf_open,
3999     NULL,
4000     PerlIOBase_fileno,
4001     PerlIOMmap_dup,
4002     PerlIOBuf_read,
4003     PerlIOMmap_unread,
4004     PerlIOMmap_write,
4005     PerlIOBuf_seek,
4006     PerlIOBuf_tell,
4007     PerlIOBuf_close,
4008     PerlIOMmap_flush,
4009     PerlIOMmap_fill,
4010     PerlIOBase_eof,
4011     PerlIOBase_error,
4012     PerlIOBase_clearerr,
4013     PerlIOBase_setlinebuf,
4014     PerlIOMmap_get_base,
4015     PerlIOBuf_bufsiz,
4016     PerlIOBuf_get_ptr,
4017     PerlIOBuf_get_cnt,
4018     PerlIOBuf_set_ptrcnt,
4019 };
4020
4021 #endif                          /* HAS_MMAP */
4022
4023 PerlIO *
4024 Perl_PerlIO_stdin(pTHX)
4025 {
4026     if (!PL_perlio) {
4027         PerlIO_stdstreams(aTHX);
4028     }
4029     return &PL_perlio[1];
4030 }
4031
4032 PerlIO *
4033 Perl_PerlIO_stdout(pTHX)
4034 {
4035     if (!PL_perlio) {
4036         PerlIO_stdstreams(aTHX);
4037     }
4038     return &PL_perlio[2];
4039 }
4040
4041 PerlIO *
4042 Perl_PerlIO_stderr(pTHX)
4043 {
4044     if (!PL_perlio) {
4045         PerlIO_stdstreams(aTHX);
4046     }
4047     return &PL_perlio[3];
4048 }
4049
4050 /*--------------------------------------------------------------------------------------*/
4051
4052 char *
4053 PerlIO_getname(PerlIO *f, char *buf)
4054 {
4055     dTHX;
4056     char *name = NULL;
4057 #ifdef VMS
4058     FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4059     if (stdio)
4060         name = fgetname(stdio, buf);
4061 #else
4062     Perl_croak(aTHX_ "Don't know how to get file name");
4063 #endif
4064     return name;
4065 }
4066
4067
4068 /*--------------------------------------------------------------------------------------*/
4069 /*
4070  * Functions which can be called on any kind of PerlIO implemented in
4071  * terms of above
4072  */
4073
4074 #undef PerlIO_fdopen
4075 PerlIO *
4076 PerlIO_fdopen(int fd, const char *mode)
4077 {
4078     dTHX;
4079     return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4080 }
4081
4082 #undef PerlIO_open
4083 PerlIO *
4084 PerlIO_open(const char *path, const char *mode)
4085 {
4086     dTHX;
4087     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4088     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4089 }
4090
4091 #undef Perlio_reopen
4092 PerlIO *
4093 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4094 {
4095     dTHX;
4096     SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4097     return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4098 }
4099
4100 #undef PerlIO_getc
4101 int
4102 PerlIO_getc(PerlIO *f)
4103 {
4104     dTHX;
4105     STDCHAR buf[1];
4106     SSize_t count = PerlIO_read(f, buf, 1);
4107     if (count == 1) {
4108         return (unsigned char) buf[0];
4109     }
4110     return EOF;
4111 }
4112
4113 #undef PerlIO_ungetc
4114 int
4115 PerlIO_ungetc(PerlIO *f, int ch)
4116 {
4117     dTHX;
4118     if (ch != EOF) {
4119         STDCHAR buf = ch;
4120         if (PerlIO_unread(f, &buf, 1) == 1)
4121             return ch;
4122     }
4123     return EOF;
4124 }
4125
4126 #undef PerlIO_putc
4127 int
4128 PerlIO_putc(PerlIO *f, int ch)
4129 {
4130     dTHX;
4131     STDCHAR buf = ch;
4132     return PerlIO_write(f, &buf, 1);
4133 }
4134
4135 #undef PerlIO_puts
4136 int
4137 PerlIO_puts(PerlIO *f, const char *s)
4138 {
4139     dTHX;
4140     STRLEN len = strlen(s);
4141     return PerlIO_write(f, s, len);
4142 }
4143
4144 #undef PerlIO_rewind
4145 void
4146 PerlIO_rewind(PerlIO *f)
4147 {
4148     dTHX;
4149     PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4150     PerlIO_clearerr(f);
4151 }
4152
4153 #undef PerlIO_vprintf
4154 int
4155 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4156 {
4157     dTHX;
4158     SV *sv = newSVpvn("", 0);
4159     char *s;
4160     STRLEN len;
4161     SSize_t wrote;
4162 #ifdef NEED_VA_COPY
4163     va_list apc;
4164     Perl_va_copy(ap, apc);
4165     sv_vcatpvf(sv, fmt, &apc);
4166 #else
4167     sv_vcatpvf(sv, fmt, &ap);
4168 #endif
4169     s = SvPV(sv, len);
4170     wrote = PerlIO_write(f, s, len);
4171     SvREFCNT_dec(sv);
4172     return wrote;
4173 }
4174
4175 #undef PerlIO_printf
4176 int
4177 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4178 {
4179     va_list ap;
4180     int result;
4181     va_start(ap, fmt);
4182     result = PerlIO_vprintf(f, fmt, ap);
4183     va_end(ap);
4184     return result;
4185 }
4186
4187 #undef PerlIO_stdoutf
4188 int
4189 PerlIO_stdoutf(const char *fmt, ...)
4190 {
4191     dTHX;
4192     va_list ap;
4193     int result;
4194     va_start(ap, fmt);
4195     result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4196     va_end(ap);
4197     return result;
4198 }
4199
4200 #undef PerlIO_tmpfile
4201 PerlIO *
4202 PerlIO_tmpfile(void)
4203 {
4204     /*
4205      * I have no idea how portable mkstemp() is ...
4206      */
4207 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4208     dTHX;
4209     PerlIO *f = NULL;
4210     FILE *stdio = PerlSIO_tmpfile();
4211     if (stdio) {
4212         PerlIOStdio *s =
4213             PerlIOSelf(PerlIO_push
4214                        (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4215                         "w+", Nullsv), PerlIOStdio);
4216         s->stdio = stdio;
4217     }
4218     return f;
4219 #else
4220     dTHX;
4221     SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4222     int fd = mkstemp(SvPVX(sv));
4223     PerlIO *f = NULL;
4224     if (fd >= 0) {
4225         f = PerlIO_fdopen(fd, "w+");
4226         if (f) {
4227             PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4228         }
4229         PerlLIO_unlink(SvPVX(sv));
4230         SvREFCNT_dec(sv);
4231     }
4232     return f;
4233 #endif
4234 }
4235
4236 #undef HAS_FSETPOS
4237 #undef HAS_FGETPOS
4238
4239 #endif                          /* USE_SFIO */
4240 #endif                          /* PERLIO_IS_STDIO */
4241
4242 /*======================================================================================*/
4243 /*
4244  * Now some functions in terms of above which may be needed even if we are
4245  * not in true PerlIO mode
4246  */
4247
4248 #ifndef HAS_FSETPOS
4249 #undef PerlIO_setpos
4250 int
4251 PerlIO_setpos(PerlIO *f, SV *pos)
4252 {
4253     dTHX;
4254     if (SvOK(pos)) {
4255         STRLEN len;
4256         Off_t *posn = (Off_t *) SvPV(pos, len);
4257         if (f && len == sizeof(Off_t))
4258             return PerlIO_seek(f, *posn, SEEK_SET);
4259     }
4260     SETERRNO(EINVAL, SS$_IVCHAN);
4261     return -1;
4262 }
4263 #else
4264 #undef PerlIO_setpos
4265 int
4266 PerlIO_setpos(PerlIO *f, SV *pos)
4267 {
4268     dTHX;
4269     if (SvOK(pos)) {
4270         STRLEN len;
4271         Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4272         if (f && len == sizeof(Fpos_t)) {
4273 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4274             return fsetpos64(f, fpos);
4275 #else
4276             return fsetpos(f, fpos);
4277 #endif
4278         }
4279     }
4280     SETERRNO(EINVAL, SS$_IVCHAN);
4281     return -1;
4282 }
4283 #endif
4284
4285 #ifndef HAS_FGETPOS
4286 #undef PerlIO_getpos
4287 int
4288 PerlIO_getpos(PerlIO *f, SV *pos)
4289 {
4290     dTHX;
4291     Off_t posn = PerlIO_tell(f);
4292     sv_setpvn(pos, (char *) &posn, sizeof(posn));
4293     return (posn == (Off_t) - 1) ? -1 : 0;
4294 }
4295 #else
4296 #undef PerlIO_getpos
4297 int
4298 PerlIO_getpos(PerlIO *f, SV *pos)
4299 {
4300     dTHX;
4301     Fpos_t fpos;
4302     int code;
4303 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4304     code = fgetpos64(f, &fpos);
4305 #else
4306     code = fgetpos(f, &fpos);
4307 #endif
4308     sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4309     return code;
4310 }
4311 #endif
4312
4313 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4314
4315 int
4316 vprintf(char *pat, char *args)
4317 {
4318     _doprnt(pat, args, stdout);
4319     return 0;                   /* wrong, but perl doesn't use the return
4320                                  * value */
4321 }
4322
4323 int
4324 vfprintf(FILE *fd, char *pat, char *args)
4325 {
4326     _doprnt(pat, args, fd);
4327     return 0;                   /* wrong, but perl doesn't use the return
4328                                  * value */
4329 }
4330
4331 #endif
4332
4333 #ifndef PerlIO_vsprintf
4334 int
4335 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4336 {
4337     int val = vsprintf(s, fmt, ap);
4338     if (n >= 0) {
4339         if (strlen(s) >= (STRLEN) n) {
4340             dTHX;
4341             (void) PerlIO_puts(Perl_error_log,
4342                                "panic: sprintf overflow - memory corrupted!\n");
4343             my_exit(1);
4344         }
4345     }
4346     return val;
4347 }
4348 #endif
4349
4350 #ifndef PerlIO_sprintf
4351 int
4352 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4353 {
4354     va_list ap;
4355     int result;
4356     va_start(ap, fmt);
4357     result = PerlIO_vsprintf(s, n, fmt, ap);
4358     va_end(ap);
4359     return result;
4360 }
4361 #endif
4362
4363
4364
4365
4366