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(__FUNCTION__ " 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 %_ %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 %_ %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 %_",sv);
 351  return 0;
 352 }
 353
 354 static int
 355 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 356 {
 357  Perl_warn(aTHX_ "free %_",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 %_",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(__FUNCTION__ " 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(__FUNCTION__ " 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(__FUNCTION__ " f=%p %s %s fl=%08x (%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   {
1680    int code = PerlLIO_setmode(fd, O_BINARY);
1681    PerlIO_debug(__FUNCTION__ " %s fd=%d m=%s c=%d\n",tab->name,fd,mode,code);
1682   }
1683  f = (*tab->Fdopen)(tab,fd,mode);
1684  if (f)
1685   {
1686    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1687    b->posn = PerlIO_tell(PerlIONext(f));
1688    if (init && fd == 2)
1689     {
1690      /* Initial stderr is unbuffered */
1691      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1692     }
1693    PerlIO_debug(__FUNCTION__ " %s f=%p fd=%d m=%s fl=%08x\n",
1694                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1695   }
1696  return f;
1697 }
1698
1699 PerlIO *
1700 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1701 {
1702  PerlIO_funcs *tab = PerlIO_default_btm();
1703  PerlIO *f = (*tab->Open)(tab,path,mode);
1704  if (f)
1705   {
1706    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1707    b->posn = PerlIO_tell(PerlIONext(f));
1708   }
1709  return f;
1710 }
1711
1712 int
1713 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1714 {
1715  PerlIO *next = PerlIONext(f);
1716  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1717  if (code = 0)
1718   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1719  if (code == 0)
1720   {
1721    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1722    b->posn = PerlIO_tell(PerlIONext(f));
1723   }
1724  return code;
1725 }
1726
1727 /* This "flush" is akin to sfio's sync in that it handles files in either
1728    read or write state
1729 */
1730 IV
1731 PerlIOBuf_flush(PerlIO *f)
1732 {
1733  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1734  int code = 0;
1735  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1736   {
1737    /* write() the buffer */
1738    STDCHAR *p = b->buf;
1739    int count;
1740    PerlIO *n = PerlIONext(f);
1741    while (p < b->ptr)
1742     {
1743      count = PerlIO_write(n,p,b->ptr - p);
1744      if (count > 0)
1745       {
1746        p += count;
1747       }
1748      else if (count < 0 || PerlIO_error(n))
1749       {
1750        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1751        code = -1;
1752        break;
1753       }
1754     }
1755    b->posn += (p - b->buf);
1756   }
1757  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1758   {
1759    /* Note position change */
1760    b->posn += (b->ptr - b->buf);
1761    if (b->ptr < b->end)
1762     {
1763      /* We did not consume all of it */
1764      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1765       {
1766        b->posn = PerlIO_tell(PerlIONext(f));
1767       }
1768     }
1769   }
1770  b->ptr = b->end = b->buf;
1771  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1772  /* FIXME: Is this right for read case ? */
1773  if (PerlIO_flush(PerlIONext(f)) != 0)
1774   code = -1;
1775  return code;
1776 }
1777
1778 IV
1779 PerlIOBuf_fill(PerlIO *f)
1780 {
1781  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1782  PerlIO *n = PerlIONext(f);
1783  SSize_t avail;
1784  /* FIXME: doing the down-stream flush is a bad idea if it causes
1785     pre-read data in stdio buffer to be discarded
1786     but this is too simplistic - as it skips _our_ hosekeeping
1787     and breaks tell tests.
1788  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1789   {
1790   }
1791   */
1792  if (PerlIO_flush(f) != 0)
1793   return -1;
1794
1795  b->ptr = b->end = b->buf;
1796  if (PerlIO_fast_gets(n))
1797   {
1798    /* Layer below is also buffered
1799     * We do _NOT_ want to call its ->Read() because that will loop
1800     * till it gets what we asked for which may hang on a pipe etc.
1801     * Instead take anything it has to hand, or ask it to fill _once_.
1802     */
1803    avail  = PerlIO_get_cnt(n);
1804    if (avail <= 0)
1805     {
1806      avail = PerlIO_fill(n);
1807      if (avail == 0)
1808       avail = PerlIO_get_cnt(n);
1809      else
1810       {
1811        if (!PerlIO_error(n) && PerlIO_eof(n))
1812         avail = 0;
1813       }
1814     }
1815    if (avail > 0)
1816     {
1817      STDCHAR *ptr = PerlIO_get_ptr(n);
1818      SSize_t cnt  = avail;
1819      if (avail > b->bufsiz)
1820       avail = b->bufsiz;
1821      Copy(ptr,b->buf,avail,STDCHAR);
1822      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1823     }
1824   }
1825  else
1826   {
1827    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1828   }
1829  if (avail <= 0)
1830   {
1831    if (avail == 0)
1832     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1833    else
1834     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1835    return -1;
1836   }
1837  b->end      = b->buf+avail;
1838  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1839  return 0;
1840 }
1841
1842 SSize_t
1843 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1844 {
1845  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1846  STDCHAR *buf  = (STDCHAR *) vbuf;
1847  if (f)
1848   {
1849    if (!b->ptr)
1850     PerlIO_get_base(f);
1851    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1852     return 0;
1853    while (count > 0)
1854     {
1855      SSize_t avail = PerlIO_get_cnt(f);
1856      SSize_t take  = (count < avail) ? count : avail;
1857      if (take > 0)
1858       {
1859        STDCHAR *ptr = PerlIO_get_ptr(f);
1860        Copy(ptr,buf,take,STDCHAR);
1861        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1862        count   -= take;
1863        buf     += take;
1864       }
1865      if (count > 0  && avail <= 0)
1866       {
1867        if (PerlIO_fill(f) != 0)
1868         break;
1869       }
1870     }
1871    return (buf - (STDCHAR *) vbuf);
1872   }
1873  return 0;
1874 }
1875
1876 SSize_t
1877 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1878 {
1879  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1880  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1881  SSize_t unread = 0;
1882  SSize_t avail;
1883  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1884   PerlIO_flush(f);
1885  if (!b->buf)
1886   PerlIO_get_base(f);
1887  if (b->buf)
1888   {
1889    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1890     {
1891      avail = (b->ptr - b->buf);
1892      if (avail > (SSize_t) count)
1893       avail = count;
1894      b->ptr -= avail;
1895     }
1896    else
1897     {
1898      avail = b->bufsiz;
1899      if (avail > (SSize_t) count)
1900       avail = count;
1901      b->end = b->ptr + avail;
1902     }
1903    if (avail > 0)
1904     {
1905      buf    -= avail;
1906      if (buf != b->ptr)
1907       {
1908        Copy(buf,b->ptr,avail,STDCHAR);
1909       }
1910      count  -= avail;
1911      unread += avail;
1912      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1913     }
1914   }
1915  return unread;
1916 }
1917
1918 SSize_t
1919 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1920 {
1921  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1922  const STDCHAR *buf = (const STDCHAR *) vbuf;
1923  Size_t written = 0;
1924  if (!b->buf)
1925   PerlIO_get_base(f);
1926  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1927   return 0;
1928  while (count > 0)
1929   {
1930    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1931    if ((SSize_t) count < avail)
1932     avail = count;
1933    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1934    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1935     {
1936      while (avail > 0)
1937       {
1938        int ch = *buf++;
1939        *(b->ptr)++ = ch;
1940        count--;
1941        avail--;
1942        written++;
1943        if (ch == '\n')
1944         {
1945          PerlIO_flush(f);
1946          break;
1947         }
1948       }
1949     }
1950    else
1951     {
1952      if (avail)
1953       {
1954        Copy(buf,b->ptr,avail,STDCHAR);
1955        count   -= avail;
1956        buf     += avail;
1957        written += avail;
1958        b->ptr  += avail;
1959       }
1960     }
1961    if (b->ptr >= (b->buf + b->bufsiz))
1962     PerlIO_flush(f);
1963   }
1964  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1965   PerlIO_flush(f);
1966  return written;
1967 }
1968
1969 IV
1970 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1971 {
1972  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1973  int code = PerlIO_flush(f);
1974  if (code == 0)
1975   {
1976    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1977    code = PerlIO_seek(PerlIONext(f),offset,whence);
1978    if (code == 0)
1979     {
1980      b->posn = PerlIO_tell(PerlIONext(f));
1981     }
1982   }
1983  return code;
1984 }
1985
1986 Off_t
1987 PerlIOBuf_tell(PerlIO *f)
1988 {
1989  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1990  Off_t posn = b->posn;
1991  if (b->buf)
1992   posn += (b->ptr - b->buf);
1993  return posn;
1994 }
1995
1996 IV
1997 PerlIOBuf_close(PerlIO *f)
1998 {
1999  IV code = PerlIOBase_close(f);
2000  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2001  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2002   {
2003    Safefree(b->buf);
2004   }
2005  b->buf = NULL;
2006  b->ptr = b->end = b->buf;
2007  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2008  return code;
2009 }
2010
2011 void
2012 PerlIOBuf_setlinebuf(PerlIO *f)
2013 {
2014  if (f)
2015   {
2016    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2017   }
2018 }
2019
2020 STDCHAR *
2021 PerlIOBuf_get_ptr(PerlIO *f)
2022 {
2023  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2024  if (!b->buf)
2025   PerlIO_get_base(f);
2026  return b->ptr;
2027 }
2028
2029 SSize_t
2030 PerlIOBuf_get_cnt(PerlIO *f)
2031 {
2032  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2033  if (!b->buf)
2034   PerlIO_get_base(f);
2035  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2036   return (b->end - b->ptr);
2037  return 0;
2038 }
2039
2040 STDCHAR *
2041 PerlIOBuf_get_base(PerlIO *f)
2042 {
2043  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2044  if (!b->buf)
2045   {
2046    if (!b->bufsiz)
2047     b->bufsiz = 4096;
2048    New('B',b->buf,b->bufsiz,STDCHAR);
2049    if (!b->buf)
2050     {
2051      b->buf = (STDCHAR *)&b->oneword;
2052      b->bufsiz = sizeof(b->oneword);
2053     }
2054    b->ptr = b->buf;
2055    b->end = b->ptr;
2056   }
2057  return b->buf;
2058 }
2059
2060 Size_t
2061 PerlIOBuf_bufsiz(PerlIO *f)
2062 {
2063  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2064  if (!b->buf)
2065   PerlIO_get_base(f);
2066  return (b->end - b->buf);
2067 }
2068
2069 void
2070 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2071 {
2072  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2073  if (!b->buf)
2074   PerlIO_get_base(f);
2075  b->ptr = ptr;
2076  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2077   {
2078    dTHX;
2079    assert(PerlIO_get_cnt(f) == cnt);
2080    assert(b->ptr >= b->buf);
2081   }
2082  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2083 }
2084
2085 PerlIO_funcs PerlIO_perlio = {
2086  "perlio",
2087  sizeof(PerlIOBuf),
2088  PERLIO_K_BUFFERED,
2089  PerlIOBase_fileno,
2090  PerlIOBuf_fdopen,
2091  PerlIOBuf_open,
2092  PerlIOBuf_reopen,
2093  PerlIOBase_pushed,
2094  PerlIOBase_noop_ok,
2095  PerlIOBuf_read,
2096  PerlIOBuf_unread,
2097  PerlIOBuf_write,
2098  PerlIOBuf_seek,
2099  PerlIOBuf_tell,
2100  PerlIOBuf_close,
2101  PerlIOBuf_flush,
2102  PerlIOBuf_fill,
2103  PerlIOBase_eof,
2104  PerlIOBase_error,
2105  PerlIOBase_clearerr,
2106  PerlIOBuf_setlinebuf,
2107  PerlIOBuf_get_base,
2108  PerlIOBuf_bufsiz,
2109  PerlIOBuf_get_ptr,
2110  PerlIOBuf_get_cnt,
2111  PerlIOBuf_set_ptrcnt,
2112 };
2113
2114 /*--------------------------------------------------------------------------------------*/
2115 /* crlf - translation
2116    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2117    to hand back a line at a time and keeping a record of which nl we "lied" about.
2118    On write translate "\n" to CR,LF
2119  */
2120
2121 typedef struct
2122 {
2123  PerlIOBuf      base;         /* PerlIOBuf stuff */
2124  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2125 } PerlIOCrlf;
2126
2127 IV
2128 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2129 {
2130  IV code;
2131  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2132  code = PerlIOBase_pushed(f,mode);
2133  PerlIO_debug(__FUNCTION__ " f=%p %s %s fl=%08x\n",
2134               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2135               PerlIOBase(f)->flags);
2136  return code;
2137 }
2138
2139
2140 SSize_t
2141 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2142 {
2143  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2144  if (c->nl)
2145   {
2146    *(c->nl) = 0xd;
2147    c->nl = NULL;
2148   }
2149  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2150   return PerlIOBuf_unread(f,vbuf,count);
2151  else
2152   {
2153    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2154    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2155    SSize_t unread = 0;
2156    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2157     PerlIO_flush(f);
2158    if (!b->buf)
2159     PerlIO_get_base(f);
2160    if (b->buf)
2161     {
2162      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2163       {
2164        b->end = b->ptr = b->buf + b->bufsiz;
2165        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2166       }
2167      while (count > 0 && b->ptr > b->buf)
2168       {
2169        int ch = *--buf;
2170        if (ch == '\n')
2171         {
2172          if (b->ptr - 2 >= b->buf)
2173           {
2174            *--(b->ptr) = 0xa;
2175            *--(b->ptr) = 0xd;
2176            unread++;
2177            count--;
2178           }
2179          else
2180           {
2181            buf++;
2182            break;
2183           }
2184         }
2185        else
2186         {
2187          *--(b->ptr) = ch;
2188          unread++;
2189          count--;
2190         }
2191       }
2192     }
2193    return unread;
2194   }
2195 }
2196
2197 SSize_t
2198 PerlIOCrlf_get_cnt(PerlIO *f)
2199 {
2200  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2201  if (!b->buf)
2202   PerlIO_get_base(f);
2203  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2204   {
2205    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2206    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2207     {
2208      STDCHAR *nl   = b->ptr;
2209     scan:
2210      while (nl < b->end && *nl != 0xd)
2211       nl++;
2212      if (nl < b->end && *nl == 0xd)
2213       {
2214      test:
2215        if (nl+1 < b->end)
2216         {
2217          if (nl[1] == 0xa)
2218           {
2219            *nl   = '\n';
2220            c->nl = nl;
2221           }
2222          else
2223           {
2224            /* Not CR,LF but just CR */
2225            nl++;
2226            goto scan;
2227           }
2228         }
2229        else
2230         {
2231          /* Blast - found CR as last char in buffer */
2232          if (b->ptr < nl)
2233           {
2234            /* They may not care, defer work as long as possible */
2235            return (nl - b->ptr);
2236           }
2237          else
2238           {
2239            int code;
2240            dTHX;
2241            b->ptr++;               /* say we have read it as far as flush() is concerned */
2242            b->buf++;               /* Leave space an front of buffer */
2243            b->bufsiz--;            /* Buffer is thus smaller */
2244            code = PerlIO_fill(f);  /* Fetch some more */
2245            b->bufsiz++;            /* Restore size for next time */
2246            b->buf--;               /* Point at space */
2247            b->ptr = nl = b->buf;   /* Which is what we hand off */
2248            b->posn--;              /* Buffer starts here */
2249            *nl = 0xd;              /* Fill in the CR */
2250            if (code == 0)
2251             goto test;             /* fill() call worked */
2252            /* CR at EOF - just fall through */
2253           }
2254         }
2255       }
2256     }
2257    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2258   }
2259  return 0;
2260 }
2261
2262 void
2263 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2264 {
2265  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2266  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2267  IV flags = PerlIOBase(f)->flags;
2268  if (!b->buf)
2269   PerlIO_get_base(f);
2270  if (!ptr)
2271   {
2272    if (c->nl)
2273     ptr = c->nl+1;
2274    else
2275     {
2276      ptr = b->end;
2277      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2278       ptr--;
2279     }
2280    ptr -= cnt;
2281   }
2282  else
2283   {
2284    /* Test code - delete when it works ... */
2285    STDCHAR *chk;
2286    if (c->nl)
2287     chk = c->nl+1;
2288    else
2289     {
2290      chk = b->end;
2291      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2292       chk--;
2293     }
2294    chk -= cnt;
2295
2296    if (ptr != chk)
2297     {
2298      dTHX;
2299      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
2300                 ptr, chk, flags, c->nl, b->end, cnt);
2301     }
2302   }
2303  if (c->nl)
2304   {
2305    if (ptr > c->nl)
2306     {
2307      /* They have taken what we lied about */
2308      *(c->nl) = 0xd;
2309      c->nl = NULL;
2310      ptr++;
2311     }
2312   }
2313  b->ptr = ptr;
2314  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2315 }
2316
2317 SSize_t
2318 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2319 {
2320  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2321   return PerlIOBuf_write(f,vbuf,count);
2322  else
2323   {
2324    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2325    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2326    const STDCHAR *ebuf = buf+count;
2327    if (!b->buf)
2328     PerlIO_get_base(f);
2329    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2330     return 0;
2331    while (buf < ebuf)
2332     {
2333      STDCHAR *eptr = b->buf+b->bufsiz;
2334      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2335      while (buf < ebuf && b->ptr < eptr)
2336       {
2337        if (*buf == '\n')
2338         {
2339          if ((b->ptr + 2) > eptr)
2340           {
2341            /* Not room for both */
2342            PerlIO_flush(f);
2343            break;
2344           }
2345          else
2346           {
2347            *(b->ptr)++ = 0xd; /* CR */
2348            *(b->ptr)++ = 0xa; /* LF */
2349            buf++;
2350            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2351             {
2352              PerlIO_flush(f);
2353              break;
2354             }
2355           }
2356         }
2357        else
2358         {
2359          int ch = *buf++;
2360          *(b->ptr)++ = ch;
2361         }
2362        if (b->ptr >= eptr)
2363         {
2364          PerlIO_flush(f);
2365          break;
2366         }
2367       }
2368     }
2369    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2370     PerlIO_flush(f);
2371    return (buf - (STDCHAR *) vbuf);
2372   }
2373 }
2374
2375 IV
2376 PerlIOCrlf_flush(PerlIO *f)
2377 {
2378  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2379  if (c->nl)
2380   {
2381    *(c->nl) = 0xd;
2382    c->nl = NULL;
2383   }
2384  return PerlIOBuf_flush(f);
2385 }
2386
2387 PerlIO_funcs PerlIO_crlf = {
2388  "crlf",
2389  sizeof(PerlIOCrlf),
2390  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2391  PerlIOBase_fileno,
2392  PerlIOBuf_fdopen,
2393  PerlIOBuf_open,
2394  PerlIOBuf_reopen,
2395  PerlIOCrlf_pushed,
2396  PerlIOBase_noop_ok,   /* popped */
2397  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2398  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2399  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2400  PerlIOBuf_seek,
2401  PerlIOBuf_tell,
2402  PerlIOBuf_close,
2403  PerlIOCrlf_flush,
2404  PerlIOBuf_fill,
2405  PerlIOBase_eof,
2406  PerlIOBase_error,
2407  PerlIOBase_clearerr,
2408  PerlIOBuf_setlinebuf,
2409  PerlIOBuf_get_base,
2410  PerlIOBuf_bufsiz,
2411  PerlIOBuf_get_ptr,
2412  PerlIOCrlf_get_cnt,
2413  PerlIOCrlf_set_ptrcnt,
2414 };
2415
2416 #ifdef HAS_MMAP
2417 /*--------------------------------------------------------------------------------------*/
2418 /* mmap as "buffer" layer */
2419
2420 typedef struct
2421 {
2422  PerlIOBuf      base;         /* PerlIOBuf stuff */
2423  Mmap_t         mptr;        /* Mapped address */
2424  Size_t         len;          /* mapped length */
2425  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2426 } PerlIOMmap;
2427
2428 static size_t page_size = 0;
2429
2430 IV
2431 PerlIOMmap_map(PerlIO *f)
2432 {
2433  dTHX;
2434  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2435  PerlIOBuf  *b = &m->base;
2436  IV flags = PerlIOBase(f)->flags;
2437  IV code  = 0;
2438  if (m->len)
2439   abort();
2440  if (flags & PERLIO_F_CANREAD)
2441   {
2442    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2443    int fd   = PerlIO_fileno(f);
2444    struct stat st;
2445    code = fstat(fd,&st);
2446    if (code == 0 && S_ISREG(st.st_mode))
2447     {
2448      SSize_t len = st.st_size - b->posn;
2449      if (len > 0)
2450       {
2451        Off_t posn;
2452        if (!page_size) {
2453 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2454            {
2455                SETERRNO(0,SS$_NORMAL);
2456 #   ifdef _SC_PAGESIZE
2457                page_size = sysconf(_SC_PAGESIZE);
2458 #   else
2459                page_size = sysconf(_SC_PAGE_SIZE);
2460 #   endif
2461                if ((long)page_size < 0) {
2462                    if (errno) {
2463                        SV *error = ERRSV;
2464                        char *msg;
2465                        STRLEN n_a;
2466                        (void)SvUPGRADE(error, SVt_PV);
2467                        msg = SvPVx(error, n_a);
2468                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2469                    }
2470                    else
2471                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2472                }
2473            }
2474 #else
2475 #   ifdef HAS_GETPAGESIZE
2476         page_size = getpagesize();
2477 #   else
2478 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2479         page_size = PAGESIZE; /* compiletime, bad */
2480 #       endif
2481 #   endif
2482 #endif
2483         if ((IV)page_size <= 0)
2484             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2485        }
2486        if (b->posn < 0)
2487         {
2488          /* This is a hack - should never happen - open should have set it ! */
2489          b->posn = PerlIO_tell(PerlIONext(f));
2490         }
2491        posn = (b->posn / page_size) * page_size;
2492        len  = st.st_size - posn;
2493        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2494        if (m->mptr && m->mptr != (Mmap_t) -1)
2495         {
2496 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2497          madvise(m->mptr, len, MADV_SEQUENTIAL);
2498 #endif
2499          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2500          b->end  = ((STDCHAR *)m->mptr) + len;
2501          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2502          b->ptr  = b->buf;
2503          m->len  = len;
2504         }
2505        else
2506         {
2507          b->buf = NULL;
2508         }
2509       }
2510      else
2511       {
2512        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2513        b->buf = NULL;
2514        b->ptr = b->end = b->ptr;
2515        code = -1;
2516       }
2517     }
2518   }
2519  return code;
2520 }
2521
2522 IV
2523 PerlIOMmap_unmap(PerlIO *f)
2524 {
2525  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2526  PerlIOBuf  *b = &m->base;
2527  IV code = 0;
2528  if (m->len)
2529   {
2530    if (b->buf)
2531     {
2532      code = munmap(m->mptr, m->len);
2533      b->buf  = NULL;
2534      m->len  = 0;
2535      m->mptr = NULL;
2536      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2537       code = -1;
2538     }
2539    b->ptr = b->end = b->buf;
2540    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2541   }
2542  return code;
2543 }
2544
2545 STDCHAR *
2546 PerlIOMmap_get_base(PerlIO *f)
2547 {
2548  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2549  PerlIOBuf  *b = &m->base;
2550  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2551   {
2552    /* Already have a readbuffer in progress */
2553    return b->buf;
2554   }
2555  if (b->buf)
2556   {
2557    /* We have a write buffer or flushed PerlIOBuf read buffer */
2558    m->bbuf = b->buf;  /* save it in case we need it again */
2559    b->buf  = NULL;    /* Clear to trigger below */
2560   }
2561  if (!b->buf)
2562   {
2563    PerlIOMmap_map(f);     /* Try and map it */
2564    if (!b->buf)
2565     {
2566      /* Map did not work - recover PerlIOBuf buffer if we have one */
2567      b->buf = m->bbuf;
2568     }
2569   }
2570  b->ptr  = b->end = b->buf;
2571  if (b->buf)
2572   return b->buf;
2573  return PerlIOBuf_get_base(f);
2574 }
2575
2576 SSize_t
2577 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2578 {
2579  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2580  PerlIOBuf  *b = &m->base;
2581  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2582   PerlIO_flush(f);
2583  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2584   {
2585    b->ptr -= count;
2586    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2587    return count;
2588   }
2589  if (m->len)
2590   {
2591    /* Loose the unwritable mapped buffer */
2592    PerlIO_flush(f);
2593    /* If flush took the "buffer" see if we have one from before */
2594    if (!b->buf && m->bbuf)
2595     b->buf = m->bbuf;
2596    if (!b->buf)
2597     {
2598      PerlIOBuf_get_base(f);
2599      m->bbuf = b->buf;
2600     }
2601   }
2602  return PerlIOBuf_unread(f,vbuf,count);
2603 }
2604
2605 SSize_t
2606 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2607 {
2608  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2609  PerlIOBuf  *b = &m->base;
2610  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2611   {
2612    /* No, or wrong sort of, buffer */
2613    if (m->len)
2614     {
2615      if (PerlIOMmap_unmap(f) != 0)
2616       return 0;
2617     }
2618    /* If unmap took the "buffer" see if we have one from before */
2619    if (!b->buf && m->bbuf)
2620     b->buf = m->bbuf;
2621    if (!b->buf)
2622     {
2623      PerlIOBuf_get_base(f);
2624      m->bbuf = b->buf;
2625     }
2626   }
2627  return PerlIOBuf_write(f,vbuf,count);
2628 }
2629
2630 IV
2631 PerlIOMmap_flush(PerlIO *f)
2632 {
2633  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2634  PerlIOBuf  *b = &m->base;
2635  IV code = PerlIOBuf_flush(f);
2636  /* Now we are "synced" at PerlIOBuf level */
2637  if (b->buf)
2638   {
2639    if (m->len)
2640     {
2641      /* Unmap the buffer */
2642      if (PerlIOMmap_unmap(f) != 0)
2643       code = -1;
2644     }
2645    else
2646     {
2647      /* We seem to have a PerlIOBuf buffer which was not mapped
2648       * remember it in case we need one later
2649       */
2650      m->bbuf = b->buf;
2651     }
2652   }
2653  return code;
2654 }
2655
2656 IV
2657 PerlIOMmap_fill(PerlIO *f)
2658 {
2659  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2660  IV code = PerlIO_flush(f);
2661  if (code == 0 && !b->buf)
2662   {
2663    code = PerlIOMmap_map(f);
2664   }
2665  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2666   {
2667    code = PerlIOBuf_fill(f);
2668   }
2669  return code;
2670 }
2671
2672 IV
2673 PerlIOMmap_close(PerlIO *f)
2674 {
2675  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2676  PerlIOBuf  *b = &m->base;
2677  IV code = PerlIO_flush(f);
2678  if (m->bbuf)
2679   {
2680    b->buf  = m->bbuf;
2681    m->bbuf = NULL;
2682    b->ptr  = b->end = b->buf;
2683   }
2684  if (PerlIOBuf_close(f) != 0)
2685   code = -1;
2686  return code;
2687 }
2688
2689
2690 PerlIO_funcs PerlIO_mmap = {
2691  "mmap",
2692  sizeof(PerlIOMmap),
2693  PERLIO_K_BUFFERED,
2694  PerlIOBase_fileno,
2695  PerlIOBuf_fdopen,
2696  PerlIOBuf_open,
2697  PerlIOBuf_reopen,
2698  PerlIOBase_pushed,
2699  PerlIOBase_noop_ok,
2700  PerlIOBuf_read,
2701  PerlIOMmap_unread,
2702  PerlIOMmap_write,
2703  PerlIOBuf_seek,
2704  PerlIOBuf_tell,
2705  PerlIOBuf_close,
2706  PerlIOMmap_flush,
2707  PerlIOMmap_fill,
2708  PerlIOBase_eof,
2709  PerlIOBase_error,
2710  PerlIOBase_clearerr,
2711  PerlIOBuf_setlinebuf,
2712  PerlIOMmap_get_base,
2713  PerlIOBuf_bufsiz,
2714  PerlIOBuf_get_ptr,
2715  PerlIOBuf_get_cnt,
2716  PerlIOBuf_set_ptrcnt,
2717 };
2718
2719 #endif /* HAS_MMAP */
2720
2721 void
2722 PerlIO_init(void)
2723 {
2724  if (!_perlio)
2725   {
2726    atexit(&PerlIO_cleanup);
2727   }
2728 }
2729
2730 #undef PerlIO_stdin
2731 PerlIO *
2732 PerlIO_stdin(void)
2733 {
2734  if (!_perlio)
2735   PerlIO_stdstreams();
2736  return &_perlio[1];
2737 }
2738
2739 #undef PerlIO_stdout
2740 PerlIO *
2741 PerlIO_stdout(void)
2742 {
2743  if (!_perlio)
2744   PerlIO_stdstreams();
2745  return &_perlio[2];
2746 }
2747
2748 #undef PerlIO_stderr
2749 PerlIO *
2750 PerlIO_stderr(void)
2751 {
2752  if (!_perlio)
2753   PerlIO_stdstreams();
2754  return &_perlio[3];
2755 }
2756
2757 /*--------------------------------------------------------------------------------------*/
2758
2759 #undef PerlIO_getname
2760 char *
2761 PerlIO_getname(PerlIO *f, char *buf)
2762 {
2763  dTHX;
2764  Perl_croak(aTHX_ "Don't know how to get file name");
2765  return NULL;
2766 }
2767
2768
2769 /*--------------------------------------------------------------------------------------*/
2770 /* Functions which can be called on any kind of PerlIO implemented
2771    in terms of above
2772 */
2773
2774 #undef PerlIO_getc
2775 int
2776 PerlIO_getc(PerlIO *f)
2777 {
2778  STDCHAR buf[1];
2779  SSize_t count = PerlIO_read(f,buf,1);
2780  if (count == 1)
2781   {
2782    return (unsigned char) buf[0];
2783   }
2784  return EOF;
2785 }
2786
2787 #undef PerlIO_ungetc
2788 int
2789 PerlIO_ungetc(PerlIO *f, int ch)
2790 {
2791  if (ch != EOF)
2792   {
2793    STDCHAR buf = ch;
2794    if (PerlIO_unread(f,&buf,1) == 1)
2795     return ch;
2796   }
2797  return EOF;
2798 }
2799
2800 #undef PerlIO_putc
2801 int
2802 PerlIO_putc(PerlIO *f, int ch)
2803 {
2804  STDCHAR buf = ch;
2805  return PerlIO_write(f,&buf,1);
2806 }
2807
2808 #undef PerlIO_puts
2809 int
2810 PerlIO_puts(PerlIO *f, const char *s)
2811 {
2812  STRLEN len = strlen(s);
2813  return PerlIO_write(f,s,len);
2814 }
2815
2816 #undef PerlIO_rewind
2817 void
2818 PerlIO_rewind(PerlIO *f)
2819 {
2820  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2821  PerlIO_clearerr(f);
2822 }
2823
2824 #undef PerlIO_vprintf
2825 int
2826 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2827 {
2828  dTHX;
2829  SV *sv = newSVpvn("",0);
2830  char *s;
2831  STRLEN len;
2832 #ifdef NEED_VA_COPY
2833  va_list apc;
2834  Perl_va_copy(ap, apc);
2835  sv_vcatpvf(sv, fmt, &apc);
2836 #else
2837  sv_vcatpvf(sv, fmt, &ap);
2838 #endif
2839  s = SvPV(sv,len);
2840  return PerlIO_write(f,s,len);
2841 }
2842
2843 #undef PerlIO_printf
2844 int
2845 PerlIO_printf(PerlIO *f,const char *fmt,...)
2846 {
2847  va_list ap;
2848  int result;
2849  va_start(ap,fmt);
2850  result = PerlIO_vprintf(f,fmt,ap);
2851  va_end(ap);
2852  return result;
2853 }
2854
2855 #undef PerlIO_stdoutf
2856 int
2857 PerlIO_stdoutf(const char *fmt,...)
2858 {
2859  va_list ap;
2860  int result;
2861  va_start(ap,fmt);
2862  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2863  va_end(ap);
2864  return result;
2865 }
2866
2867 #undef PerlIO_tmpfile
2868 PerlIO *
2869 PerlIO_tmpfile(void)
2870 {
2871  /* I have no idea how portable mkstemp() is ... */
2872 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2873  PerlIO *f = NULL;
2874  FILE *stdio = tmpfile();
2875  if (stdio)
2876   {
2877    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2878    s->stdio  = stdio;
2879   }
2880  return f;
2881 #else
2882  dTHX;
2883  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2884  int fd = mkstemp(SvPVX(sv));
2885  PerlIO *f = NULL;
2886  if (fd >= 0)
2887   {
2888    f = PerlIO_fdopen(fd,"w+");
2889    if (f)
2890     {
2891      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2892     }
2893    PerlLIO_unlink(SvPVX(sv));
2894    SvREFCNT_dec(sv);
2895   }
2896  return f;
2897 #endif
2898 }
2899
2900 #undef HAS_FSETPOS
2901 #undef HAS_FGETPOS
2902
2903 #endif /* USE_SFIO */
2904 #endif /* PERLIO_IS_STDIO */
2905
2906 /*======================================================================================*/
2907 /* Now some functions in terms of above which may be needed even if
2908    we are not in true PerlIO mode
2909  */
2910
2911 #ifndef HAS_FSETPOS
2912 #undef PerlIO_setpos
2913 int
2914 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2915 {
2916  return PerlIO_seek(f,*pos,0);
2917 }
2918 #else
2919 #ifndef PERLIO_IS_STDIO
2920 #undef PerlIO_setpos
2921 int
2922 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2923 {
2924 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2925  return fsetpos64(f, pos);
2926 #else
2927  return fsetpos(f, pos);
2928 #endif
2929 }
2930 #endif
2931 #endif
2932
2933 #ifndef HAS_FGETPOS
2934 #undef PerlIO_getpos
2935 int
2936 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2937 {
2938  *pos = PerlIO_tell(f);
2939  return *pos == -1 ? -1 : 0;
2940 }
2941 #else
2942 #ifndef PERLIO_IS_STDIO
2943 #undef PerlIO_getpos
2944 int
2945 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2946 {
2947 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2948  return fgetpos64(f, pos);
2949 #else
2950  return fgetpos(f, pos);
2951 #endif
2952 }
2953 #endif
2954 #endif
2955
2956 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2957
2958 int
2959 vprintf(char *pat, char *args)
2960 {
2961     _doprnt(pat, args, stdout);
2962     return 0;           /* wrong, but perl doesn't use the return value */
2963 }
2964
2965 int
2966 vfprintf(FILE *fd, char *pat, char *args)
2967 {
2968     _doprnt(pat, args, fd);
2969     return 0;           /* wrong, but perl doesn't use the return value */
2970 }
2971
2972 #endif
2973
2974 #ifndef PerlIO_vsprintf
2975 int
2976 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2977 {
2978  int val = vsprintf(s, fmt, ap);
2979  if (n >= 0)
2980   {
2981    if (strlen(s) >= (STRLEN)n)
2982     {
2983      dTHX;
2984      (void)PerlIO_puts(Perl_error_log,
2985                        "panic: sprintf overflow - memory corrupted!\n");
2986      my_exit(1);
2987     }
2988   }
2989  return val;
2990 }
2991 #endif
2992
2993 #ifndef PerlIO_sprintf
2994 int
2995 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2996 {
2997  va_list ap;
2998  int result;
2999  va_start(ap,fmt);
3000  result = PerlIO_vsprintf(s, n, fmt, ap);
3001  va_end(ap);
3002  return result;
3003 }
3004 #endif
3005
3006 #endif /* !PERL_IMPLICIT_SYS */
3007