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