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