perlio.c

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