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