perlio.c

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