perlio.c

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