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