perlio.c

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