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