perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2000, 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 #ifndef PERLIO_LAYERS
  32 int
  33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  34 {
  35  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  36   {
  37    return 0;
  38   }
  39  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
  40  /* NOTREACHED */
  41  return -1;
  42 }
  43
  44 int
  45 perlsio_binmode(FILE *fp, int iotype, int mode)
  46 {
  47 /* This used to be contents of do_binmode in doio.c */
  48 #ifdef DOSISH
  49 #  if defined(atarist) || defined(__MINT__)
  50     if (!fflush(fp)) {
  51         if (mode & O_BINARY)
  52             ((FILE*)fp)->_flag |= _IOBIN;
  53         else
  54             ((FILE*)fp)->_flag &= ~ _IOBIN;
  55         return 1;
  56     }
  57     return 0;
  58 #  else
  59     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  60 #    if defined(WIN32) && defined(__BORLANDC__)
  61         /* The translation mode of the stream is maintained independent
  62          * of the translation mode of the fd in the Borland RTL (heavy
  63          * digging through their runtime sources reveal).  User has to
  64          * set the mode explicitly for the stream (though they don't
  65          * document this anywhere). GSAR 97-5-24
  66          */
  67         fseek(fp,0L,0);
  68         if (mode & O_BINARY)
  69             fp->flags |= _F_BIN;
  70         else
  71             fp->flags &= ~ _F_BIN;
  72 #    endif
  73         return 1;
  74     }
  75     else
  76         return 0;
  77 #  endif
  78 #else
  79 #  if defined(USEMYBINMODE)
  80     if (my_binmode(fp, iotype, mode) != FALSE)
  81         return 1;
  82     else
  83         return 0;
  84 #  else
  85     return 1;
  86 #  endif
  87 #endif
  88 }
  89
  90 int
  91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
  92 {
  93  return perlsio_binmode(fp,iotype,mode);
  94 }
  95
  96 #endif
  97
  98 #if !defined(PERL_IMPLICIT_SYS)
  99
 100 #ifdef PERLIO_IS_STDIO
 101
 102 void
 103 PerlIO_init(void)
 104 {
 105  /* Does nothing (yet) except force this file to be included
 106     in perl binary. That allows this file to force inclusion
 107     of other functions that may be required by loadable
 108     extensions e.g. for FileHandle::tmpfile
 109  */
 110 }
 111
 112 #undef PerlIO_tmpfile
 113 PerlIO *
 114 PerlIO_tmpfile(void)
 115 {
 116  return tmpfile();
 117 }
 118
 119 #else /* PERLIO_IS_STDIO */
 120
 121 #ifdef USE_SFIO
 122
 123 #undef HAS_FSETPOS
 124 #undef HAS_FGETPOS
 125
 126 /* This section is just to make sure these functions
 127    get pulled in from libsfio.a
 128 */
 129
 130 #undef PerlIO_tmpfile
 131 PerlIO *
 132 PerlIO_tmpfile(void)
 133 {
 134  return sftmp(0);
 135 }
 136
 137 void
 138 PerlIO_init(void)
 139 {
 140  /* Force this file to be included  in perl binary. Which allows
 141   *  this file to force inclusion  of other functions that may be
 142   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 143   */
 144
 145  /* Hack
 146   * sfio does its own 'autoflush' on stdout in common cases.
 147   * Flush results in a lot of lseek()s to regular files and
 148   * lot of small writes to pipes.
 149   */
 150  sfset(sfstdout,SF_SHARE,0);
 151 }
 152
 153 #else /* USE_SFIO */
 154 /*======================================================================================*/
 155 /* Implement all the PerlIO interface ourselves.
 156  */
 157
 158 #include "perliol.h"
 159
 160 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 161 #ifdef I_UNISTD
 162 #include <unistd.h>
 163 #endif
 164 #ifdef HAS_MMAP
 165 #include <sys/mman.h>
 166 #endif
 167
 168 #include "XSUB.h"
 169
 170 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 171
 172 void
 173 PerlIO_debug(const char *fmt,...)
 174 {
 175  static int dbg = 0;
 176  va_list ap;
 177  va_start(ap,fmt);
 178  if (!dbg)
 179   {
 180    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 181    if (s && *s)
 182     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 183    else
 184     dbg = -1;
 185   }
 186  if (dbg > 0)
 187   {
 188    dTHX;
 189    SV *sv = newSVpvn("",0);
 190    char *s;
 191    STRLEN len;
 192    s = CopFILE(PL_curcop);
 193    if (!s)
 194     s = "(none)";
 195    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 196    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 197
 198    s = SvPV(sv,len);
 199    PerlLIO_write(dbg,s,len);
 200    SvREFCNT_dec(sv);
 201   }
 202  va_end(ap);
 203 }
 204
 205 /*--------------------------------------------------------------------------------------*/
 206
 207 /* Inner level routines */
 208
 209 /* Table of pointers to the PerlIO structs (malloc'ed) */
 210 PerlIO *_perlio      = NULL;
 211 #define PERLIO_TABLE_SIZE 64
 212
 213 PerlIO *
 214 PerlIO_allocate(void)
 215 {
 216  /* Find a free slot in the table, allocating new table as necessary */
 217  PerlIO **last = &_perlio;
 218  PerlIO *f;
 219  while ((f = *last))
 220   {
 221    int i;
 222    last = (PerlIO **)(f);
 223    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 224     {
 225      if (!*++f)
 226       {
 227        return f;
 228       }
 229     }
 230   }
 231  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 232  if (!f)
 233   return NULL;
 234  *last = f;
 235  return f+1;
 236 }
 237
 238 void
 239 PerlIO_cleantable(PerlIO **tablep)
 240 {
 241  PerlIO *table = *tablep;
 242  if (table)
 243   {
 244    int i;
 245    PerlIO_cleantable((PerlIO **) &(table[0]));
 246    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 247     {
 248      PerlIO *f = table+i;
 249      if (*f)
 250       {
 251        PerlIO_close(f);
 252       }
 253     }
 254    Safefree(table);
 255    *tablep = NULL;
 256   }
 257 }
 258
 259 HV *PerlIO_layer_hv;
 260 AV *PerlIO_layer_av;
 261
 262 void
 263 PerlIO_cleanup(void)
 264 {
 265  PerlIO_cleantable(&_perlio);
 266 }
 267
 268 void
 269 PerlIO_pop(PerlIO *f)
 270 {
 271  PerlIOl *l = *f;
 272  if (l)
 273   {
 274    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 275    (*l->tab->Popped)(f);
 276    *f = l->next;
 277    Safefree(l);
 278   }
 279 }
 280
 281 /*--------------------------------------------------------------------------------------*/
 282 /* XS Interface for perl code */
 283
 284 XS(XS_perlio_import)
 285 {
 286  dXSARGS;
 287  GV *gv = CvGV(cv);
 288  char *s = GvNAME(gv);
 289  STRLEN l = GvNAMELEN(gv);
 290  PerlIO_debug("%.*s\n",(int) l,s);
 291  XSRETURN_EMPTY;
 292 }
 293
 294 XS(XS_perlio_unimport)
 295 {
 296  dXSARGS;
 297  GV *gv = CvGV(cv);
 298  char *s = GvNAME(gv);
 299  STRLEN l = GvNAMELEN(gv);
 300  PerlIO_debug("%.*s\n",(int) l,s);
 301  XSRETURN_EMPTY;
 302 }
 303
 304 SV *
 305 PerlIO_find_layer(const char *name, STRLEN len)
 306 {
 307  dTHX;
 308  SV **svp;
 309  SV *sv;
 310  if (len <= 0)
 311   len = strlen(name);
 312  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 313  if (svp && (sv = *svp) && SvROK(sv))
 314   return *svp;
 315  return NULL;
 316 }
 317
 318
 319 static int
 320 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 321 {
 322  if (SvROK(sv))
 323   {
 324    IO *io = GvIOn((GV *)SvRV(sv));
 325    PerlIO *ifp = IoIFP(io);
 326    PerlIO *ofp = IoOFP(io);
 327    AV *av = (AV *) mg->mg_obj;
 328    Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
 329   }
 330  return 0;
 331 }
 332
 333 static int
 334 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 335 {
 336  if (SvROK(sv))
 337   {
 338    IO *io = GvIOn((GV *)SvRV(sv));
 339    PerlIO *ifp = IoIFP(io);
 340    PerlIO *ofp = IoOFP(io);
 341    AV *av = (AV *) mg->mg_obj;
 342    Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
 343   }
 344  return 0;
 345 }
 346
 347 static int
 348 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 349 {
 350  Perl_warn(aTHX_ "clear %"SVf,sv);
 351  return 0;
 352 }
 353
 354 static int
 355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 356 {
 357  Perl_warn(aTHX_ "free %"SVf,sv);
 358  return 0;
 359 }
 360
 361 MGVTBL perlio_vtab = {
 362  perlio_mg_get,
 363  perlio_mg_set,
 364  NULL, /* len */
 365  NULL,
 366  perlio_mg_free
 367 };
 368
 369 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 370 {
 371  dXSARGS;
 372  SV *sv    = SvRV(ST(1));
 373  AV *av    = newAV();
 374  MAGIC *mg;
 375  int count = 0;
 376  int i;
 377  sv_magic(sv, (SV *)av, '~', NULL, 0);
 378  SvRMAGICAL_off(sv);
 379  mg = mg_find(sv,'~');
 380  mg->mg_virtual = &perlio_vtab;
 381  mg_magical(sv);
 382  Perl_warn(aTHX_ "attrib %"SVf,sv);
 383  for (i=2; i < items; i++)
 384   {
 385    STRLEN len;
 386    const char *name = SvPV(ST(i),len);
 387    SV *layer  = PerlIO_find_layer(name,len);
 388    if (layer)
 389     {
 390      av_push(av,SvREFCNT_inc(layer));
 391     }
 392    else
 393     {
 394      ST(count) = ST(i);
 395      count++;
 396     }
 397   }
 398  SvREFCNT_dec(av);
 399  XSRETURN(count);
 400 }
 401
 402 void
 403 PerlIO_define_layer(PerlIO_funcs *tab)
 404 {
 405  dTHX;
 406  HV *stash = gv_stashpv("perlio::Layer", TRUE);
 407  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
 408  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 409 }
 410
 411 PerlIO_funcs *
 412 PerlIO_default_layer(I32 n)
 413 {
 414  dTHX;
 415  SV **svp;
 416  SV *layer;
 417  PerlIO_funcs *tab = &PerlIO_stdio;
 418  int len;
 419  if (!PerlIO_layer_hv)
 420   {
 421    const char *s  = PerlEnv_getenv("PERLIO");
 422    newXS("perlio::import",XS_perlio_import,__FILE__);
 423    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 424 #if 0
 425    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 426 #endif
 427    PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
 428    PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
 429    PerlIO_define_layer(&PerlIO_unix);
 430    PerlIO_define_layer(&PerlIO_perlio);
 431    PerlIO_define_layer(&PerlIO_stdio);
 432    PerlIO_define_layer(&PerlIO_crlf);
 433 #ifdef HAS_MMAP
 434    PerlIO_define_layer(&PerlIO_mmap);
 435 #endif
 436    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
 437    if (s)
 438     {
 439      while (*s)
 440       {
 441        while (*s && isSPACE((unsigned char)*s))
 442         s++;
 443        if (*s)
 444         {
 445          const char *e = s;
 446          SV *layer;
 447          while (*e && !isSPACE((unsigned char)*e))
 448           e++;
 449          if (*s == ':')
 450           s++;
 451          layer = PerlIO_find_layer(s,e-s);
 452          if (layer)
 453           {
 454            PerlIO_debug("Pushing %.*s\n",(e-s),s);
 455            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
 456           }
 457          else
 458           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
 459          s = e;
 460         }
 461       }
 462     }
 463   }
 464  len  = av_len(PerlIO_layer_av);
 465  if (len < 1)
 466   {
 467    if (O_BINARY != O_TEXT)
 468     {
 469      av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
 470     }
 471    else
 472     {
 473      if (PerlIO_stdio.Set_ptrcnt)
 474       {
 475        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
 476       }
 477      else
 478       {
 479        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
 480       }
 481     }
 482    len  = av_len(PerlIO_layer_av);
 483   }
 484  if (n < 0)
 485   n += len+1;
 486  svp = av_fetch(PerlIO_layer_av,n,0);
 487  if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
 488   {
 489    tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
 490   }
 491  /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
 492  return tab;
 493 }
 494
 495 #define PerlIO_default_top() PerlIO_default_layer(-1)
 496 #define PerlIO_default_btm() PerlIO_default_layer(0)
 497
 498 void
 499 PerlIO_stdstreams()
 500 {
 501  if (!_perlio)
 502   {
 503    PerlIO_allocate();
 504    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
 505    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
 506    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
 507   }
 508 }
 509
 510 PerlIO *
 511 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 512 {
 513  PerlIOl *l = NULL;
 514  Newc('L',l,tab->size,char,PerlIOl);
 515  if (l)
 516   {
 517    Zero(l,tab->size,char);
 518    l->next = *f;
 519    l->tab  = tab;
 520    *f      = l;
 521    PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
 522    if ((*l->tab->Pushed)(f,mode) != 0)
 523     {
 524      PerlIO_pop(f);
 525      return NULL;
 526     }
 527   }
 528  return f;
 529 }
 530
 531 int
 532 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 533 {
 534  if (names)
 535   {
 536    const char *s = names;
 537    while (*s)
 538     {
 539      while (isSPACE(*s))
 540       s++;
 541      if (*s == ':')
 542       s++;
 543      if (*s)
 544       {
 545        const char *e = s;
 546        while (*e && *e != ':' && !isSPACE(*e))
 547         e++;
 548        if (e > s)
 549         {
 550          if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
 551           {
 552            /* Pop back to bottom layer */
 553            if (PerlIONext(f))
 554             {
 555              PerlIO_flush(f);
 556              while (PerlIONext(f))
 557               {
 558                PerlIO_pop(f);
 559               }
 560             }
 561           }
 562          else
 563           {
 564            SV *layer = PerlIO_find_layer(s,e-s);
 565            if (layer)
 566             {
 567              PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
 568              if (tab)
 569               {
 570                PerlIO *new = PerlIO_push(f,tab,mode);
 571                if (!new)
 572                 return -1;
 573               }
 574             }
 575            else
 576             Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
 577           }
 578         }
 579        s = e;
 580       }
 581     }
 582   }
 583  return 0;
 584 }
 585
 586
 587
 588 /*--------------------------------------------------------------------------------------*/
 589 /* Given the abstraction above the public API functions */
 590
 591 int
 592 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 593 {
 594  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 595               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 596  if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
 597   {
 598    PerlIO *top = f;
 599    PerlIOl *l;
 600    while (l = *top)
 601     {
 602      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 603       {
 604        PerlIO_flush(top);
 605        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 606        break;
 607       }
 608      top = PerlIONext(top);
 609     }
 610   }
 611  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 612 }
 613
 614 #undef PerlIO__close
 615 int
 616 PerlIO__close(PerlIO *f)
 617 {
 618  return (*PerlIOBase(f)->tab->Close)(f);
 619 }
 620
 621
 622 #undef PerlIO_close
 623 int
 624 PerlIO_close(PerlIO *f)
 625 {
 626  int code = (*PerlIOBase(f)->tab->Close)(f);
 627  while (*f)
 628   {
 629    PerlIO_pop(f);
 630   }
 631  return code;
 632 }
 633
 634 #undef PerlIO_fileno
 635 int
 636 PerlIO_fileno(PerlIO *f)
 637 {
 638  return (*PerlIOBase(f)->tab->Fileno)(f);
 639 }
 640
 641
 642
 643 #undef PerlIO_fdopen
 644 PerlIO *
 645 PerlIO_fdopen(int fd, const char *mode)
 646 {
 647  PerlIO_funcs *tab = PerlIO_default_top();
 648  if (!_perlio)
 649   PerlIO_stdstreams();
 650  return (*tab->Fdopen)(tab,fd,mode);
 651 }
 652
 653 #undef PerlIO_open
 654 PerlIO *
 655 PerlIO_open(const char *path, const char *mode)
 656 {
 657  PerlIO_funcs *tab = PerlIO_default_top();
 658  if (!_perlio)
 659   PerlIO_stdstreams();
 660  return (*tab->Open)(tab,path,mode);
 661 }
 662
 663 #undef PerlIO_reopen
 664 PerlIO *
 665 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 666 {
 667  if (f)
 668   {
 669    PerlIO_flush(f);
 670    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 671     {
 672      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 673       return f;
 674     }
 675    return NULL;
 676   }
 677  else
 678   return PerlIO_open(path,mode);
 679 }
 680
 681 #undef PerlIO_read
 682 SSize_t
 683 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 684 {
 685  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 686 }
 687
 688 #undef PerlIO_unread
 689 SSize_t
 690 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 691 {
 692  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 693 }
 694
 695 #undef PerlIO_write
 696 SSize_t
 697 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 698 {
 699  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 700 }
 701
 702 #undef PerlIO_seek
 703 int
 704 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 705 {
 706  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 707 }
 708
 709 #undef PerlIO_tell
 710 Off_t
 711 PerlIO_tell(PerlIO *f)
 712 {
 713  return (*PerlIOBase(f)->tab->Tell)(f);
 714 }
 715
 716 #undef PerlIO_flush
 717 int
 718 PerlIO_flush(PerlIO *f)
 719 {
 720  if (f)
 721   {
 722    return (*PerlIOBase(f)->tab->Flush)(f);
 723   }
 724  else
 725   {
 726    PerlIO **table = &_perlio;
 727    int code = 0;
 728    while ((f = *table))
 729     {
 730      int i;
 731      table = (PerlIO **)(f++);
 732      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 733       {
 734        if (*f && PerlIO_flush(f) != 0)
 735         code = -1;
 736        f++;
 737       }
 738     }
 739    return code;
 740   }
 741 }
 742
 743 #undef PerlIO_fill
 744 int
 745 PerlIO_fill(PerlIO *f)
 746 {
 747  return (*PerlIOBase(f)->tab->Fill)(f);
 748 }
 749
 750 #undef PerlIO_isutf8
 751 int
 752 PerlIO_isutf8(PerlIO *f)
 753 {
 754  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 755 }
 756
 757 #undef PerlIO_eof
 758 int
 759 PerlIO_eof(PerlIO *f)
 760 {
 761  return (*PerlIOBase(f)->tab->Eof)(f);
 762 }
 763
 764 #undef PerlIO_error
 765 int
 766 PerlIO_error(PerlIO *f)
 767 {
 768  return (*PerlIOBase(f)->tab->Error)(f);
 769 }
 770
 771 #undef PerlIO_clearerr
 772 void
 773 PerlIO_clearerr(PerlIO *f)
 774 {
 775  if (f && *f)
 776   (*PerlIOBase(f)->tab->Clearerr)(f);
 777 }
 778
 779 #undef PerlIO_setlinebuf
 780 void
 781 PerlIO_setlinebuf(PerlIO *f)
 782 {
 783  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 784 }
 785
 786 #undef PerlIO_has_base
 787 int
 788 PerlIO_has_base(PerlIO *f)
 789 {
 790  if (f && *f)
 791   {
 792    return (PerlIOBase(f)->tab->Get_base != NULL);
 793   }
 794  return 0;
 795 }
 796
 797 #undef PerlIO_fast_gets
 798 int
 799 PerlIO_fast_gets(PerlIO *f)
 800 {
 801  if (f && *f)
 802   {
 803    PerlIOl *l = PerlIOBase(f);
 804    return (l->tab->Set_ptrcnt != NULL);
 805   }
 806  return 0;
 807 }
 808
 809 #undef PerlIO_has_cntptr
 810 int
 811 PerlIO_has_cntptr(PerlIO *f)
 812 {
 813  if (f && *f)
 814   {
 815    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 816    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 817   }
 818  return 0;
 819 }
 820
 821 #undef PerlIO_canset_cnt
 822 int
 823 PerlIO_canset_cnt(PerlIO *f)
 824 {
 825  if (f && *f)
 826   {
 827    PerlIOl *l = PerlIOBase(f);
 828    return (l->tab->Set_ptrcnt != NULL);
 829   }
 830  return 0;
 831 }
 832
 833 #undef PerlIO_get_base
 834 STDCHAR *
 835 PerlIO_get_base(PerlIO *f)
 836 {
 837  return (*PerlIOBase(f)->tab->Get_base)(f);
 838 }
 839
 840 #undef PerlIO_get_bufsiz
 841 int
 842 PerlIO_get_bufsiz(PerlIO *f)
 843 {
 844  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 845 }
 846
 847 #undef PerlIO_get_ptr
 848 STDCHAR *
 849 PerlIO_get_ptr(PerlIO *f)
 850 {
 851  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 852 }
 853
 854 #undef PerlIO_get_cnt
 855 int
 856 PerlIO_get_cnt(PerlIO *f)
 857 {
 858  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 859 }
 860
 861 #undef PerlIO_set_cnt
 862 void
 863 PerlIO_set_cnt(PerlIO *f,int cnt)
 864 {
 865  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 866 }
 867
 868 #undef PerlIO_set_ptrcnt
 869 void
 870 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 871 {
 872  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 873 }
 874
 875 /*--------------------------------------------------------------------------------------*/
 876 /* "Methods" of the "base class" */
 877
 878 IV
 879 PerlIOBase_fileno(PerlIO *f)
 880 {
 881  return PerlIO_fileno(PerlIONext(f));
 882 }
 883
 884 char *
 885 PerlIO_modestr(PerlIO *f,char *buf)
 886 {
 887  char *s = buf;
 888  IV flags = PerlIOBase(f)->flags;
 889  if (flags & PERLIO_F_CANREAD)
 890   *s++ = 'r';
 891  if (flags & PERLIO_F_CANWRITE)
 892   *s++ = 'w';
 893  if (flags & PERLIO_F_CRLF)
 894   *s++ = 't';
 895  else
 896   *s++ = 'b';
 897  *s = '\0';
 898  return buf;
 899 }
 900
 901 IV
 902 PerlIOBase_pushed(PerlIO *f, const char *mode)
 903 {
 904  PerlIOl *l = PerlIOBase(f);
 905  const char *omode = mode;
 906  char temp[8];
 907  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 908                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 909  if (mode)
 910   {
 911    switch (*mode++)
 912     {
 913      case 'r':
 914       l->flags |= PERLIO_F_CANREAD;
 915       break;
 916      case 'a':
 917       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 918       break;
 919      case 'w':
 920       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 921       break;
 922      default:
 923       errno = EINVAL;
 924       return -1;
 925     }
 926    while (*mode)
 927     {
 928      switch (*mode++)
 929       {
 930        case '+':
 931         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 932         break;
 933        case 'b':
 934         l->flags &= ~PERLIO_F_CRLF;
 935         break;
 936        case 't':
 937         l->flags |= PERLIO_F_CRLF;
 938         break;
 939       default:
 940        errno = EINVAL;
 941        return -1;
 942       }
 943     }
 944   }
 945  else
 946   {
 947    if (l->next)
 948     {
 949      l->flags |= l->next->flags &
 950                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 951     }
 952   }
 953  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
 954               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
 955               l->flags,PerlIO_modestr(f,temp));
 956  return 0;
 957 }
 958
 959 IV
 960 PerlIOBase_popped(PerlIO *f)
 961 {
 962  return 0;
 963 }
 964
 965 SSize_t
 966 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 967 {
 968  Off_t old = PerlIO_tell(f);
 969  if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
 970   {
 971    Off_t new = PerlIO_tell(f);
 972    return old - new;
 973   }
 974  return 0;
 975 }
 976
 977 IV
 978 PerlIOBase_noop_ok(PerlIO *f)
 979 {
 980  return 0;
 981 }
 982
 983 IV
 984 PerlIOBase_noop_fail(PerlIO *f)
 985 {
 986  return -1;
 987 }
 988
 989 IV
 990 PerlIOBase_close(PerlIO *f)
 991 {
 992  IV code = 0;
 993  PerlIO *n = PerlIONext(f);
 994  if (PerlIO_flush(f) != 0)
 995   code = -1;
 996  if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
 997   code = -1;
 998  PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
 999  return code;
1000 }
1001
1002 IV
1003 PerlIOBase_eof(PerlIO *f)
1004 {
1005  if (f && *f)
1006   {
1007    return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1008   }
1009  return 1;
1010 }
1011
1012 IV
1013 PerlIOBase_error(PerlIO *f)
1014 {
1015  if (f && *f)
1016   {
1017    return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1018   }
1019  return 1;
1020 }
1021
1022 void
1023 PerlIOBase_clearerr(PerlIO *f)
1024 {
1025  if (f && *f)
1026   {
1027    PerlIO *n = PerlIONext(f);
1028    PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1029    if (n)
1030     PerlIO_clearerr(n);
1031   }
1032 }
1033
1034 void
1035 PerlIOBase_setlinebuf(PerlIO *f)
1036 {
1037
1038 }
1039
1040 /*--------------------------------------------------------------------------------------*/
1041 /* Bottom-most level for UNIX-like case */
1042
1043 typedef struct
1044 {
1045  struct _PerlIO base;       /* The generic part */
1046  int            fd;         /* UNIX like file descriptor */
1047  int            oflags;     /* open/fcntl flags */
1048 } PerlIOUnix;
1049
1050 int
1051 PerlIOUnix_oflags(const char *mode)
1052 {
1053  int oflags = -1;
1054  switch(*mode)
1055   {
1056    case 'r':
1057     oflags = O_RDONLY;
1058     if (*++mode == '+')
1059      {
1060       oflags = O_RDWR;
1061       mode++;
1062      }
1063     break;
1064
1065    case 'w':
1066     oflags = O_CREAT|O_TRUNC;
1067     if (*++mode == '+')
1068      {
1069       oflags |= O_RDWR;
1070       mode++;
1071      }
1072     else
1073      oflags |= O_WRONLY;
1074     break;
1075
1076    case 'a':
1077     oflags = O_CREAT|O_APPEND;
1078     if (*++mode == '+')
1079      {
1080       oflags |= O_RDWR;
1081       mode++;
1082      }
1083     else
1084      oflags |= O_WRONLY;
1085     break;
1086   }
1087  if (*mode == 'b')
1088   {
1089    oflags |=  O_BINARY;
1090    oflags &= ~O_TEXT;
1091    mode++;
1092   }
1093  else if (*mode == 't')
1094   {
1095    oflags |=  O_TEXT;
1096    oflags &= ~O_BINARY;
1097    mode++;
1098   }
1099  /* Always open in binary mode */
1100  oflags |= O_BINARY;
1101  if (*mode || oflags == -1)
1102   {
1103    errno = EINVAL;
1104    oflags = -1;
1105   }
1106  return oflags;
1107 }
1108
1109 IV
1110 PerlIOUnix_fileno(PerlIO *f)
1111 {
1112  return PerlIOSelf(f,PerlIOUnix)->fd;
1113 }
1114
1115 PerlIO *
1116 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1117 {
1118  PerlIO *f = NULL;
1119  if (*mode == 'I')
1120   mode++;
1121  if (fd >= 0)
1122   {
1123    int oflags = PerlIOUnix_oflags(mode);
1124    if (oflags != -1)
1125     {
1126      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1127      s->fd     = fd;
1128      s->oflags = oflags;
1129      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1130     }
1131   }
1132  return f;
1133 }
1134
1135 PerlIO *
1136 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1137 {
1138  PerlIO *f = NULL;
1139  int oflags = PerlIOUnix_oflags(mode);
1140  if (oflags != -1)
1141   {
1142    int fd = PerlLIO_open3(path,oflags,0666);
1143    if (fd >= 0)
1144     {
1145      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
1146      s->fd     = fd;
1147      s->oflags = oflags;
1148      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1149     }
1150   }
1151  return f;
1152 }
1153
1154 int
1155 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1156 {
1157  PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1158  int oflags = PerlIOUnix_oflags(mode);
1159  if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1160   (*PerlIOBase(f)->tab->Close)(f);
1161  if (oflags != -1)
1162   {
1163    int fd = PerlLIO_open3(path,oflags,0666);
1164    if (fd >= 0)
1165     {
1166      s->fd = fd;
1167      s->oflags = oflags;
1168      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1169      return 0;
1170     }
1171   }
1172  return -1;
1173 }
1174
1175 SSize_t
1176 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1177 {
1178  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1179  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1180   return 0;
1181  while (1)
1182   {
1183    SSize_t len = PerlLIO_read(fd,vbuf,count);
1184    if (len >= 0 || errno != EINTR)
1185     {
1186      if (len < 0)
1187       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1188      else if (len == 0 && count != 0)
1189       PerlIOBase(f)->flags |= PERLIO_F_EOF;
1190      return len;
1191     }
1192   }
1193 }
1194
1195 SSize_t
1196 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1197 {
1198  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1199  while (1)
1200   {
1201    SSize_t len = PerlLIO_write(fd,vbuf,count);
1202    if (len >= 0 || errno != EINTR)
1203     {
1204      if (len < 0)
1205       PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1206      return len;
1207     }
1208   }
1209 }
1210
1211 IV
1212 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1213 {
1214  Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1215  PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1216  return (new == (Off_t) -1) ? -1 : 0;
1217 }
1218
1219 Off_t
1220 PerlIOUnix_tell(PerlIO *f)
1221 {
1222  return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1223 }
1224
1225 IV
1226 PerlIOUnix_close(PerlIO *f)
1227 {
1228  int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1229  int code = 0;
1230  while (PerlLIO_close(fd) != 0)
1231   {
1232    if (errno != EINTR)
1233     {
1234      code = -1;
1235      break;
1236     }
1237   }
1238  if (code == 0)
1239   {
1240    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1241   }
1242  return code;
1243 }
1244
1245 PerlIO_funcs PerlIO_unix = {
1246  "unix",
1247  sizeof(PerlIOUnix),
1248  PERLIO_K_RAW,
1249  PerlIOUnix_fileno,
1250  PerlIOUnix_fdopen,
1251  PerlIOUnix_open,
1252  PerlIOUnix_reopen,
1253  PerlIOBase_pushed,
1254  PerlIOBase_noop_ok,
1255  PerlIOUnix_read,
1256  PerlIOBase_unread,
1257  PerlIOUnix_write,
1258  PerlIOUnix_seek,
1259  PerlIOUnix_tell,
1260  PerlIOUnix_close,
1261  PerlIOBase_noop_ok,   /* flush */
1262  PerlIOBase_noop_fail, /* fill */
1263  PerlIOBase_eof,
1264  PerlIOBase_error,
1265  PerlIOBase_clearerr,
1266  PerlIOBase_setlinebuf,
1267  NULL, /* get_base */
1268  NULL, /* get_bufsiz */
1269  NULL, /* get_ptr */
1270  NULL, /* get_cnt */
1271  NULL, /* set_ptrcnt */
1272 };
1273
1274 /*--------------------------------------------------------------------------------------*/
1275 /* stdio as a layer */
1276
1277 typedef struct
1278 {
1279  struct _PerlIO base;
1280  FILE *         stdio;      /* The stream */
1281 } PerlIOStdio;
1282
1283 IV
1284 PerlIOStdio_fileno(PerlIO *f)
1285 {
1286  return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1287 }
1288
1289 const char *
1290 PerlIOStdio_mode(const char *mode,char *tmode)
1291 {
1292  const char *ret = mode;
1293  if (O_BINARY != O_TEXT)
1294   {
1295    ret = (const char *) tmode;
1296    while (*mode)
1297     {
1298      *tmode++ = *mode++;
1299     }
1300    *tmode++ = 'b';
1301    *tmode = '\0';
1302   }
1303  return ret;
1304 }
1305
1306 PerlIO *
1307 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1308 {
1309  PerlIO *f = NULL;
1310  int init = 0;
1311  char tmode[8];
1312  if (*mode == 'I')
1313   {
1314    init = 1;
1315    mode++;
1316   }
1317  if (fd >= 0)
1318   {
1319    FILE *stdio = NULL;
1320    if (init)
1321     {
1322      switch(fd)
1323       {
1324        case 0:
1325         stdio = stdin;
1326         break;
1327        case 1:
1328         stdio = stdout;
1329         break;
1330        case 2:
1331         stdio = stderr;
1332         break;
1333       }
1334     }
1335    else
1336     {
1337      stdio = fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1338     }
1339    if (stdio)
1340     {
1341      PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
1342      s->stdio  = stdio;
1343     }
1344   }
1345  return f;
1346 }
1347
1348 #undef PerlIO_importFILE
1349 PerlIO *
1350 PerlIO_importFILE(FILE *stdio, int fl)
1351 {
1352  PerlIO *f = NULL;
1353  if (stdio)
1354   {
1355    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1356    s->stdio  = stdio;
1357   }
1358  return f;
1359 }
1360
1361 PerlIO *
1362 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1363 {
1364  PerlIO *f = NULL;
1365  FILE *stdio = fopen(path,mode);
1366  if (stdio)
1367   {
1368    char tmode[8];
1369    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
1370                                (mode = PerlIOStdio_mode(mode,tmode))),
1371                                PerlIOStdio);
1372    s->stdio  = stdio;
1373   }
1374  return f;
1375 }
1376
1377 int
1378 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1379 {
1380  PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1381  char tmode[8];
1382  FILE *stdio = freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1383  if (!s->stdio)
1384   return -1;
1385  s->stdio = stdio;
1386  return 0;
1387 }
1388
1389 SSize_t
1390 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1391 {
1392  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1393  SSize_t got = 0;
1394  if (count == 1)
1395   {
1396    STDCHAR *buf = (STDCHAR *) vbuf;
1397    /* Perl is expecting PerlIO_getc() to fill the buffer
1398     * Linux's stdio does not do that for fread()
1399     */
1400    int ch = fgetc(s);
1401    if (ch != EOF)
1402     {
1403      *buf = ch;
1404      got = 1;
1405     }
1406   }
1407  else
1408   got = fread(vbuf,1,count,s);
1409  return got;
1410 }
1411
1412 SSize_t
1413 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1414 {
1415  FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1416  STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1417  SSize_t unread = 0;
1418  while (count > 0)
1419   {
1420    int ch = *buf-- & 0xff;
1421    if (ungetc(ch,s) != ch)
1422     break;
1423    unread++;
1424    count--;
1425   }
1426  return unread;
1427 }
1428
1429 SSize_t
1430 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1431 {
1432  return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1433 }
1434
1435 IV
1436 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1437 {
1438  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1439  return fseek(stdio,offset,whence);
1440 }
1441
1442 Off_t
1443 PerlIOStdio_tell(PerlIO *f)
1444 {
1445  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1446  return ftell(stdio);
1447 }
1448
1449 IV
1450 PerlIOStdio_close(PerlIO *f)
1451 {
1452  int optval, optlen = sizeof(int);
1453  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1454  return(
1455    (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1456        fclose(stdio) :
1457        close(PerlIO_fileno(f)));
1458 }
1459
1460 IV
1461 PerlIOStdio_flush(PerlIO *f)
1462 {
1463  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1464  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1465   {
1466    return fflush(stdio);
1467   }
1468  else
1469   {
1470 #if 0
1471    /* FIXME: This discards ungetc() and pre-read stuff which is
1472       not right if this is just a "sync" from a layer above
1473       Suspect right design is to do _this_ but not have layer above
1474       flush this layer read-to-read
1475     */
1476    /* Not writeable - sync by attempting a seek */
1477    int err = errno;
1478    if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1479     errno = err;
1480 #endif
1481   }
1482  return 0;
1483 }
1484
1485 IV
1486 PerlIOStdio_fill(PerlIO *f)
1487 {
1488  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1489  int c;
1490  /* fflush()ing read-only streams can cause trouble on some stdio-s */
1491  if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1492   {
1493    if (fflush(stdio) != 0)
1494     return EOF;
1495   }
1496  c = fgetc(stdio);
1497  if (c == EOF || ungetc(c,stdio) != c)
1498   return EOF;
1499  return 0;
1500 }
1501
1502 IV
1503 PerlIOStdio_eof(PerlIO *f)
1504 {
1505  return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1506 }
1507
1508 IV
1509 PerlIOStdio_error(PerlIO *f)
1510 {
1511  return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1512 }
1513
1514 void
1515 PerlIOStdio_clearerr(PerlIO *f)
1516 {
1517  clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1518 }
1519
1520 void
1521 PerlIOStdio_setlinebuf(PerlIO *f)
1522 {
1523 #ifdef HAS_SETLINEBUF
1524  setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1525 #else
1526  setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1527 #endif
1528 }
1529
1530 #ifdef FILE_base
1531 STDCHAR *
1532 PerlIOStdio_get_base(PerlIO *f)
1533 {
1534  FILE *stdio  = PerlIOSelf(f,PerlIOStdio)->stdio;
1535  return FILE_base(stdio);
1536 }
1537
1538 Size_t
1539 PerlIOStdio_get_bufsiz(PerlIO *f)
1540 {
1541  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1542  return FILE_bufsiz(stdio);
1543 }
1544 #endif
1545
1546 #ifdef USE_STDIO_PTR
1547 STDCHAR *
1548 PerlIOStdio_get_ptr(PerlIO *f)
1549 {
1550  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1551  return FILE_ptr(stdio);
1552 }
1553
1554 SSize_t
1555 PerlIOStdio_get_cnt(PerlIO *f)
1556 {
1557  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1558  return FILE_cnt(stdio);
1559 }
1560
1561 void
1562 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1563 {
1564  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1565  if (ptr != NULL)
1566   {
1567 #ifdef STDIO_PTR_LVALUE
1568    FILE_ptr(stdio) = ptr;
1569 #ifdef STDIO_PTR_LVAL_SETS_CNT
1570    if (FILE_cnt(stdio) != (cnt))
1571     {
1572      dTHX;
1573      assert(FILE_cnt(stdio) == (cnt));
1574     }
1575 #endif
1576 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1577    /* Setting ptr _does_ change cnt - we are done */
1578    return;
1579 #endif
1580 #else  /* STDIO_PTR_LVALUE */
1581    abort();
1582 #endif /* STDIO_PTR_LVALUE */
1583   }
1584 /* Now (or only) set cnt */
1585 #ifdef STDIO_CNT_LVALUE
1586  FILE_cnt(stdio) = cnt;
1587 #else  /* STDIO_CNT_LVALUE */
1588 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1589  FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1590 #else  /* STDIO_PTR_LVAL_SETS_CNT */
1591  abort();
1592 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1593 #endif /* STDIO_CNT_LVALUE */
1594 }
1595
1596 #endif
1597
1598 PerlIO_funcs PerlIO_stdio = {
1599  "stdio",
1600  sizeof(PerlIOStdio),
1601  PERLIO_K_BUFFERED,
1602  PerlIOStdio_fileno,
1603  PerlIOStdio_fdopen,
1604  PerlIOStdio_open,
1605  PerlIOStdio_reopen,
1606  PerlIOBase_pushed,
1607  PerlIOBase_noop_ok,
1608  PerlIOStdio_read,
1609  PerlIOStdio_unread,
1610  PerlIOStdio_write,
1611  PerlIOStdio_seek,
1612  PerlIOStdio_tell,
1613  PerlIOStdio_close,
1614  PerlIOStdio_flush,
1615  PerlIOStdio_fill,
1616  PerlIOStdio_eof,
1617  PerlIOStdio_error,
1618  PerlIOStdio_clearerr,
1619  PerlIOStdio_setlinebuf,
1620 #ifdef FILE_base
1621  PerlIOStdio_get_base,
1622  PerlIOStdio_get_bufsiz,
1623 #else
1624  NULL,
1625  NULL,
1626 #endif
1627 #ifdef USE_STDIO_PTR
1628  PerlIOStdio_get_ptr,
1629  PerlIOStdio_get_cnt,
1630 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1631  PerlIOStdio_set_ptrcnt
1632 #else  /* STDIO_PTR_LVALUE */
1633  NULL
1634 #endif /* STDIO_PTR_LVALUE */
1635 #else  /* USE_STDIO_PTR */
1636  NULL,
1637  NULL,
1638  NULL
1639 #endif /* USE_STDIO_PTR */
1640 };
1641
1642 #undef PerlIO_exportFILE
1643 FILE *
1644 PerlIO_exportFILE(PerlIO *f, int fl)
1645 {
1646  PerlIO_flush(f);
1647  /* Should really push stdio discipline when we have them */
1648  return fdopen(PerlIO_fileno(f),"r+");
1649 }
1650
1651 #undef PerlIO_findFILE
1652 FILE *
1653 PerlIO_findFILE(PerlIO *f)
1654 {
1655  return PerlIO_exportFILE(f,0);
1656 }
1657
1658 #undef PerlIO_releaseFILE
1659 void
1660 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1661 {
1662 }
1663
1664 /*--------------------------------------------------------------------------------------*/
1665 /* perlio buffer layer */
1666
1667 PerlIO *
1668 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1669 {
1670  PerlIO_funcs *tab = PerlIO_default_btm();
1671  int init = 0;
1672  PerlIO *f;
1673  if (*mode == 'I')
1674   {
1675    init = 1;
1676    mode++;
1677   }
1678 #if O_BINARY != O_TEXT
1679  /* do something about failing setmode()? --jhi */
1680  PerlLIO_setmode(fd, O_BINARY);
1681 #endif
1682  f = (*tab->Fdopen)(tab,fd,mode);
1683  if (f)
1684   {
1685    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1686    b->posn = PerlIO_tell(PerlIONext(f));
1687    if (init && fd == 2)
1688     {
1689      /* Initial stderr is unbuffered */
1690      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1691     }
1692    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1693                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1694   }
1695  return f;
1696 }
1697
1698 PerlIO *
1699 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1700 {
1701  PerlIO_funcs *tab = PerlIO_default_btm();
1702  PerlIO *f = (*tab->Open)(tab,path,mode);
1703  if (f)
1704   {
1705    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1706    b->posn = PerlIO_tell(PerlIONext(f));
1707   }
1708  return f;
1709 }
1710
1711 int
1712 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1713 {
1714  PerlIO *next = PerlIONext(f);
1715  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1716  if (code = 0)
1717   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1718  if (code == 0)
1719   {
1720    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1721    b->posn = PerlIO_tell(PerlIONext(f));
1722   }
1723  return code;
1724 }
1725
1726 /* This "flush" is akin to sfio's sync in that it handles files in either
1727    read or write state
1728 */
1729 IV
1730 PerlIOBuf_flush(PerlIO *f)
1731 {
1732  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1733  int code = 0;
1734  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1735   {
1736    /* write() the buffer */
1737    STDCHAR *p = b->buf;
1738    int count;
1739    PerlIO *n = PerlIONext(f);
1740    while (p < b->ptr)
1741     {
1742      count = PerlIO_write(n,p,b->ptr - p);
1743      if (count > 0)
1744       {
1745        p += count;
1746       }
1747      else if (count < 0 || PerlIO_error(n))
1748       {
1749        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1750        code = -1;
1751        break;
1752       }
1753     }
1754    b->posn += (p - b->buf);
1755   }
1756  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1757   {
1758    /* Note position change */
1759    b->posn += (b->ptr - b->buf);
1760    if (b->ptr < b->end)
1761     {
1762      /* We did not consume all of it */
1763      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1764       {
1765        b->posn = PerlIO_tell(PerlIONext(f));
1766       }
1767     }
1768   }
1769  b->ptr = b->end = b->buf;
1770  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1771  /* FIXME: Is this right for read case ? */
1772  if (PerlIO_flush(PerlIONext(f)) != 0)
1773   code = -1;
1774  return code;
1775 }
1776
1777 IV
1778 PerlIOBuf_fill(PerlIO *f)
1779 {
1780  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1781  PerlIO *n = PerlIONext(f);
1782  SSize_t avail;
1783  /* FIXME: doing the down-stream flush is a bad idea if it causes
1784     pre-read data in stdio buffer to be discarded
1785     but this is too simplistic - as it skips _our_ hosekeeping
1786     and breaks tell tests.
1787  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1788   {
1789   }
1790   */
1791  if (PerlIO_flush(f) != 0)
1792   return -1;
1793
1794  b->ptr = b->end = b->buf;
1795  if (PerlIO_fast_gets(n))
1796   {
1797    /* Layer below is also buffered
1798     * We do _NOT_ want to call its ->Read() because that will loop
1799     * till it gets what we asked for which may hang on a pipe etc.
1800     * Instead take anything it has to hand, or ask it to fill _once_.
1801     */
1802    avail  = PerlIO_get_cnt(n);
1803    if (avail <= 0)
1804     {
1805      avail = PerlIO_fill(n);
1806      if (avail == 0)
1807       avail = PerlIO_get_cnt(n);
1808      else
1809       {
1810        if (!PerlIO_error(n) && PerlIO_eof(n))
1811         avail = 0;
1812       }
1813     }
1814    if (avail > 0)
1815     {
1816      STDCHAR *ptr = PerlIO_get_ptr(n);
1817      SSize_t cnt  = avail;
1818      if (avail > b->bufsiz)
1819       avail = b->bufsiz;
1820      Copy(ptr,b->buf,avail,STDCHAR);
1821      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1822     }
1823   }
1824  else
1825   {
1826    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1827   }
1828  if (avail <= 0)
1829   {
1830    if (avail == 0)
1831     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1832    else
1833     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1834    return -1;
1835   }
1836  b->end      = b->buf+avail;
1837  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1838  return 0;
1839 }
1840
1841 SSize_t
1842 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1843 {
1844  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1845  STDCHAR *buf  = (STDCHAR *) vbuf;
1846  if (f)
1847   {
1848    if (!b->ptr)
1849     PerlIO_get_base(f);
1850    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1851     return 0;
1852    while (count > 0)
1853     {
1854      SSize_t avail = PerlIO_get_cnt(f);
1855      SSize_t take  = (count < avail) ? count : avail;
1856      if (take > 0)
1857       {
1858        STDCHAR *ptr = PerlIO_get_ptr(f);
1859        Copy(ptr,buf,take,STDCHAR);
1860        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1861        count   -= take;
1862        buf     += take;
1863       }
1864      if (count > 0  && avail <= 0)
1865       {
1866        if (PerlIO_fill(f) != 0)
1867         break;
1868       }
1869     }
1870    return (buf - (STDCHAR *) vbuf);
1871   }
1872  return 0;
1873 }
1874
1875 SSize_t
1876 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1877 {
1878  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1879  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1880  SSize_t unread = 0;
1881  SSize_t avail;
1882  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1883   PerlIO_flush(f);
1884  if (!b->buf)
1885   PerlIO_get_base(f);
1886  if (b->buf)
1887   {
1888    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1889     {
1890      avail = (b->ptr - b->buf);
1891      if (avail > (SSize_t) count)
1892       avail = count;
1893      b->ptr -= avail;
1894     }
1895    else
1896     {
1897      avail = b->bufsiz;
1898      if (avail > (SSize_t) count)
1899       avail = count;
1900      b->end = b->ptr + avail;
1901     }
1902    if (avail > 0)
1903     {
1904      buf    -= avail;
1905      if (buf != b->ptr)
1906       {
1907        Copy(buf,b->ptr,avail,STDCHAR);
1908       }
1909      count  -= avail;
1910      unread += avail;
1911      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1912     }
1913   }
1914  return unread;
1915 }
1916
1917 SSize_t
1918 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1919 {
1920  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1921  const STDCHAR *buf = (const STDCHAR *) vbuf;
1922  Size_t written = 0;
1923  if (!b->buf)
1924   PerlIO_get_base(f);
1925  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1926   return 0;
1927  while (count > 0)
1928   {
1929    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1930    if ((SSize_t) count < avail)
1931     avail = count;
1932    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1933    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1934     {
1935      while (avail > 0)
1936       {
1937        int ch = *buf++;
1938        *(b->ptr)++ = ch;
1939        count--;
1940        avail--;
1941        written++;
1942        if (ch == '\n')
1943         {
1944          PerlIO_flush(f);
1945          break;
1946         }
1947       }
1948     }
1949    else
1950     {
1951      if (avail)
1952       {
1953        Copy(buf,b->ptr,avail,STDCHAR);
1954        count   -= avail;
1955        buf     += avail;
1956        written += avail;
1957        b->ptr  += avail;
1958       }
1959     }
1960    if (b->ptr >= (b->buf + b->bufsiz))
1961     PerlIO_flush(f);
1962   }
1963  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1964   PerlIO_flush(f);
1965  return written;
1966 }
1967
1968 IV
1969 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1970 {
1971  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1972  int code = PerlIO_flush(f);
1973  if (code == 0)
1974   {
1975    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1976    code = PerlIO_seek(PerlIONext(f),offset,whence);
1977    if (code == 0)
1978     {
1979      b->posn = PerlIO_tell(PerlIONext(f));
1980     }
1981   }
1982  return code;
1983 }
1984
1985 Off_t
1986 PerlIOBuf_tell(PerlIO *f)
1987 {
1988  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1989  Off_t posn = b->posn;
1990  if (b->buf)
1991   posn += (b->ptr - b->buf);
1992  return posn;
1993 }
1994
1995 IV
1996 PerlIOBuf_close(PerlIO *f)
1997 {
1998  IV code = PerlIOBase_close(f);
1999  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2000  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2001   {
2002    Safefree(b->buf);
2003   }
2004  b->buf = NULL;
2005  b->ptr = b->end = b->buf;
2006  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2007  return code;
2008 }
2009
2010 void
2011 PerlIOBuf_setlinebuf(PerlIO *f)
2012 {
2013  if (f)
2014   {
2015    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2016   }
2017 }
2018
2019 STDCHAR *
2020 PerlIOBuf_get_ptr(PerlIO *f)
2021 {
2022  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2023  if (!b->buf)
2024   PerlIO_get_base(f);
2025  return b->ptr;
2026 }
2027
2028 SSize_t
2029 PerlIOBuf_get_cnt(PerlIO *f)
2030 {
2031  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2032  if (!b->buf)
2033   PerlIO_get_base(f);
2034  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2035   return (b->end - b->ptr);
2036  return 0;
2037 }
2038
2039 STDCHAR *
2040 PerlIOBuf_get_base(PerlIO *f)
2041 {
2042  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2043  if (!b->buf)
2044   {
2045    if (!b->bufsiz)
2046     b->bufsiz = 4096;
2047    New('B',b->buf,b->bufsiz,STDCHAR);
2048    if (!b->buf)
2049     {
2050      b->buf = (STDCHAR *)&b->oneword;
2051      b->bufsiz = sizeof(b->oneword);
2052     }
2053    b->ptr = b->buf;
2054    b->end = b->ptr;
2055   }
2056  return b->buf;
2057 }
2058
2059 Size_t
2060 PerlIOBuf_bufsiz(PerlIO *f)
2061 {
2062  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2063  if (!b->buf)
2064   PerlIO_get_base(f);
2065  return (b->end - b->buf);
2066 }
2067
2068 void
2069 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2070 {
2071  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2072  if (!b->buf)
2073   PerlIO_get_base(f);
2074  b->ptr = ptr;
2075  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2076   {
2077    dTHX;
2078    assert(PerlIO_get_cnt(f) == cnt);
2079    assert(b->ptr >= b->buf);
2080   }
2081  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2082 }
2083
2084 PerlIO_funcs PerlIO_perlio = {
2085  "perlio",
2086  sizeof(PerlIOBuf),
2087  PERLIO_K_BUFFERED,
2088  PerlIOBase_fileno,
2089  PerlIOBuf_fdopen,
2090  PerlIOBuf_open,
2091  PerlIOBuf_reopen,
2092  PerlIOBase_pushed,
2093  PerlIOBase_noop_ok,
2094  PerlIOBuf_read,
2095  PerlIOBuf_unread,
2096  PerlIOBuf_write,
2097  PerlIOBuf_seek,
2098  PerlIOBuf_tell,
2099  PerlIOBuf_close,
2100  PerlIOBuf_flush,
2101  PerlIOBuf_fill,
2102  PerlIOBase_eof,
2103  PerlIOBase_error,
2104  PerlIOBase_clearerr,
2105  PerlIOBuf_setlinebuf,
2106  PerlIOBuf_get_base,
2107  PerlIOBuf_bufsiz,
2108  PerlIOBuf_get_ptr,
2109  PerlIOBuf_get_cnt,
2110  PerlIOBuf_set_ptrcnt,
2111 };
2112
2113 /*--------------------------------------------------------------------------------------*/
2114 /* crlf - translation
2115    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2116    to hand back a line at a time and keeping a record of which nl we "lied" about.
2117    On write translate "\n" to CR,LF
2118  */
2119
2120 typedef struct
2121 {
2122  PerlIOBuf      base;         /* PerlIOBuf stuff */
2123  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2124 } PerlIOCrlf;
2125
2126 IV
2127 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2128 {
2129  IV code;
2130  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2131  code = PerlIOBase_pushed(f,mode);
2132  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2133               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2134               PerlIOBase(f)->flags);
2135  return code;
2136 }
2137
2138
2139 SSize_t
2140 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2141 {
2142  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2143  if (c->nl)
2144   {
2145    *(c->nl) = 0xd;
2146    c->nl = NULL;
2147   }
2148  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2149   return PerlIOBuf_unread(f,vbuf,count);
2150  else
2151   {
2152    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2153    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2154    SSize_t unread = 0;
2155    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2156     PerlIO_flush(f);
2157    if (!b->buf)
2158     PerlIO_get_base(f);
2159    if (b->buf)
2160     {
2161      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2162       {
2163        b->end = b->ptr = b->buf + b->bufsiz;
2164        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2165       }
2166      while (count > 0 && b->ptr > b->buf)
2167       {
2168        int ch = *--buf;
2169        if (ch == '\n')
2170         {
2171          if (b->ptr - 2 >= b->buf)
2172           {
2173            *--(b->ptr) = 0xa;
2174            *--(b->ptr) = 0xd;
2175            unread++;
2176            count--;
2177           }
2178          else
2179           {
2180            buf++;
2181            break;
2182           }
2183         }
2184        else
2185         {
2186          *--(b->ptr) = ch;
2187          unread++;
2188          count--;
2189         }
2190       }
2191     }
2192    return unread;
2193   }
2194 }
2195
2196 SSize_t
2197 PerlIOCrlf_get_cnt(PerlIO *f)
2198 {
2199  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2200  if (!b->buf)
2201   PerlIO_get_base(f);
2202  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2203   {
2204    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2205    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2206     {
2207      STDCHAR *nl   = b->ptr;
2208     scan:
2209      while (nl < b->end && *nl != 0xd)
2210       nl++;
2211      if (nl < b->end && *nl == 0xd)
2212       {
2213      test:
2214        if (nl+1 < b->end)
2215         {
2216          if (nl[1] == 0xa)
2217           {
2218            *nl   = '\n';
2219            c->nl = nl;
2220           }
2221          else
2222           {
2223            /* Not CR,LF but just CR */
2224            nl++;
2225            goto scan;
2226           }
2227         }
2228        else
2229         {
2230          /* Blast - found CR as last char in buffer */
2231          if (b->ptr < nl)
2232           {
2233            /* They may not care, defer work as long as possible */
2234            return (nl - b->ptr);
2235           }
2236          else
2237           {
2238            int code;
2239            dTHX;
2240            b->ptr++;               /* say we have read it as far as flush() is concerned */
2241            b->buf++;               /* Leave space an front of buffer */
2242            b->bufsiz--;            /* Buffer is thus smaller */
2243            code = PerlIO_fill(f);  /* Fetch some more */
2244            b->bufsiz++;            /* Restore size for next time */
2245            b->buf--;               /* Point at space */
2246            b->ptr = nl = b->buf;   /* Which is what we hand off */
2247            b->posn--;              /* Buffer starts here */
2248            *nl = 0xd;              /* Fill in the CR */
2249            if (code == 0)
2250             goto test;             /* fill() call worked */
2251            /* CR at EOF - just fall through */
2252           }
2253         }
2254       }
2255     }
2256    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2257   }
2258  return 0;
2259 }
2260
2261 void
2262 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2263 {
2264  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2265  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2266  IV flags = PerlIOBase(f)->flags;
2267  if (!b->buf)
2268   PerlIO_get_base(f);
2269  if (!ptr)
2270   {
2271    if (c->nl)
2272     ptr = c->nl+1;
2273    else
2274     {
2275      ptr = b->end;
2276      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2277       ptr--;
2278     }
2279    ptr -= cnt;
2280   }
2281  else
2282   {
2283    /* Test code - delete when it works ... */
2284    STDCHAR *chk;
2285    if (c->nl)
2286     chk = c->nl+1;
2287    else
2288     {
2289      chk = b->end;
2290      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2291       chk--;
2292     }
2293    chk -= cnt;
2294
2295    if (ptr != chk)
2296     {
2297      dTHX;
2298      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2299                 ptr, chk, flags, c->nl, b->end, cnt);
2300     }
2301   }
2302  if (c->nl)
2303   {
2304    if (ptr > c->nl)
2305     {
2306      /* They have taken what we lied about */
2307      *(c->nl) = 0xd;
2308      c->nl = NULL;
2309      ptr++;
2310     }
2311   }
2312  b->ptr = ptr;
2313  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2314 }
2315
2316 SSize_t
2317 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2318 {
2319  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2320   return PerlIOBuf_write(f,vbuf,count);
2321  else
2322   {
2323    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2324    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2325    const STDCHAR *ebuf = buf+count;
2326    if (!b->buf)
2327     PerlIO_get_base(f);
2328    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2329     return 0;
2330    while (buf < ebuf)
2331     {
2332      STDCHAR *eptr = b->buf+b->bufsiz;
2333      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2334      while (buf < ebuf && b->ptr < eptr)
2335       {
2336        if (*buf == '\n')
2337         {
2338          if ((b->ptr + 2) > eptr)
2339           {
2340            /* Not room for both */
2341            PerlIO_flush(f);
2342            break;
2343           }
2344          else
2345           {
2346            *(b->ptr)++ = 0xd; /* CR */
2347            *(b->ptr)++ = 0xa; /* LF */
2348            buf++;
2349            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2350             {
2351              PerlIO_flush(f);
2352              break;
2353             }
2354           }
2355         }
2356        else
2357         {
2358          int ch = *buf++;
2359          *(b->ptr)++ = ch;
2360         }
2361        if (b->ptr >= eptr)
2362         {
2363          PerlIO_flush(f);
2364          break;
2365         }
2366       }
2367     }
2368    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2369     PerlIO_flush(f);
2370    return (buf - (STDCHAR *) vbuf);
2371   }
2372 }
2373
2374 IV
2375 PerlIOCrlf_flush(PerlIO *f)
2376 {
2377  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2378  if (c->nl)
2379   {
2380    *(c->nl) = 0xd;
2381    c->nl = NULL;
2382   }
2383  return PerlIOBuf_flush(f);
2384 }
2385
2386 PerlIO_funcs PerlIO_crlf = {
2387  "crlf",
2388  sizeof(PerlIOCrlf),
2389  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2390  PerlIOBase_fileno,
2391  PerlIOBuf_fdopen,
2392  PerlIOBuf_open,
2393  PerlIOBuf_reopen,
2394  PerlIOCrlf_pushed,
2395  PerlIOBase_noop_ok,   /* popped */
2396  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2397  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2398  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2399  PerlIOBuf_seek,
2400  PerlIOBuf_tell,
2401  PerlIOBuf_close,
2402  PerlIOCrlf_flush,
2403  PerlIOBuf_fill,
2404  PerlIOBase_eof,
2405  PerlIOBase_error,
2406  PerlIOBase_clearerr,
2407  PerlIOBuf_setlinebuf,
2408  PerlIOBuf_get_base,
2409  PerlIOBuf_bufsiz,
2410  PerlIOBuf_get_ptr,
2411  PerlIOCrlf_get_cnt,
2412  PerlIOCrlf_set_ptrcnt,
2413 };
2414
2415 #ifdef HAS_MMAP
2416 /*--------------------------------------------------------------------------------------*/
2417 /* mmap as "buffer" layer */
2418
2419 typedef struct
2420 {
2421  PerlIOBuf      base;         /* PerlIOBuf stuff */
2422  Mmap_t         mptr;        /* Mapped address */
2423  Size_t         len;          /* mapped length */
2424  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2425 } PerlIOMmap;
2426
2427 static size_t page_size = 0;
2428
2429 IV
2430 PerlIOMmap_map(PerlIO *f)
2431 {
2432  dTHX;
2433  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2434  PerlIOBuf  *b = &m->base;
2435  IV flags = PerlIOBase(f)->flags;
2436  IV code  = 0;
2437  if (m->len)
2438   abort();
2439  if (flags & PERLIO_F_CANREAD)
2440   {
2441    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2442    int fd   = PerlIO_fileno(f);
2443    struct stat st;
2444    code = fstat(fd,&st);
2445    if (code == 0 && S_ISREG(st.st_mode))
2446     {
2447      SSize_t len = st.st_size - b->posn;
2448      if (len > 0)
2449       {
2450        Off_t posn;
2451        if (!page_size) {
2452 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2453            {
2454                SETERRNO(0,SS$_NORMAL);
2455 #   ifdef _SC_PAGESIZE
2456                page_size = sysconf(_SC_PAGESIZE);
2457 #   else
2458                page_size = sysconf(_SC_PAGE_SIZE);
2459 #   endif
2460                if ((long)page_size < 0) {
2461                    if (errno) {
2462                        SV *error = ERRSV;
2463                        char *msg;
2464                        STRLEN n_a;
2465                        (void)SvUPGRADE(error, SVt_PV);
2466                        msg = SvPVx(error, n_a);
2467                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2468                    }
2469                    else
2470                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2471                }
2472            }
2473 #else
2474 #   ifdef HAS_GETPAGESIZE
2475         page_size = getpagesize();
2476 #   else
2477 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2478         page_size = PAGESIZE; /* compiletime, bad */
2479 #       endif
2480 #   endif
2481 #endif
2482         if ((IV)page_size <= 0)
2483             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2484        }
2485        if (b->posn < 0)
2486         {
2487          /* This is a hack - should never happen - open should have set it ! */
2488          b->posn = PerlIO_tell(PerlIONext(f));
2489         }
2490        posn = (b->posn / page_size) * page_size;
2491        len  = st.st_size - posn;
2492        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2493        if (m->mptr && m->mptr != (Mmap_t) -1)
2494         {
2495 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2496          madvise(m->mptr, len, MADV_SEQUENTIAL);
2497 #endif
2498          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2499          b->end  = ((STDCHAR *)m->mptr) + len;
2500          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2501          b->ptr  = b->buf;
2502          m->len  = len;
2503         }
2504        else
2505         {
2506          b->buf = NULL;
2507         }
2508       }
2509      else
2510       {
2511        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2512        b->buf = NULL;
2513        b->ptr = b->end = b->ptr;
2514        code = -1;
2515       }
2516     }
2517   }
2518  return code;
2519 }
2520
2521 IV
2522 PerlIOMmap_unmap(PerlIO *f)
2523 {
2524  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2525  PerlIOBuf  *b = &m->base;
2526  IV code = 0;
2527  if (m->len)
2528   {
2529    if (b->buf)
2530     {
2531      code = munmap(m->mptr, m->len);
2532      b->buf  = NULL;
2533      m->len  = 0;
2534      m->mptr = NULL;
2535      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2536       code = -1;
2537     }
2538    b->ptr = b->end = b->buf;
2539    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2540   }
2541  return code;
2542 }
2543
2544 STDCHAR *
2545 PerlIOMmap_get_base(PerlIO *f)
2546 {
2547  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2548  PerlIOBuf  *b = &m->base;
2549  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2550   {
2551    /* Already have a readbuffer in progress */
2552    return b->buf;
2553   }
2554  if (b->buf)
2555   {
2556    /* We have a write buffer or flushed PerlIOBuf read buffer */
2557    m->bbuf = b->buf;  /* save it in case we need it again */
2558    b->buf  = NULL;    /* Clear to trigger below */
2559   }
2560  if (!b->buf)
2561   {
2562    PerlIOMmap_map(f);     /* Try and map it */
2563    if (!b->buf)
2564     {
2565      /* Map did not work - recover PerlIOBuf buffer if we have one */
2566      b->buf = m->bbuf;
2567     }
2568   }
2569  b->ptr  = b->end = b->buf;
2570  if (b->buf)
2571   return b->buf;
2572  return PerlIOBuf_get_base(f);
2573 }
2574
2575 SSize_t
2576 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2577 {
2578  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2579  PerlIOBuf  *b = &m->base;
2580  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2581   PerlIO_flush(f);
2582  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2583   {
2584    b->ptr -= count;
2585    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2586    return count;
2587   }
2588  if (m->len)
2589   {
2590    /* Loose the unwritable mapped buffer */
2591    PerlIO_flush(f);
2592    /* If flush took the "buffer" see if we have one from before */
2593    if (!b->buf && m->bbuf)
2594     b->buf = m->bbuf;
2595    if (!b->buf)
2596     {
2597      PerlIOBuf_get_base(f);
2598      m->bbuf = b->buf;
2599     }
2600   }
2601  return PerlIOBuf_unread(f,vbuf,count);
2602 }
2603
2604 SSize_t
2605 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2606 {
2607  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2608  PerlIOBuf  *b = &m->base;
2609  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2610   {
2611    /* No, or wrong sort of, buffer */
2612    if (m->len)
2613     {
2614      if (PerlIOMmap_unmap(f) != 0)
2615       return 0;
2616     }
2617    /* If unmap took the "buffer" see if we have one from before */
2618    if (!b->buf && m->bbuf)
2619     b->buf = m->bbuf;
2620    if (!b->buf)
2621     {
2622      PerlIOBuf_get_base(f);
2623      m->bbuf = b->buf;
2624     }
2625   }
2626  return PerlIOBuf_write(f,vbuf,count);
2627 }
2628
2629 IV
2630 PerlIOMmap_flush(PerlIO *f)
2631 {
2632  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2633  PerlIOBuf  *b = &m->base;
2634  IV code = PerlIOBuf_flush(f);
2635  /* Now we are "synced" at PerlIOBuf level */
2636  if (b->buf)
2637   {
2638    if (m->len)
2639     {
2640      /* Unmap the buffer */
2641      if (PerlIOMmap_unmap(f) != 0)
2642       code = -1;
2643     }
2644    else
2645     {
2646      /* We seem to have a PerlIOBuf buffer which was not mapped
2647       * remember it in case we need one later
2648       */
2649      m->bbuf = b->buf;
2650     }
2651   }
2652  return code;
2653 }
2654
2655 IV
2656 PerlIOMmap_fill(PerlIO *f)
2657 {
2658  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2659  IV code = PerlIO_flush(f);
2660  if (code == 0 && !b->buf)
2661   {
2662    code = PerlIOMmap_map(f);
2663   }
2664  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2665   {
2666    code = PerlIOBuf_fill(f);
2667   }
2668  return code;
2669 }
2670
2671 IV
2672 PerlIOMmap_close(PerlIO *f)
2673 {
2674  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2675  PerlIOBuf  *b = &m->base;
2676  IV code = PerlIO_flush(f);
2677  if (m->bbuf)
2678   {
2679    b->buf  = m->bbuf;
2680    m->bbuf = NULL;
2681    b->ptr  = b->end = b->buf;
2682   }
2683  if (PerlIOBuf_close(f) != 0)
2684   code = -1;
2685  return code;
2686 }
2687
2688
2689 PerlIO_funcs PerlIO_mmap = {
2690  "mmap",
2691  sizeof(PerlIOMmap),
2692  PERLIO_K_BUFFERED,
2693  PerlIOBase_fileno,
2694  PerlIOBuf_fdopen,
2695  PerlIOBuf_open,
2696  PerlIOBuf_reopen,
2697  PerlIOBase_pushed,
2698  PerlIOBase_noop_ok,
2699  PerlIOBuf_read,
2700  PerlIOMmap_unread,
2701  PerlIOMmap_write,
2702  PerlIOBuf_seek,
2703  PerlIOBuf_tell,
2704  PerlIOBuf_close,
2705  PerlIOMmap_flush,
2706  PerlIOMmap_fill,
2707  PerlIOBase_eof,
2708  PerlIOBase_error,
2709  PerlIOBase_clearerr,
2710  PerlIOBuf_setlinebuf,
2711  PerlIOMmap_get_base,
2712  PerlIOBuf_bufsiz,
2713  PerlIOBuf_get_ptr,
2714  PerlIOBuf_get_cnt,
2715  PerlIOBuf_set_ptrcnt,
2716 };
2717
2718 #endif /* HAS_MMAP */
2719
2720 void
2721 PerlIO_init(void)
2722 {
2723  if (!_perlio)
2724   {
2725    atexit(&PerlIO_cleanup);
2726   }
2727 }
2728
2729 #undef PerlIO_stdin
2730 PerlIO *
2731 PerlIO_stdin(void)
2732 {
2733  if (!_perlio)
2734   PerlIO_stdstreams();
2735  return &_perlio[1];
2736 }
2737
2738 #undef PerlIO_stdout
2739 PerlIO *
2740 PerlIO_stdout(void)
2741 {
2742  if (!_perlio)
2743   PerlIO_stdstreams();
2744  return &_perlio[2];
2745 }
2746
2747 #undef PerlIO_stderr
2748 PerlIO *
2749 PerlIO_stderr(void)
2750 {
2751  if (!_perlio)
2752   PerlIO_stdstreams();
2753  return &_perlio[3];
2754 }
2755
2756 /*--------------------------------------------------------------------------------------*/
2757
2758 #undef PerlIO_getname
2759 char *
2760 PerlIO_getname(PerlIO *f, char *buf)
2761 {
2762  dTHX;
2763  Perl_croak(aTHX_ "Don't know how to get file name");
2764  return NULL;
2765 }
2766
2767
2768 /*--------------------------------------------------------------------------------------*/
2769 /* Functions which can be called on any kind of PerlIO implemented
2770    in terms of above
2771 */
2772
2773 #undef PerlIO_getc
2774 int
2775 PerlIO_getc(PerlIO *f)
2776 {
2777  STDCHAR buf[1];
2778  SSize_t count = PerlIO_read(f,buf,1);
2779  if (count == 1)
2780   {
2781    return (unsigned char) buf[0];
2782   }
2783  return EOF;
2784 }
2785
2786 #undef PerlIO_ungetc
2787 int
2788 PerlIO_ungetc(PerlIO *f, int ch)
2789 {
2790  if (ch != EOF)
2791   {
2792    STDCHAR buf = ch;
2793    if (PerlIO_unread(f,&buf,1) == 1)
2794     return ch;
2795   }
2796  return EOF;
2797 }
2798
2799 #undef PerlIO_putc
2800 int
2801 PerlIO_putc(PerlIO *f, int ch)
2802 {
2803  STDCHAR buf = ch;
2804  return PerlIO_write(f,&buf,1);
2805 }
2806
2807 #undef PerlIO_puts
2808 int
2809 PerlIO_puts(PerlIO *f, const char *s)
2810 {
2811  STRLEN len = strlen(s);
2812  return PerlIO_write(f,s,len);
2813 }
2814
2815 #undef PerlIO_rewind
2816 void
2817 PerlIO_rewind(PerlIO *f)
2818 {
2819  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2820  PerlIO_clearerr(f);
2821 }
2822
2823 #undef PerlIO_vprintf
2824 int
2825 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2826 {
2827  dTHX;
2828  SV *sv = newSVpvn("",0);
2829  char *s;
2830  STRLEN len;
2831 #ifdef NEED_VA_COPY
2832  va_list apc;
2833  Perl_va_copy(ap, apc);
2834  sv_vcatpvf(sv, fmt, &apc);
2835 #else
2836  sv_vcatpvf(sv, fmt, &ap);
2837 #endif
2838  s = SvPV(sv,len);
2839  return PerlIO_write(f,s,len);
2840 }
2841
2842 #undef PerlIO_printf
2843 int
2844 PerlIO_printf(PerlIO *f,const char *fmt,...)
2845 {
2846  va_list ap;
2847  int result;
2848  va_start(ap,fmt);
2849  result = PerlIO_vprintf(f,fmt,ap);
2850  va_end(ap);
2851  return result;
2852 }
2853
2854 #undef PerlIO_stdoutf
2855 int
2856 PerlIO_stdoutf(const char *fmt,...)
2857 {
2858  va_list ap;
2859  int result;
2860  va_start(ap,fmt);
2861  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2862  va_end(ap);
2863  return result;
2864 }
2865
2866 #undef PerlIO_tmpfile
2867 PerlIO *
2868 PerlIO_tmpfile(void)
2869 {
2870  /* I have no idea how portable mkstemp() is ... */
2871 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2872  PerlIO *f = NULL;
2873  FILE *stdio = tmpfile();
2874  if (stdio)
2875   {
2876    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2877    s->stdio  = stdio;
2878   }
2879  return f;
2880 #else
2881  dTHX;
2882  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2883  int fd = mkstemp(SvPVX(sv));
2884  PerlIO *f = NULL;
2885  if (fd >= 0)
2886   {
2887    f = PerlIO_fdopen(fd,"w+");
2888    if (f)
2889     {
2890      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2891     }
2892    PerlLIO_unlink(SvPVX(sv));
2893    SvREFCNT_dec(sv);
2894   }
2895  return f;
2896 #endif
2897 }
2898
2899 #undef HAS_FSETPOS
2900 #undef HAS_FGETPOS
2901
2902 #endif /* USE_SFIO */
2903 #endif /* PERLIO_IS_STDIO */
2904
2905 /*======================================================================================*/
2906 /* Now some functions in terms of above which may be needed even if
2907    we are not in true PerlIO mode
2908  */
2909
2910 #ifndef HAS_FSETPOS
2911 #undef PerlIO_setpos
2912 int
2913 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2914 {
2915  return PerlIO_seek(f,*pos,0);
2916 }
2917 #else
2918 #ifndef PERLIO_IS_STDIO
2919 #undef PerlIO_setpos
2920 int
2921 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2922 {
2923 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2924  return fsetpos64(f, pos);
2925 #else
2926  return fsetpos(f, pos);
2927 #endif
2928 }
2929 #endif
2930 #endif
2931
2932 #ifndef HAS_FGETPOS
2933 #undef PerlIO_getpos
2934 int
2935 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2936 {
2937  *pos = PerlIO_tell(f);
2938  return *pos == -1 ? -1 : 0;
2939 }
2940 #else
2941 #ifndef PERLIO_IS_STDIO
2942 #undef PerlIO_getpos
2943 int
2944 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2945 {
2946 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2947  return fgetpos64(f, pos);
2948 #else
2949  return fgetpos(f, pos);
2950 #endif
2951 }
2952 #endif
2953 #endif
2954
2955 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2956
2957 int
2958 vprintf(char *pat, char *args)
2959 {
2960     _doprnt(pat, args, stdout);
2961     return 0;           /* wrong, but perl doesn't use the return value */
2962 }
2963
2964 int
2965 vfprintf(FILE *fd, char *pat, char *args)
2966 {
2967     _doprnt(pat, args, fd);
2968     return 0;           /* wrong, but perl doesn't use the return value */
2969 }
2970
2971 #endif
2972
2973 #ifndef PerlIO_vsprintf
2974 int
2975 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2976 {
2977  int val = vsprintf(s, fmt, ap);
2978  if (n >= 0)
2979   {
2980    if (strlen(s) >= (STRLEN)n)
2981     {
2982      dTHX;
2983      (void)PerlIO_puts(Perl_error_log,
2984                        "panic: sprintf overflow - memory corrupted!\n");
2985      my_exit(1);
2986     }
2987   }
2988  return val;
2989 }
2990 #endif
2991
2992 #ifndef PerlIO_sprintf
2993 int
2994 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2995 {
2996  va_list ap;
2997  int result;
2998  va_start(ap,fmt);
2999  result = PerlIO_vsprintf(s, n, fmt, ap);
3000  va_end(ap);
3001  return result;
3002 }
3003 #endif
3004
3005 #endif /* !PERL_IMPLICIT_SYS */
3006