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