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 '%s'\n",f,tab->name,
 688                  (mode) ? mode : "(Null)",(arg) ? SvPV_nolen(arg) : "(Null)");
 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  if (fd >= 0 && PerlLIO_isatty(fd))
2310   {
2311    PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2312   }
2313  posn = PerlIO_tell(PerlIONext(f));
2314  if (posn != (Off_t) -1)
2315   {
2316    b->posn = posn;
2317   }
2318  return PerlIOBase_pushed(f,mode,arg);
2319 }
2320
2321 PerlIO *
2322 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)
2323 {
2324  if (f)
2325   {
2326    PerlIO *next = PerlIONext(f);
2327    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2328    next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2329    if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2330     {
2331      return NULL;
2332     }
2333   }
2334  else
2335   {
2336    PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2337    int init = 0;
2338    if (*mode == 'I')
2339     {
2340      init = 1;
2341      mode++;
2342     }
2343    f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2344    if (f)
2345     {
2346      PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2347      fd = PerlIO_fileno(f);
2348 #if O_BINARY != O_TEXT
2349      /* do something about failing setmode()? --jhi */
2350      PerlLIO_setmode(fd , O_BINARY);
2351 #endif
2352      if (init && fd == 2)
2353       {
2354        /* Initial stderr is unbuffered */
2355        PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2356       }
2357     }
2358   }
2359  return f;
2360 }
2361
2362 /* This "flush" is akin to sfio's sync in that it handles files in either
2363    read or write state
2364 */
2365 IV
2366 PerlIOBuf_flush(PerlIO *f)
2367 {
2368  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2369  int code = 0;
2370  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2371   {
2372    /* write() the buffer */
2373    STDCHAR *buf = b->buf;
2374    STDCHAR *p = buf;
2375    PerlIO *n = PerlIONext(f);
2376    while (p < b->ptr)
2377     {
2378      SSize_t count = PerlIO_write(n,p,b->ptr - p);
2379      if (count > 0)
2380       {
2381        p += count;
2382       }
2383      else if (count < 0 || PerlIO_error(n))
2384       {
2385        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2386        code = -1;
2387        break;
2388       }
2389     }
2390    b->posn += (p - buf);
2391   }
2392  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2393   {
2394    STDCHAR *buf = PerlIO_get_base(f);
2395    /* Note position change */
2396    b->posn += (b->ptr - buf);
2397    if (b->ptr < b->end)
2398     {
2399      /* We did not consume all of it */
2400      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2401       {
2402        b->posn = PerlIO_tell(PerlIONext(f));
2403       }
2404     }
2405   }
2406  b->ptr = b->end = b->buf;
2407  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2408  /* FIXME: Is this right for read case ? */
2409  if (PerlIO_flush(PerlIONext(f)) != 0)
2410   code = -1;
2411  return code;
2412 }
2413
2414 IV
2415 PerlIOBuf_fill(PerlIO *f)
2416 {
2417  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2418  PerlIO *n = PerlIONext(f);
2419  SSize_t avail;
2420  /* FIXME: doing the down-stream flush is a bad idea if it causes
2421     pre-read data in stdio buffer to be discarded
2422     but this is too simplistic - as it skips _our_ hosekeeping
2423     and breaks tell tests.
2424  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2425   {
2426   }
2427   */
2428  if (PerlIO_flush(f) != 0)
2429   return -1;
2430
2431  if (!b->buf)
2432   PerlIO_get_base(f); /* allocate via vtable */
2433
2434  b->ptr = b->end = b->buf;
2435  if (PerlIO_fast_gets(n))
2436   {
2437    /* Layer below is also buffered
2438     * We do _NOT_ want to call its ->Read() because that will loop
2439     * till it gets what we asked for which may hang on a pipe etc.
2440     * Instead take anything it has to hand, or ask it to fill _once_.
2441     */
2442    avail  = PerlIO_get_cnt(n);
2443    if (avail <= 0)
2444     {
2445      avail = PerlIO_fill(n);
2446      if (avail == 0)
2447       avail = PerlIO_get_cnt(n);
2448      else
2449       {
2450        if (!PerlIO_error(n) && PerlIO_eof(n))
2451         avail = 0;
2452       }
2453     }
2454    if (avail > 0)
2455     {
2456      STDCHAR *ptr = PerlIO_get_ptr(n);
2457      SSize_t cnt  = avail;
2458      if (avail > b->bufsiz)
2459       avail = b->bufsiz;
2460      Copy(ptr,b->buf,avail,STDCHAR);
2461      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2462     }
2463   }
2464  else
2465   {
2466    avail = PerlIO_read(n,b->ptr,b->bufsiz);
2467   }
2468  if (avail <= 0)
2469   {
2470    if (avail == 0)
2471     PerlIOBase(f)->flags |= PERLIO_F_EOF;
2472    else
2473     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2474    return -1;
2475   }
2476  b->end      = b->buf+avail;
2477  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2478  return 0;
2479 }
2480
2481 SSize_t
2482 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2483 {
2484  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2485  if (f)
2486   {
2487    if (!b->ptr)
2488     PerlIO_get_base(f);
2489    return PerlIOBase_read(f,vbuf,count);
2490   }
2491  return 0;
2492 }
2493
2494 SSize_t
2495 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2496 {
2497  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2498  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2499  SSize_t unread = 0;
2500  SSize_t avail;
2501  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2502   PerlIO_flush(f);
2503  if (!b->buf)
2504   PerlIO_get_base(f);
2505  if (b->buf)
2506   {
2507    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2508     {
2509      avail = (b->ptr - b->buf);
2510     }
2511    else
2512     {
2513      avail = b->bufsiz;
2514      b->end = b->buf + avail;
2515      b->ptr = b->end;
2516      PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2517      b->posn -= b->bufsiz;
2518     }
2519    if (avail > (SSize_t) count)
2520     avail = count;
2521    if (avail > 0)
2522     {
2523      b->ptr -= avail;
2524      buf    -= avail;
2525      if (buf != b->ptr)
2526       {
2527        Copy(buf,b->ptr,avail,STDCHAR);
2528       }
2529      count  -= avail;
2530      unread += avail;
2531      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2532     }
2533   }
2534  return unread;
2535 }
2536
2537 SSize_t
2538 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2539 {
2540  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2541  const STDCHAR *buf = (const STDCHAR *) vbuf;
2542  Size_t written = 0;
2543  if (!b->buf)
2544   PerlIO_get_base(f);
2545  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2546   return 0;
2547  while (count > 0)
2548   {
2549    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2550    if ((SSize_t) count < avail)
2551     avail = count;
2552    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2553    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2554     {
2555      while (avail > 0)
2556       {
2557        int ch = *buf++;
2558        *(b->ptr)++ = ch;
2559        count--;
2560        avail--;
2561        written++;
2562        if (ch == '\n')
2563         {
2564          PerlIO_flush(f);
2565          break;
2566         }
2567       }
2568     }
2569    else
2570     {
2571      if (avail)
2572       {
2573        Copy(buf,b->ptr,avail,STDCHAR);
2574        count   -= avail;
2575        buf     += avail;
2576        written += avail;
2577        b->ptr  += avail;
2578       }
2579     }
2580    if (b->ptr >= (b->buf + b->bufsiz))
2581     PerlIO_flush(f);
2582   }
2583  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2584   PerlIO_flush(f);
2585  return written;
2586 }
2587
2588 IV
2589 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2590 {
2591  IV code;
2592  if ((code = PerlIO_flush(f)) == 0)
2593   {
2594    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2595    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2596    code = PerlIO_seek(PerlIONext(f),offset,whence);
2597    if (code == 0)
2598     {
2599      b->posn = PerlIO_tell(PerlIONext(f));
2600     }
2601   }
2602  return code;
2603 }
2604
2605 Off_t
2606 PerlIOBuf_tell(PerlIO *f)
2607 {
2608  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2609  Off_t posn = b->posn;
2610  if (b->buf)
2611   posn += (b->ptr - b->buf);
2612  return posn;
2613 }
2614
2615 IV
2616 PerlIOBuf_close(PerlIO *f)
2617 {
2618  dTHX;
2619  IV code = PerlIOBase_close(f);
2620  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2621  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2622   {
2623    PerlMemShared_free(b->buf);
2624   }
2625  b->buf = NULL;
2626  b->ptr = b->end = b->buf;
2627  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2628  return code;
2629 }
2630
2631 STDCHAR *
2632 PerlIOBuf_get_ptr(PerlIO *f)
2633 {
2634  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2635  if (!b->buf)
2636   PerlIO_get_base(f);
2637  return b->ptr;
2638 }
2639
2640 SSize_t
2641 PerlIOBuf_get_cnt(PerlIO *f)
2642 {
2643  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2644  if (!b->buf)
2645   PerlIO_get_base(f);
2646  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2647   return (b->end - b->ptr);
2648  return 0;
2649 }
2650
2651 STDCHAR *
2652 PerlIOBuf_get_base(PerlIO *f)
2653 {
2654  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2655  if (!b->buf)
2656   {
2657    dTHX;
2658    if (!b->bufsiz)
2659     b->bufsiz = 4096;
2660    b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2661    if (!b->buf)
2662     {
2663      b->buf = (STDCHAR *)&b->oneword;
2664      b->bufsiz = sizeof(b->oneword);
2665     }
2666    b->ptr = b->buf;
2667    b->end = b->ptr;
2668   }
2669  return b->buf;
2670 }
2671
2672 Size_t
2673 PerlIOBuf_bufsiz(PerlIO *f)
2674 {
2675  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2676  if (!b->buf)
2677   PerlIO_get_base(f);
2678  return (b->end - b->buf);
2679 }
2680
2681 void
2682 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2683 {
2684  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2685  if (!b->buf)
2686   PerlIO_get_base(f);
2687  b->ptr = ptr;
2688  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2689   {
2690    dTHX;
2691    assert(PerlIO_get_cnt(f) == cnt);
2692    assert(b->ptr >= b->buf);
2693   }
2694  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2695 }
2696
2697 PerlIO_funcs PerlIO_perlio = {
2698  "perlio",
2699  sizeof(PerlIOBuf),
2700  PERLIO_K_BUFFERED,
2701  PerlIOBuf_pushed,
2702  PerlIOBase_noop_ok,
2703  PerlIOBuf_open,
2704  NULL,
2705  PerlIOBase_fileno,
2706  PerlIOBuf_read,
2707  PerlIOBuf_unread,
2708  PerlIOBuf_write,
2709  PerlIOBuf_seek,
2710  PerlIOBuf_tell,
2711  PerlIOBuf_close,
2712  PerlIOBuf_flush,
2713  PerlIOBuf_fill,
2714  PerlIOBase_eof,
2715  PerlIOBase_error,
2716  PerlIOBase_clearerr,
2717  PerlIOBase_setlinebuf,
2718  PerlIOBuf_get_base,
2719  PerlIOBuf_bufsiz,
2720  PerlIOBuf_get_ptr,
2721  PerlIOBuf_get_cnt,
2722  PerlIOBuf_set_ptrcnt,
2723 };
2724
2725 /*--------------------------------------------------------------------------------------*/
2726 /* Temp layer to hold unread chars when cannot do it any other way */
2727
2728 IV
2729 PerlIOPending_fill(PerlIO *f)
2730 {
2731  /* Should never happen */
2732  PerlIO_flush(f);
2733  return 0;
2734 }
2735
2736 IV
2737 PerlIOPending_close(PerlIO *f)
2738 {
2739  /* A tad tricky - flush pops us, then we close new top */
2740  PerlIO_flush(f);
2741  return PerlIO_close(f);
2742 }
2743
2744 IV
2745 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2746 {
2747  /* A tad tricky - flush pops us, then we seek new top */
2748  PerlIO_flush(f);
2749  return PerlIO_seek(f,offset,whence);
2750 }
2751
2752
2753 IV
2754 PerlIOPending_flush(PerlIO *f)
2755 {
2756  dTHX;
2757  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2758  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2759   {
2760    PerlMemShared_free(b->buf);
2761    b->buf = NULL;
2762   }
2763  PerlIO_pop(aTHX_ f);
2764  return 0;
2765 }
2766
2767 void
2768 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2769 {
2770  if (cnt <= 0)
2771   {
2772    PerlIO_flush(f);
2773   }
2774  else
2775   {
2776    PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2777   }
2778 }
2779
2780 IV
2781 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2782 {
2783  IV code    = PerlIOBase_pushed(f,mode,arg);
2784  PerlIOl *l = PerlIOBase(f);
2785  /* Our PerlIO_fast_gets must match what we are pushed on,
2786     or sv_gets() etc. get muddled when it changes mid-string
2787     when we auto-pop.
2788   */
2789  l->flags   = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2790               (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2791  return code;
2792 }
2793
2794 SSize_t
2795 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2796 {
2797  SSize_t avail = PerlIO_get_cnt(f);
2798  SSize_t got   = 0;
2799  if (count < avail)
2800   avail = count;
2801  if (avail > 0)
2802   got = PerlIOBuf_read(f,vbuf,avail);
2803  if (got >= 0 && got < count)
2804   {
2805    SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2806    if (more >= 0 || got == 0)
2807     got += more;
2808   }
2809  return got;
2810 }
2811
2812 PerlIO_funcs PerlIO_pending = {
2813  "pending",
2814  sizeof(PerlIOBuf),
2815  PERLIO_K_BUFFERED,
2816  PerlIOPending_pushed,
2817  PerlIOBase_noop_ok,
2818  NULL,
2819  NULL,
2820  PerlIOBase_fileno,
2821  PerlIOPending_read,
2822  PerlIOBuf_unread,
2823  PerlIOBuf_write,
2824  PerlIOPending_seek,
2825  PerlIOBuf_tell,
2826  PerlIOPending_close,
2827  PerlIOPending_flush,
2828  PerlIOPending_fill,
2829  PerlIOBase_eof,
2830  PerlIOBase_error,
2831  PerlIOBase_clearerr,
2832  PerlIOBase_setlinebuf,
2833  PerlIOBuf_get_base,
2834  PerlIOBuf_bufsiz,
2835  PerlIOBuf_get_ptr,
2836  PerlIOBuf_get_cnt,
2837  PerlIOPending_set_ptrcnt,
2838 };
2839
2840
2841
2842 /*--------------------------------------------------------------------------------------*/
2843 /* crlf - translation
2844    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2845    to hand back a line at a time and keeping a record of which nl we "lied" about.
2846    On write translate "\n" to CR,LF
2847  */
2848
2849 typedef struct
2850 {
2851  PerlIOBuf      base;         /* PerlIOBuf stuff */
2852  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2853 } PerlIOCrlf;
2854
2855 IV
2856 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2857 {
2858  IV code;
2859  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2860  code = PerlIOBuf_pushed(f,mode,arg);
2861 #if 0
2862  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2863               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2864               PerlIOBase(f)->flags);
2865 #endif
2866  return code;
2867 }
2868
2869
2870 SSize_t
2871 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2872 {
2873  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2874  if (c->nl)
2875   {
2876    *(c->nl) = 0xd;
2877    c->nl = NULL;
2878   }
2879  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2880   return PerlIOBuf_unread(f,vbuf,count);
2881  else
2882   {
2883    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2884    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2885    SSize_t unread = 0;
2886    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2887     PerlIO_flush(f);
2888    if (!b->buf)
2889     PerlIO_get_base(f);
2890    if (b->buf)
2891     {
2892      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2893       {
2894        b->end = b->ptr = b->buf + b->bufsiz;
2895        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2896        b->posn -= b->bufsiz;
2897       }
2898      while (count > 0 && b->ptr > b->buf)
2899       {
2900        int ch = *--buf;
2901        if (ch == '\n')
2902         {
2903          if (b->ptr - 2 >= b->buf)
2904           {
2905            *--(b->ptr) = 0xa;
2906            *--(b->ptr) = 0xd;
2907            unread++;
2908            count--;
2909           }
2910          else
2911           {
2912            buf++;
2913            break;
2914           }
2915         }
2916        else
2917         {
2918          *--(b->ptr) = ch;
2919          unread++;
2920          count--;
2921         }
2922       }
2923     }
2924    return unread;
2925   }
2926 }
2927
2928 SSize_t
2929 PerlIOCrlf_get_cnt(PerlIO *f)
2930 {
2931  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2932  if (!b->buf)
2933   PerlIO_get_base(f);
2934  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2935   {
2936    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2937    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2938     {
2939      STDCHAR *nl   = b->ptr;
2940     scan:
2941      while (nl < b->end && *nl != 0xd)
2942       nl++;
2943      if (nl < b->end && *nl == 0xd)
2944       {
2945      test:
2946        if (nl+1 < b->end)
2947         {
2948          if (nl[1] == 0xa)
2949           {
2950            *nl   = '\n';
2951            c->nl = nl;
2952           }
2953          else
2954           {
2955            /* Not CR,LF but just CR */
2956            nl++;
2957            goto scan;
2958           }
2959         }
2960        else
2961         {
2962          /* Blast - found CR as last char in buffer */
2963          if (b->ptr < nl)
2964           {
2965            /* They may not care, defer work as long as possible */
2966            return (nl - b->ptr);
2967           }
2968          else
2969           {
2970            int code;
2971            dTHX;
2972            b->ptr++;               /* say we have read it as far as flush() is concerned */
2973            b->buf++;               /* Leave space an front of buffer */
2974            b->bufsiz--;            /* Buffer is thus smaller */
2975            code = PerlIO_fill(f);  /* Fetch some more */
2976            b->bufsiz++;            /* Restore size for next time */
2977            b->buf--;               /* Point at space */
2978            b->ptr = nl = b->buf;   /* Which is what we hand off */
2979            b->posn--;              /* Buffer starts here */
2980            *nl = 0xd;              /* Fill in the CR */
2981            if (code == 0)
2982             goto test;             /* fill() call worked */
2983            /* CR at EOF - just fall through */
2984           }
2985         }
2986       }
2987     }
2988    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2989   }
2990  return 0;
2991 }
2992
2993 void
2994 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2995 {
2996  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2997  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2998  IV flags = PerlIOBase(f)->flags;
2999  if (!b->buf)
3000   PerlIO_get_base(f);
3001  if (!ptr)
3002   {
3003    if (c->nl)
3004     ptr = c->nl+1;
3005    else
3006     {
3007      ptr = b->end;
3008      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3009       ptr--;
3010     }
3011    ptr -= cnt;
3012   }
3013  else
3014   {
3015    /* Test code - delete when it works ... */
3016    STDCHAR *chk;
3017    if (c->nl)
3018     chk = c->nl+1;
3019    else
3020     {
3021      chk = b->end;
3022      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3023       chk--;
3024     }
3025    chk -= cnt;
3026
3027    if (ptr != chk)
3028     {
3029      dTHX;
3030      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3031                 ptr, chk, flags, c->nl, b->end, cnt);
3032     }
3033   }
3034  if (c->nl)
3035   {
3036    if (ptr > c->nl)
3037     {
3038      /* They have taken what we lied about */
3039      *(c->nl) = 0xd;
3040      c->nl = NULL;
3041      ptr++;
3042     }
3043   }
3044  b->ptr = ptr;
3045  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3046 }
3047
3048 SSize_t
3049 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3050 {
3051  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3052   return PerlIOBuf_write(f,vbuf,count);
3053  else
3054   {
3055    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3056    const STDCHAR *buf  = (const STDCHAR *) vbuf;
3057    const STDCHAR *ebuf = buf+count;
3058    if (!b->buf)
3059     PerlIO_get_base(f);
3060    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3061     return 0;
3062    while (buf < ebuf)
3063     {
3064      STDCHAR *eptr = b->buf+b->bufsiz;
3065      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3066      while (buf < ebuf && b->ptr < eptr)
3067       {
3068        if (*buf == '\n')
3069         {
3070          if ((b->ptr + 2) > eptr)
3071           {
3072            /* Not room for both */
3073            PerlIO_flush(f);
3074            break;
3075           }
3076          else
3077           {
3078            *(b->ptr)++ = 0xd; /* CR */
3079            *(b->ptr)++ = 0xa; /* LF */
3080            buf++;
3081            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3082             {
3083              PerlIO_flush(f);
3084              break;
3085             }
3086           }
3087         }
3088        else
3089         {
3090          int ch = *buf++;
3091          *(b->ptr)++ = ch;
3092         }
3093        if (b->ptr >= eptr)
3094         {
3095          PerlIO_flush(f);
3096          break;
3097         }
3098       }
3099     }
3100    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3101     PerlIO_flush(f);
3102    return (buf - (STDCHAR *) vbuf);
3103   }
3104 }
3105
3106 IV
3107 PerlIOCrlf_flush(PerlIO *f)
3108 {
3109  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3110  if (c->nl)
3111   {
3112    *(c->nl) = 0xd;
3113    c->nl = NULL;
3114   }
3115  return PerlIOBuf_flush(f);
3116 }
3117
3118 PerlIO_funcs PerlIO_crlf = {
3119  "crlf",
3120  sizeof(PerlIOCrlf),
3121  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3122  PerlIOCrlf_pushed,
3123  PerlIOBase_noop_ok,   /* popped */
3124  PerlIOBuf_open,
3125  NULL,
3126  PerlIOBase_fileno,
3127  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
3128  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
3129  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
3130  PerlIOBuf_seek,
3131  PerlIOBuf_tell,
3132  PerlIOBuf_close,
3133  PerlIOCrlf_flush,
3134  PerlIOBuf_fill,
3135  PerlIOBase_eof,
3136  PerlIOBase_error,
3137  PerlIOBase_clearerr,
3138  PerlIOBase_setlinebuf,
3139  PerlIOBuf_get_base,
3140  PerlIOBuf_bufsiz,
3141  PerlIOBuf_get_ptr,
3142  PerlIOCrlf_get_cnt,
3143  PerlIOCrlf_set_ptrcnt,
3144 };
3145
3146 #ifdef HAS_MMAP
3147 /*--------------------------------------------------------------------------------------*/
3148 /* mmap as "buffer" layer */
3149
3150 typedef struct
3151 {
3152  PerlIOBuf      base;         /* PerlIOBuf stuff */
3153  Mmap_t         mptr;        /* Mapped address */
3154  Size_t         len;          /* mapped length */
3155  STDCHAR        *bbuf;        /* malloced buffer if map fails */
3156 } PerlIOMmap;
3157
3158 static size_t page_size = 0;
3159
3160 IV
3161 PerlIOMmap_map(PerlIO *f)
3162 {
3163  dTHX;
3164  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3165  PerlIOBuf  *b = &m->base;
3166  IV flags = PerlIOBase(f)->flags;
3167  IV code  = 0;
3168  if (m->len)
3169   abort();
3170  if (flags & PERLIO_F_CANREAD)
3171   {
3172    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3173    int fd   = PerlIO_fileno(f);
3174    struct stat st;
3175    code = fstat(fd,&st);
3176    if (code == 0 && S_ISREG(st.st_mode))
3177     {
3178      SSize_t len = st.st_size - b->posn;
3179      if (len > 0)
3180       {
3181        Off_t posn;
3182        if (!page_size) {
3183 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3184            {
3185                SETERRNO(0,SS$_NORMAL);
3186 #   ifdef _SC_PAGESIZE
3187                page_size = sysconf(_SC_PAGESIZE);
3188 #   else
3189                page_size = sysconf(_SC_PAGE_SIZE);
3190 #   endif
3191                if ((long)page_size < 0) {
3192                    if (errno) {
3193                        SV *error = ERRSV;
3194                        char *msg;
3195                        STRLEN n_a;
3196                        (void)SvUPGRADE(error, SVt_PV);
3197                        msg = SvPVx(error, n_a);
3198                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3199                    }
3200                    else
3201                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3202                }
3203            }
3204 #else
3205 #   ifdef HAS_GETPAGESIZE
3206         page_size = getpagesize();
3207 #   else
3208 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
3209         page_size = PAGESIZE; /* compiletime, bad */
3210 #       endif
3211 #   endif
3212 #endif
3213         if ((IV)page_size <= 0)
3214             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3215        }
3216        if (b->posn < 0)
3217         {
3218          /* This is a hack - should never happen - open should have set it ! */
3219          b->posn = PerlIO_tell(PerlIONext(f));
3220         }
3221        posn = (b->posn / page_size) * page_size;
3222        len  = st.st_size - posn;
3223        m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3224        if (m->mptr && m->mptr != (Mmap_t) -1)
3225         {
3226 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3227          madvise(m->mptr, len, MADV_SEQUENTIAL);
3228 #endif
3229 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3230          madvise(m->mptr, len, MADV_WILLNEED);
3231 #endif
3232          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3233          b->end  = ((STDCHAR *)m->mptr) + len;
3234          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
3235          b->ptr  = b->buf;
3236          m->len  = len;
3237         }
3238        else
3239         {
3240          b->buf = NULL;
3241         }
3242       }
3243      else
3244       {
3245        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3246        b->buf = NULL;
3247        b->ptr = b->end = b->ptr;
3248        code = -1;
3249       }
3250     }
3251   }
3252  return code;
3253 }
3254
3255 IV
3256 PerlIOMmap_unmap(PerlIO *f)
3257 {
3258  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3259  PerlIOBuf  *b = &m->base;
3260  IV code = 0;
3261  if (m->len)
3262   {
3263    if (b->buf)
3264     {
3265      code = munmap(m->mptr, m->len);
3266      b->buf  = NULL;
3267      m->len  = 0;
3268      m->mptr = NULL;
3269      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3270       code = -1;
3271     }
3272    b->ptr = b->end = b->buf;
3273    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3274   }
3275  return code;
3276 }
3277
3278 STDCHAR *
3279 PerlIOMmap_get_base(PerlIO *f)
3280 {
3281  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3282  PerlIOBuf  *b = &m->base;
3283  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3284   {
3285    /* Already have a readbuffer in progress */
3286    return b->buf;
3287   }
3288  if (b->buf)
3289   {
3290    /* We have a write buffer or flushed PerlIOBuf read buffer */
3291    m->bbuf = b->buf;  /* save it in case we need it again */
3292    b->buf  = NULL;    /* Clear to trigger below */
3293   }
3294  if (!b->buf)
3295   {
3296    PerlIOMmap_map(f);     /* Try and map it */
3297    if (!b->buf)
3298     {
3299      /* Map did not work - recover PerlIOBuf buffer if we have one */
3300      b->buf = m->bbuf;
3301     }
3302   }
3303  b->ptr  = b->end = b->buf;
3304  if (b->buf)
3305   return b->buf;
3306  return PerlIOBuf_get_base(f);
3307 }
3308
3309 SSize_t
3310 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3311 {
3312  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3313  PerlIOBuf  *b = &m->base;
3314  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3315   PerlIO_flush(f);
3316  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3317   {
3318    b->ptr -= count;
3319    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3320    return count;
3321   }
3322  if (m->len)
3323   {
3324    /* Loose the unwritable mapped buffer */
3325    PerlIO_flush(f);
3326    /* If flush took the "buffer" see if we have one from before */
3327    if (!b->buf && m->bbuf)
3328     b->buf = m->bbuf;
3329    if (!b->buf)
3330     {
3331      PerlIOBuf_get_base(f);
3332      m->bbuf = b->buf;
3333     }
3334   }
3335 return PerlIOBuf_unread(f,vbuf,count);
3336 }
3337
3338 SSize_t
3339 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3340 {
3341  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3342  PerlIOBuf  *b = &m->base;
3343  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3344   {
3345    /* No, or wrong sort of, buffer */
3346    if (m->len)
3347     {
3348      if (PerlIOMmap_unmap(f) != 0)
3349       return 0;
3350     }
3351    /* If unmap took the "buffer" see if we have one from before */
3352    if (!b->buf && m->bbuf)
3353     b->buf = m->bbuf;
3354    if (!b->buf)
3355     {
3356      PerlIOBuf_get_base(f);
3357      m->bbuf = b->buf;
3358     }
3359   }
3360  return PerlIOBuf_write(f,vbuf,count);
3361 }
3362
3363 IV
3364 PerlIOMmap_flush(PerlIO *f)
3365 {
3366  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3367  PerlIOBuf  *b = &m->base;
3368  IV code = PerlIOBuf_flush(f);
3369  /* Now we are "synced" at PerlIOBuf level */
3370  if (b->buf)
3371   {
3372    if (m->len)
3373     {
3374      /* Unmap the buffer */
3375      if (PerlIOMmap_unmap(f) != 0)
3376       code = -1;
3377     }
3378    else
3379     {
3380      /* We seem to have a PerlIOBuf buffer which was not mapped
3381       * remember it in case we need one later
3382       */
3383      m->bbuf = b->buf;
3384     }
3385   }
3386  return code;
3387 }
3388
3389 IV
3390 PerlIOMmap_fill(PerlIO *f)
3391 {
3392  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3393  IV code = PerlIO_flush(f);
3394  if (code == 0 && !b->buf)
3395   {
3396    code = PerlIOMmap_map(f);
3397   }
3398  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3399   {
3400    code = PerlIOBuf_fill(f);
3401   }
3402  return code;
3403 }
3404
3405 IV
3406 PerlIOMmap_close(PerlIO *f)
3407 {
3408  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3409  PerlIOBuf  *b = &m->base;
3410  IV code = PerlIO_flush(f);
3411  if (m->bbuf)
3412   {
3413    b->buf  = m->bbuf;
3414    m->bbuf = NULL;
3415    b->ptr  = b->end = b->buf;
3416   }
3417  if (PerlIOBuf_close(f) != 0)
3418   code = -1;
3419  return code;
3420 }
3421
3422
3423 PerlIO_funcs PerlIO_mmap = {
3424  "mmap",
3425  sizeof(PerlIOMmap),
3426  PERLIO_K_BUFFERED,
3427  PerlIOBuf_pushed,
3428  PerlIOBase_noop_ok,
3429  PerlIOBuf_open,
3430  NULL,
3431  PerlIOBase_fileno,
3432  PerlIOBuf_read,
3433  PerlIOMmap_unread,
3434  PerlIOMmap_write,
3435  PerlIOBuf_seek,
3436  PerlIOBuf_tell,
3437  PerlIOBuf_close,
3438  PerlIOMmap_flush,
3439  PerlIOMmap_fill,
3440  PerlIOBase_eof,
3441  PerlIOBase_error,
3442  PerlIOBase_clearerr,
3443  PerlIOBase_setlinebuf,
3444  PerlIOMmap_get_base,
3445  PerlIOBuf_bufsiz,
3446  PerlIOBuf_get_ptr,
3447  PerlIOBuf_get_cnt,
3448  PerlIOBuf_set_ptrcnt,
3449 };
3450
3451 #endif /* HAS_MMAP */
3452
3453 void
3454 PerlIO_init(void)
3455 {
3456  if (!_perlio)
3457   {
3458 #ifndef WIN32
3459    atexit(&PerlIO_cleanup);
3460 #endif
3461   }
3462 }
3463
3464 #undef PerlIO_stdin
3465 PerlIO *
3466 PerlIO_stdin(void)
3467 {
3468  if (!_perlio)
3469   {
3470    dTHX;
3471    PerlIO_stdstreams(aTHX);
3472   }
3473  return &_perlio[1];
3474 }
3475
3476 #undef PerlIO_stdout
3477 PerlIO *
3478 PerlIO_stdout(void)
3479 {
3480  if (!_perlio)
3481   {
3482    dTHX;
3483    PerlIO_stdstreams(aTHX);
3484   }
3485  return &_perlio[2];
3486 }
3487
3488 #undef PerlIO_stderr
3489 PerlIO *
3490 PerlIO_stderr(void)
3491 {
3492  if (!_perlio)
3493   {
3494    dTHX;
3495    PerlIO_stdstreams(aTHX);
3496   }
3497  return &_perlio[3];
3498 }
3499
3500 /*--------------------------------------------------------------------------------------*/
3501
3502 #undef PerlIO_getname
3503 char *
3504 PerlIO_getname(PerlIO *f, char *buf)
3505 {
3506  dTHX;
3507  Perl_croak(aTHX_ "Don't know how to get file name");
3508  return NULL;
3509 }
3510
3511
3512 /*--------------------------------------------------------------------------------------*/
3513 /* Functions which can be called on any kind of PerlIO implemented
3514    in terms of above
3515 */
3516
3517 #undef PerlIO_getc
3518 int
3519 PerlIO_getc(PerlIO *f)
3520 {
3521  STDCHAR buf[1];
3522  SSize_t count = PerlIO_read(f,buf,1);
3523  if (count == 1)
3524   {
3525    return (unsigned char) buf[0];
3526   }
3527  return EOF;
3528 }
3529
3530 #undef PerlIO_ungetc
3531 int
3532 PerlIO_ungetc(PerlIO *f, int ch)
3533 {
3534  if (ch != EOF)
3535   {
3536    STDCHAR buf = ch;
3537    if (PerlIO_unread(f,&buf,1) == 1)
3538     return ch;
3539   }
3540  return EOF;
3541 }
3542
3543 #undef PerlIO_putc
3544 int
3545 PerlIO_putc(PerlIO *f, int ch)
3546 {
3547  STDCHAR buf = ch;
3548  return PerlIO_write(f,&buf,1);
3549 }
3550
3551 #undef PerlIO_puts
3552 int
3553 PerlIO_puts(PerlIO *f, const char *s)
3554 {
3555  STRLEN len = strlen(s);
3556  return PerlIO_write(f,s,len);
3557 }
3558
3559 #undef PerlIO_rewind
3560 void
3561 PerlIO_rewind(PerlIO *f)
3562 {
3563  PerlIO_seek(f,(Off_t)0,SEEK_SET);
3564  PerlIO_clearerr(f);
3565 }
3566
3567 #undef PerlIO_vprintf
3568 int
3569 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3570 {
3571  dTHX;
3572  SV *sv = newSVpvn("",0);
3573  char *s;
3574  STRLEN len;
3575  SSize_t wrote;
3576 #ifdef NEED_VA_COPY
3577  va_list apc;
3578  Perl_va_copy(ap, apc);
3579  sv_vcatpvf(sv, fmt, &apc);
3580 #else
3581  sv_vcatpvf(sv, fmt, &ap);
3582 #endif
3583  s = SvPV(sv,len);
3584  wrote = PerlIO_write(f,s,len);
3585  SvREFCNT_dec(sv);
3586  return wrote;
3587 }
3588
3589 #undef PerlIO_printf
3590 int
3591 PerlIO_printf(PerlIO *f,const char *fmt,...)
3592 {
3593  va_list ap;
3594  int result;
3595  va_start(ap,fmt);
3596  result = PerlIO_vprintf(f,fmt,ap);
3597  va_end(ap);
3598  return result;
3599 }
3600
3601 #undef PerlIO_stdoutf
3602 int
3603 PerlIO_stdoutf(const char *fmt,...)
3604 {
3605  va_list ap;
3606  int result;
3607  va_start(ap,fmt);
3608  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3609  va_end(ap);
3610  return result;
3611 }
3612
3613 #undef PerlIO_tmpfile
3614 PerlIO *
3615 PerlIO_tmpfile(void)
3616 {
3617  /* I have no idea how portable mkstemp() is ... */
3618 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3619  dTHX;
3620  PerlIO *f = NULL;
3621  FILE *stdio = PerlSIO_tmpfile();
3622  if (stdio)
3623   {
3624    PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3625    s->stdio  = stdio;
3626   }
3627  return f;
3628 #else
3629  dTHX;
3630  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3631  int fd = mkstemp(SvPVX(sv));
3632  PerlIO *f = NULL;
3633  if (fd >= 0)
3634   {
3635    f = PerlIO_fdopen(fd,"w+");
3636    if (f)
3637     {
3638      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3639     }
3640    PerlLIO_unlink(SvPVX(sv));
3641    SvREFCNT_dec(sv);
3642   }
3643  return f;
3644 #endif
3645 }
3646
3647 #undef HAS_FSETPOS
3648 #undef HAS_FGETPOS
3649
3650 #endif /* USE_SFIO */
3651 #endif /* PERLIO_IS_STDIO */
3652
3653 /*======================================================================================*/
3654 /* Now some functions in terms of above which may be needed even if
3655    we are not in true PerlIO mode
3656  */
3657
3658 #ifndef HAS_FSETPOS
3659 #undef PerlIO_setpos
3660 int
3661 PerlIO_setpos(PerlIO *f, SV *pos)
3662 {
3663  dTHX;
3664  if (SvOK(pos))
3665   {
3666    STRLEN len;
3667    Off_t *posn = (Off_t *) SvPV(pos,len);
3668    if (f && len == sizeof(Off_t))
3669     return PerlIO_seek(f,*posn,SEEK_SET);
3670   }
3671  errno = EINVAL;
3672  return -1;
3673 }
3674 #else
3675 #undef PerlIO_setpos
3676 int
3677 PerlIO_setpos(PerlIO *f, SV *pos)
3678 {
3679  dTHX;
3680  if (SvOK(pos))
3681   {
3682    STRLEN len;
3683    Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3684    if (f && len == sizeof(Fpos_t))
3685     {
3686 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3687      return fsetpos64(f, fpos);
3688 #else
3689      return fsetpos(f, fpos);
3690 #endif
3691     }
3692   }
3693  errno = EINVAL;
3694  return -1;
3695 }
3696 #endif
3697
3698 #ifndef HAS_FGETPOS
3699 #undef PerlIO_getpos
3700 int
3701 PerlIO_getpos(PerlIO *f, SV *pos)
3702 {
3703  dTHX;
3704  Off_t posn = PerlIO_tell(f);
3705  sv_setpvn(pos,(char *)&posn,sizeof(posn));
3706  return (posn == (Off_t)-1) ? -1 : 0;
3707 }
3708 #else
3709 #undef PerlIO_getpos
3710 int
3711 PerlIO_getpos(PerlIO *f, SV *pos)
3712 {
3713  dTHX;
3714  Fpos_t fpos;
3715  int code;
3716 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3717  code = fgetpos64(f, &fpos);
3718 #else
3719  code = fgetpos(f, &fpos);
3720 #endif
3721  sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3722  return code;
3723 }
3724 #endif
3725
3726 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3727
3728 int
3729 vprintf(char *pat, char *args)
3730 {
3731     _doprnt(pat, args, stdout);
3732     return 0;           /* wrong, but perl doesn't use the return value */
3733 }
3734
3735 int
3736 vfprintf(FILE *fd, char *pat, char *args)
3737 {
3738     _doprnt(pat, args, fd);
3739     return 0;           /* wrong, but perl doesn't use the return value */
3740 }
3741
3742 #endif
3743
3744 #ifndef PerlIO_vsprintf
3745 int
3746 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3747 {
3748  int val = vsprintf(s, fmt, ap);
3749  if (n >= 0)
3750   {
3751    if (strlen(s) >= (STRLEN)n)
3752     {
3753      dTHX;
3754      (void)PerlIO_puts(Perl_error_log,
3755                        "panic: sprintf overflow - memory corrupted!\n");
3756      my_exit(1);
3757     }
3758   }
3759  return val;
3760 }
3761 #endif
3762
3763 #ifndef PerlIO_sprintf
3764 int
3765 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3766 {
3767  va_list ap;
3768  int result;
3769  va_start(ap,fmt);
3770  result = PerlIO_vsprintf(s, n, fmt, ap);
3771  va_end(ap);
3772  return result;
3773 }
3774 #endif
3775
3776