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