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