perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-2000, Nick Ing-Simmons
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 #define VOIDUSED 1
  11 #ifdef PERL_MICRO
  12 #   include "uconfig.h"
  13 #else
  14 #   include "config.h"
  15 #endif
  16
  17 #define PERLIO_NOT_STDIO 0
  18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  19 /* #define PerlIO FILE */
  20 #endif
  21 /*
  22  * This file provides those parts of PerlIO abstraction
  23  * which are not #defined in perlio.h.
  24  * Which these are depends on various Configure #ifdef's
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_PERLIO_C
  29 #include "perl.h"
  30
  31 #ifndef PERLIO_LAYERS
  32 int
  33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  34 {
  35  if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
  36   {
  37    return 0;
  38   }
  39  Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
  40  /* NOTREACHED */
  41  return -1;
  42 }
  43
  44 int
  45 perlsio_binmode(FILE *fp, int iotype, int mode)
  46 {
  47 /* This used to be contents of do_binmode in doio.c */
  48 #ifdef DOSISH
  49 #  if defined(atarist) || defined(__MINT__)
  50     if (!fflush(fp)) {
  51         if (mode & O_BINARY)
  52             ((FILE*)fp)->_flag |= _IOBIN;
  53         else
  54             ((FILE*)fp)->_flag &= ~ _IOBIN;
  55         return 1;
  56     }
  57     return 0;
  58 #  else
  59     if (PerlLIO_setmode(fileno(fp), mode) != -1) {
  60 #    if defined(WIN32) && defined(__BORLANDC__)
  61         /* The translation mode of the stream is maintained independent
  62          * of the translation mode of the fd in the Borland RTL (heavy
  63          * digging through their runtime sources reveal).  User has to
  64          * set the mode explicitly for the stream (though they don't
  65          * document this anywhere). GSAR 97-5-24
  66          */
  67         fseek(fp,0L,0);
  68         if (mode & O_BINARY)
  69             fp->flags |= _F_BIN;
  70         else
  71             fp->flags &= ~ _F_BIN;
  72 #    endif
  73         return 1;
  74     }
  75     else
  76         return 0;
  77 #  endif
  78 #else
  79 #  if defined(USEMYBINMODE)
  80     if (my_binmode(fp, iotype, mode) != FALSE)
  81         return 1;
  82     else
  83         return 0;
  84 #  else
  85     return 1;
  86 #  endif
  87 #endif
  88 }
  89
  90 int
  91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
  92 {
  93  return perlsio_binmode(fp,iotype,mode);
  94 }
  95
  96 #endif
  97
  98 #if !defined(PERL_IMPLICIT_SYS)
  99
 100 #ifdef PERLIO_IS_STDIO
 101
 102 void
 103 PerlIO_init(void)
 104 {
 105  /* Does nothing (yet) except force this file to be included
 106     in perl binary. That allows this file to force inclusion
 107     of other functions that may be required by loadable
 108     extensions e.g. for FileHandle::tmpfile
 109  */
 110 }
 111
 112 #undef PerlIO_tmpfile
 113 PerlIO *
 114 PerlIO_tmpfile(void)
 115 {
 116  return tmpfile();
 117 }
 118
 119 #else /* PERLIO_IS_STDIO */
 120
 121 #ifdef USE_SFIO
 122
 123 #undef HAS_FSETPOS
 124 #undef HAS_FGETPOS
 125
 126 /* This section is just to make sure these functions
 127    get pulled in from libsfio.a
 128 */
 129
 130 #undef PerlIO_tmpfile
 131 PerlIO *
 132 PerlIO_tmpfile(void)
 133 {
 134  return sftmp(0);
 135 }
 136
 137 void
 138 PerlIO_init(void)
 139 {
 140  /* Force this file to be included  in perl binary. Which allows
 141   *  this file to force inclusion  of other functions that may be
 142   *  required by loadable  extensions e.g. for FileHandle::tmpfile
 143   */
 144
 145  /* Hack
 146   * sfio does its own 'autoflush' on stdout in common cases.
 147   * Flush results in a lot of lseek()s to regular files and
 148   * lot of small writes to pipes.
 149   */
 150  sfset(sfstdout,SF_SHARE,0);
 151 }
 152
 153 #else /* USE_SFIO */
 154 /*======================================================================================*/
 155 /* Implement all the PerlIO interface ourselves.
 156  */
 157
 158 #include "perliol.h"
 159
 160 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
 161 #ifdef I_UNISTD
 162 #include <unistd.h>
 163 #endif
 164 #ifdef HAS_MMAP
 165 #include <sys/mman.h>
 166 #endif
 167
 168 #include "XSUB.h"
 169
 170 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 171
 172 void
 173 PerlIO_debug(const char *fmt,...)
 174 {
 175  static int dbg = 0;
 176  va_list ap;
 177  va_start(ap,fmt);
 178  if (!dbg)
 179   {
 180    char *s = PerlEnv_getenv("PERLIO_DEBUG");
 181    if (s && *s)
 182     dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
 183    else
 184     dbg = -1;
 185   }
 186  if (dbg > 0)
 187   {
 188    dTHX;
 189    SV *sv = newSVpvn("",0);
 190    char *s;
 191    STRLEN len;
 192    s = CopFILE(PL_curcop);
 193    if (!s)
 194     s = "(none)";
 195    Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
 196    Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
 197
 198    s = SvPV(sv,len);
 199    PerlLIO_write(dbg,s,len);
 200    SvREFCNT_dec(sv);
 201   }
 202  va_end(ap);
 203 }
 204
 205 /*--------------------------------------------------------------------------------------*/
 206
 207 /* Inner level routines */
 208
 209 /* Table of pointers to the PerlIO structs (malloc'ed) */
 210 PerlIO *_perlio      = NULL;
 211 #define PERLIO_TABLE_SIZE 64
 212
 213 PerlIO *
 214 PerlIO_allocate(void)
 215 {
 216  /* Find a free slot in the table, allocating new table as necessary */
 217  PerlIO **last = &_perlio;
 218  PerlIO *f;
 219  while ((f = *last))
 220   {
 221    int i;
 222    last = (PerlIO **)(f);
 223    for (i=1; i < PERLIO_TABLE_SIZE; i++)
 224     {
 225      if (!*++f)
 226       {
 227        return f;
 228       }
 229     }
 230   }
 231  Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
 232  if (!f)
 233   return NULL;
 234  *last = f;
 235  return f+1;
 236 }
 237
 238 void
 239 PerlIO_cleantable(PerlIO **tablep)
 240 {
 241  PerlIO *table = *tablep;
 242  if (table)
 243   {
 244    int i;
 245    PerlIO_cleantable((PerlIO **) &(table[0]));
 246    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
 247     {
 248      PerlIO *f = table+i;
 249      if (*f)
 250       {
 251        PerlIO_close(f);
 252       }
 253     }
 254    Safefree(table);
 255    *tablep = NULL;
 256   }
 257 }
 258
 259 HV *PerlIO_layer_hv;
 260 AV *PerlIO_layer_av;
 261
 262 void
 263 PerlIO_cleanup(void)
 264 {
 265  PerlIO_cleantable(&_perlio);
 266 }
 267
 268 void
 269 PerlIO_pop(PerlIO *f)
 270 {
 271  PerlIOl *l = *f;
 272  if (l)
 273   {
 274    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
 275    (*l->tab->Popped)(f);
 276    *f = l->next;
 277    Safefree(l);
 278   }
 279 }
 280
 281 /*--------------------------------------------------------------------------------------*/
 282 /* XS Interface for perl code */
 283
 284 XS(XS_perlio_import)
 285 {
 286  dXSARGS;
 287  GV *gv = CvGV(cv);
 288  char *s = GvNAME(gv);
 289  STRLEN l = GvNAMELEN(gv);
 290  PerlIO_debug("%.*s\n",(int) l,s);
 291  XSRETURN_EMPTY;
 292 }
 293
 294 XS(XS_perlio_unimport)
 295 {
 296  dXSARGS;
 297  GV *gv = CvGV(cv);
 298  char *s = GvNAME(gv);
 299  STRLEN l = GvNAMELEN(gv);
 300  PerlIO_debug("%.*s\n",(int) l,s);
 301  XSRETURN_EMPTY;
 302 }
 303
 304 SV *
 305 PerlIO_find_layer(const char *name, STRLEN len)
 306 {
 307  dTHX;
 308  SV **svp;
 309  SV *sv;
 310  if (len <= 0)
 311   len = strlen(name);
 312  svp  = hv_fetch(PerlIO_layer_hv,name,len,0);
 313  if (svp && (sv = *svp) && SvROK(sv))
 314   return *svp;
 315  return NULL;
 316 }
 317
 318
 319 static int
 320 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 321 {
 322  if (SvROK(sv))
 323   {
 324    IO *io = GvIOn((GV *)SvRV(sv));
 325    PerlIO *ifp = IoIFP(io);
 326    PerlIO *ofp = IoOFP(io);
 327    AV *av = (AV *) mg->mg_obj;
 328    Perl_warn(aTHX_ "set %_ %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("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
 522    if ((*l->tab->Pushed)(f,mode) != 0)
 523     {
 524      PerlIO_pop(f);
 525      return NULL;
 526     }
 527   }
 528  return f;
 529 }
 530
 531 int
 532 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 533 {
 534  if (names)
 535   {
 536    const char *s = names;
 537    while (*s)
 538     {
 539      while (isSPACE(*s))
 540       s++;
 541      if (*s == ':')
 542       s++;
 543      if (*s)
 544       {
 545        const char *e = s;
 546        while (*e && *e != ':' && !isSPACE(*e))
 547         e++;
 548        if (e > s)
 549         {
 550          if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
 551           {
 552            /* Pop back to bottom layer */
 553            if (PerlIONext(f))
 554             {
 555              PerlIO_flush(f);
 556              while (PerlIONext(f))
 557               {
 558                PerlIO_pop(f);
 559               }
 560             }
 561           }
 562          else
 563           {
 564            SV *layer = PerlIO_find_layer(s,e-s);
 565            if (layer)
 566             {
 567              PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
 568              if (tab)
 569               {
 570                PerlIO *new = PerlIO_push(f,tab,mode);
 571                if (!new)
 572                 return -1;
 573               }
 574             }
 575            else
 576             Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
 577           }
 578         }
 579        s = e;
 580       }
 581     }
 582   }
 583  return 0;
 584 }
 585
 586
 587
 588 /*--------------------------------------------------------------------------------------*/
 589 /* Given the abstraction above the public API functions */
 590
 591 int
 592 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 593 {
 594  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 595               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
 596  if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
 597   {
 598    PerlIO *top = f;
 599    PerlIOl *l;
 600    while (l = *top)
 601     {
 602      if (PerlIOBase(top)->tab == &PerlIO_crlf)
 603       {
 604        PerlIO_flush(top);
 605        PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
 606        break;
 607       }
 608      top = PerlIONext(top);
 609     }
 610   }
 611  return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
 612 }
 613
 614 #undef PerlIO__close
 615 int
 616 PerlIO__close(PerlIO *f)
 617 {
 618  return (*PerlIOBase(f)->tab->Close)(f);
 619 }
 620
 621
 622 #undef PerlIO_close
 623 int
 624 PerlIO_close(PerlIO *f)
 625 {
 626  int code = (*PerlIOBase(f)->tab->Close)(f);
 627  while (*f)
 628   {
 629    PerlIO_pop(f);
 630   }
 631  return code;
 632 }
 633
 634 #undef PerlIO_fileno
 635 int
 636 PerlIO_fileno(PerlIO *f)
 637 {
 638  return (*PerlIOBase(f)->tab->Fileno)(f);
 639 }
 640
 641
 642
 643 #undef PerlIO_fdopen
 644 PerlIO *
 645 PerlIO_fdopen(int fd, const char *mode)
 646 {
 647  PerlIO_funcs *tab = PerlIO_default_top();
 648  if (!_perlio)
 649   PerlIO_stdstreams();
 650  return (*tab->Fdopen)(tab,fd,mode);
 651 }
 652
 653 #undef PerlIO_open
 654 PerlIO *
 655 PerlIO_open(const char *path, const char *mode)
 656 {
 657  PerlIO_funcs *tab = PerlIO_default_top();
 658  if (!_perlio)
 659   PerlIO_stdstreams();
 660  return (*tab->Open)(tab,path,mode);
 661 }
 662
 663 #undef PerlIO_reopen
 664 PerlIO *
 665 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
 666 {
 667  if (f)
 668   {
 669    PerlIO_flush(f);
 670    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
 671     {
 672      if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
 673       return f;
 674     }
 675    return NULL;
 676   }
 677  else
 678   return PerlIO_open(path,mode);
 679 }
 680
 681 #undef PerlIO_read
 682 SSize_t
 683 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
 684 {
 685  return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
 686 }
 687
 688 #undef PerlIO_unread
 689 SSize_t
 690 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
 691 {
 692  return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
 693 }
 694
 695 #undef PerlIO_write
 696 SSize_t
 697 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
 698 {
 699  return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
 700 }
 701
 702 #undef PerlIO_seek
 703 int
 704 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 705 {
 706  return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
 707 }
 708
 709 #undef PerlIO_tell
 710 Off_t
 711 PerlIO_tell(PerlIO *f)
 712 {
 713  return (*PerlIOBase(f)->tab->Tell)(f);
 714 }
 715
 716 #undef PerlIO_flush
 717 int
 718 PerlIO_flush(PerlIO *f)
 719 {
 720  if (f)
 721   {
 722    return (*PerlIOBase(f)->tab->Flush)(f);
 723   }
 724  else
 725   {
 726    PerlIO **table = &_perlio;
 727    int code = 0;
 728    while ((f = *table))
 729     {
 730      int i;
 731      table = (PerlIO **)(f++);
 732      for (i=1; i < PERLIO_TABLE_SIZE; i++)
 733       {
 734        if (*f && PerlIO_flush(f) != 0)
 735         code = -1;
 736        f++;
 737       }
 738     }
 739    return code;
 740   }
 741 }
 742
 743 #undef PerlIO_fill
 744 int
 745 PerlIO_fill(PerlIO *f)
 746 {
 747  return (*PerlIOBase(f)->tab->Fill)(f);
 748 }
 749
 750 #undef PerlIO_isutf8
 751 int
 752 PerlIO_isutf8(PerlIO *f)
 753 {
 754  return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
 755 }
 756
 757 #undef PerlIO_eof
 758 int
 759 PerlIO_eof(PerlIO *f)
 760 {
 761  return (*PerlIOBase(f)->tab->Eof)(f);
 762 }
 763
 764 #undef PerlIO_error
 765 int
 766 PerlIO_error(PerlIO *f)
 767 {
 768  return (*PerlIOBase(f)->tab->Error)(f);
 769 }
 770
 771 #undef PerlIO_clearerr
 772 void
 773 PerlIO_clearerr(PerlIO *f)
 774 {
 775  if (f && *f)
 776   (*PerlIOBase(f)->tab->Clearerr)(f);
 777 }
 778
 779 #undef PerlIO_setlinebuf
 780 void
 781 PerlIO_setlinebuf(PerlIO *f)
 782 {
 783  (*PerlIOBase(f)->tab->Setlinebuf)(f);
 784 }
 785
 786 #undef PerlIO_has_base
 787 int
 788 PerlIO_has_base(PerlIO *f)
 789 {
 790  if (f && *f)
 791   {
 792    return (PerlIOBase(f)->tab->Get_base != NULL);
 793   }
 794  return 0;
 795 }
 796
 797 #undef PerlIO_fast_gets
 798 int
 799 PerlIO_fast_gets(PerlIO *f)
 800 {
 801  if (f && *f)
 802   {
 803    PerlIOl *l = PerlIOBase(f);
 804    return (l->tab->Set_ptrcnt != NULL);
 805   }
 806  return 0;
 807 }
 808
 809 #undef PerlIO_has_cntptr
 810 int
 811 PerlIO_has_cntptr(PerlIO *f)
 812 {
 813  if (f && *f)
 814   {
 815    PerlIO_funcs *tab = PerlIOBase(f)->tab;
 816    return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
 817   }
 818  return 0;
 819 }
 820
 821 #undef PerlIO_canset_cnt
 822 int
 823 PerlIO_canset_cnt(PerlIO *f)
 824 {
 825  if (f && *f)
 826   {
 827    PerlIOl *l = PerlIOBase(f);
 828    return (l->tab->Set_ptrcnt != NULL);
 829   }
 830  return 0;
 831 }
 832
 833 #undef PerlIO_get_base
 834 STDCHAR *
 835 PerlIO_get_base(PerlIO *f)
 836 {
 837  return (*PerlIOBase(f)->tab->Get_base)(f);
 838 }
 839
 840 #undef PerlIO_get_bufsiz
 841 int
 842 PerlIO_get_bufsiz(PerlIO *f)
 843 {
 844  return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
 845 }
 846
 847 #undef PerlIO_get_ptr
 848 STDCHAR *
 849 PerlIO_get_ptr(PerlIO *f)
 850 {
 851  return (*PerlIOBase(f)->tab->Get_ptr)(f);
 852 }
 853
 854 #undef PerlIO_get_cnt
 855 int
 856 PerlIO_get_cnt(PerlIO *f)
 857 {
 858  return (*PerlIOBase(f)->tab->Get_cnt)(f);
 859 }
 860
 861 #undef PerlIO_set_cnt
 862 void
 863 PerlIO_set_cnt(PerlIO *f,int cnt)
 864 {
 865  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
 866 }
 867
 868 #undef PerlIO_set_ptrcnt
 869 void
 870 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 871 {
 872  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 873 }
 874
 875 /*--------------------------------------------------------------------------------------*/
 876 /* "Methods" of the "base class" */
 877
 878 IV
 879 PerlIOBase_fileno(PerlIO *f)
 880 {
 881  return PerlIO_fileno(PerlIONext(f));
 882 }
 883
 884 char *
 885 PerlIO_modestr(PerlIO *f,char *buf)
 886 {
 887  char *s = buf;
 888  IV flags = PerlIOBase(f)->flags;
 889  if (flags & PERLIO_F_CANREAD)
 890   *s++ = 'r';
 891  if (flags & PERLIO_F_CANWRITE)
 892   *s++ = 'w';
 893  if (flags & PERLIO_F_CRLF)
 894   *s++ = 't';
 895  else
 896   *s++ = 'b';
 897  *s = '\0';
 898  return buf;
 899 }
 900
 901 IV
 902 PerlIOBase_pushed(PerlIO *f, const char *mode)
 903 {
 904  PerlIOl *l = PerlIOBase(f);
 905  const char *omode = mode;
 906  char temp[8];
 907  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
 908                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 909  if (mode)
 910   {
 911    switch (*mode++)
 912     {
 913      case 'r':
 914       l->flags |= PERLIO_F_CANREAD;
 915       break;
 916      case 'a':
 917       l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
 918       break;
 919      case 'w':
 920       l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
 921       break;
 922      default:
 923       errno = EINVAL;
 924       return -1;
 925     }
 926    while (*mode)
 927     {
 928      switch (*mode++)
 929       {
 930        case '+':
 931         l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
 932         break;
 933        case 'b':
 934         l->flags &= ~PERLIO_F_CRLF;
 935         break;
 936        case 't':
 937         l->flags |= PERLIO_F_CRLF;
 938         break;
 939       default:
 940        errno = EINVAL;
 941        return -1;
 942       }
 943     }
 944   }
 945  else
 946   {
 947    if (l->next)
 948     {
 949      l->flags |= l->next->flags &
 950                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
 951     }
 952   }
 953  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%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    /* do something about failing setmode()? --jhi */
1682    PerlIO_debug("PerlIOBuf_fdopen %s fd=%d m=%s c=%d\n",tab->name,fd,mode,code);
1683   }
1684 #endif
1685  f = (*tab->Fdopen)(tab,fd,mode);
1686  if (f)
1687   {
1688    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1689    b->posn = PerlIO_tell(PerlIONext(f));
1690    if (init && fd == 2)
1691     {
1692      /* Initial stderr is unbuffered */
1693      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1694     }
1695    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08x\n",
1696                 self->name,f,fd,mode,PerlIOBase(f)->flags);
1697   }
1698  return f;
1699 }
1700
1701 PerlIO *
1702 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1703 {
1704  PerlIO_funcs *tab = PerlIO_default_btm();
1705  PerlIO *f = (*tab->Open)(tab,path,mode);
1706  if (f)
1707   {
1708    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1709    b->posn = PerlIO_tell(PerlIONext(f));
1710   }
1711  return f;
1712 }
1713
1714 int
1715 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1716 {
1717  PerlIO *next = PerlIONext(f);
1718  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1719  if (code = 0)
1720   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1721  if (code == 0)
1722   {
1723    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1724    b->posn = PerlIO_tell(PerlIONext(f));
1725   }
1726  return code;
1727 }
1728
1729 /* This "flush" is akin to sfio's sync in that it handles files in either
1730    read or write state
1731 */
1732 IV
1733 PerlIOBuf_flush(PerlIO *f)
1734 {
1735  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1736  int code = 0;
1737  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1738   {
1739    /* write() the buffer */
1740    STDCHAR *p = b->buf;
1741    int count;
1742    PerlIO *n = PerlIONext(f);
1743    while (p < b->ptr)
1744     {
1745      count = PerlIO_write(n,p,b->ptr - p);
1746      if (count > 0)
1747       {
1748        p += count;
1749       }
1750      else if (count < 0 || PerlIO_error(n))
1751       {
1752        PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1753        code = -1;
1754        break;
1755       }
1756     }
1757    b->posn += (p - b->buf);
1758   }
1759  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1760   {
1761    /* Note position change */
1762    b->posn += (b->ptr - b->buf);
1763    if (b->ptr < b->end)
1764     {
1765      /* We did not consume all of it */
1766      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1767       {
1768        b->posn = PerlIO_tell(PerlIONext(f));
1769       }
1770     }
1771   }
1772  b->ptr = b->end = b->buf;
1773  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1774  /* FIXME: Is this right for read case ? */
1775  if (PerlIO_flush(PerlIONext(f)) != 0)
1776   code = -1;
1777  return code;
1778 }
1779
1780 IV
1781 PerlIOBuf_fill(PerlIO *f)
1782 {
1783  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1784  PerlIO *n = PerlIONext(f);
1785  SSize_t avail;
1786  /* FIXME: doing the down-stream flush is a bad idea if it causes
1787     pre-read data in stdio buffer to be discarded
1788     but this is too simplistic - as it skips _our_ hosekeeping
1789     and breaks tell tests.
1790  if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1791   {
1792   }
1793   */
1794  if (PerlIO_flush(f) != 0)
1795   return -1;
1796
1797  b->ptr = b->end = b->buf;
1798  if (PerlIO_fast_gets(n))
1799   {
1800    /* Layer below is also buffered
1801     * We do _NOT_ want to call its ->Read() because that will loop
1802     * till it gets what we asked for which may hang on a pipe etc.
1803     * Instead take anything it has to hand, or ask it to fill _once_.
1804     */
1805    avail  = PerlIO_get_cnt(n);
1806    if (avail <= 0)
1807     {
1808      avail = PerlIO_fill(n);
1809      if (avail == 0)
1810       avail = PerlIO_get_cnt(n);
1811      else
1812       {
1813        if (!PerlIO_error(n) && PerlIO_eof(n))
1814         avail = 0;
1815       }
1816     }
1817    if (avail > 0)
1818     {
1819      STDCHAR *ptr = PerlIO_get_ptr(n);
1820      SSize_t cnt  = avail;
1821      if (avail > b->bufsiz)
1822       avail = b->bufsiz;
1823      Copy(ptr,b->buf,avail,STDCHAR);
1824      PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1825     }
1826   }
1827  else
1828   {
1829    avail = PerlIO_read(n,b->ptr,b->bufsiz);
1830   }
1831  if (avail <= 0)
1832   {
1833    if (avail == 0)
1834     PerlIOBase(f)->flags |= PERLIO_F_EOF;
1835    else
1836     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1837    return -1;
1838   }
1839  b->end      = b->buf+avail;
1840  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1841  return 0;
1842 }
1843
1844 SSize_t
1845 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1846 {
1847  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
1848  STDCHAR *buf  = (STDCHAR *) vbuf;
1849  if (f)
1850   {
1851    if (!b->ptr)
1852     PerlIO_get_base(f);
1853    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1854     return 0;
1855    while (count > 0)
1856     {
1857      SSize_t avail = PerlIO_get_cnt(f);
1858      SSize_t take  = (count < avail) ? count : avail;
1859      if (take > 0)
1860       {
1861        STDCHAR *ptr = PerlIO_get_ptr(f);
1862        Copy(ptr,buf,take,STDCHAR);
1863        PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1864        count   -= take;
1865        buf     += take;
1866       }
1867      if (count > 0  && avail <= 0)
1868       {
1869        if (PerlIO_fill(f) != 0)
1870         break;
1871       }
1872     }
1873    return (buf - (STDCHAR *) vbuf);
1874   }
1875  return 0;
1876 }
1877
1878 SSize_t
1879 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1880 {
1881  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1882  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1883  SSize_t unread = 0;
1884  SSize_t avail;
1885  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1886   PerlIO_flush(f);
1887  if (!b->buf)
1888   PerlIO_get_base(f);
1889  if (b->buf)
1890   {
1891    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1892     {
1893      avail = (b->ptr - b->buf);
1894      if (avail > (SSize_t) count)
1895       avail = count;
1896      b->ptr -= avail;
1897     }
1898    else
1899     {
1900      avail = b->bufsiz;
1901      if (avail > (SSize_t) count)
1902       avail = count;
1903      b->end = b->ptr + avail;
1904     }
1905    if (avail > 0)
1906     {
1907      buf    -= avail;
1908      if (buf != b->ptr)
1909       {
1910        Copy(buf,b->ptr,avail,STDCHAR);
1911       }
1912      count  -= avail;
1913      unread += avail;
1914      PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1915     }
1916   }
1917  return unread;
1918 }
1919
1920 SSize_t
1921 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
1922 {
1923  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1924  const STDCHAR *buf = (const STDCHAR *) vbuf;
1925  Size_t written = 0;
1926  if (!b->buf)
1927   PerlIO_get_base(f);
1928  if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1929   return 0;
1930  while (count > 0)
1931   {
1932    SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1933    if ((SSize_t) count < avail)
1934     avail = count;
1935    PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1936    if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1937     {
1938      while (avail > 0)
1939       {
1940        int ch = *buf++;
1941        *(b->ptr)++ = ch;
1942        count--;
1943        avail--;
1944        written++;
1945        if (ch == '\n')
1946         {
1947          PerlIO_flush(f);
1948          break;
1949         }
1950       }
1951     }
1952    else
1953     {
1954      if (avail)
1955       {
1956        Copy(buf,b->ptr,avail,STDCHAR);
1957        count   -= avail;
1958        buf     += avail;
1959        written += avail;
1960        b->ptr  += avail;
1961       }
1962     }
1963    if (b->ptr >= (b->buf + b->bufsiz))
1964     PerlIO_flush(f);
1965   }
1966  if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
1967   PerlIO_flush(f);
1968  return written;
1969 }
1970
1971 IV
1972 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1973 {
1974  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1975  int code = PerlIO_flush(f);
1976  if (code == 0)
1977   {
1978    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1979    code = PerlIO_seek(PerlIONext(f),offset,whence);
1980    if (code == 0)
1981     {
1982      b->posn = PerlIO_tell(PerlIONext(f));
1983     }
1984   }
1985  return code;
1986 }
1987
1988 Off_t
1989 PerlIOBuf_tell(PerlIO *f)
1990 {
1991  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1992  Off_t posn = b->posn;
1993  if (b->buf)
1994   posn += (b->ptr - b->buf);
1995  return posn;
1996 }
1997
1998 IV
1999 PerlIOBuf_close(PerlIO *f)
2000 {
2001  IV code = PerlIOBase_close(f);
2002  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2003  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2004   {
2005    Safefree(b->buf);
2006   }
2007  b->buf = NULL;
2008  b->ptr = b->end = b->buf;
2009  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2010  return code;
2011 }
2012
2013 void
2014 PerlIOBuf_setlinebuf(PerlIO *f)
2015 {
2016  if (f)
2017   {
2018    PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2019   }
2020 }
2021
2022 STDCHAR *
2023 PerlIOBuf_get_ptr(PerlIO *f)
2024 {
2025  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2026  if (!b->buf)
2027   PerlIO_get_base(f);
2028  return b->ptr;
2029 }
2030
2031 SSize_t
2032 PerlIOBuf_get_cnt(PerlIO *f)
2033 {
2034  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2035  if (!b->buf)
2036   PerlIO_get_base(f);
2037  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2038   return (b->end - b->ptr);
2039  return 0;
2040 }
2041
2042 STDCHAR *
2043 PerlIOBuf_get_base(PerlIO *f)
2044 {
2045  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2046  if (!b->buf)
2047   {
2048    if (!b->bufsiz)
2049     b->bufsiz = 4096;
2050    New('B',b->buf,b->bufsiz,STDCHAR);
2051    if (!b->buf)
2052     {
2053      b->buf = (STDCHAR *)&b->oneword;
2054      b->bufsiz = sizeof(b->oneword);
2055     }
2056    b->ptr = b->buf;
2057    b->end = b->ptr;
2058   }
2059  return b->buf;
2060 }
2061
2062 Size_t
2063 PerlIOBuf_bufsiz(PerlIO *f)
2064 {
2065  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2066  if (!b->buf)
2067   PerlIO_get_base(f);
2068  return (b->end - b->buf);
2069 }
2070
2071 void
2072 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2073 {
2074  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2075  if (!b->buf)
2076   PerlIO_get_base(f);
2077  b->ptr = ptr;
2078  if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2079   {
2080    dTHX;
2081    assert(PerlIO_get_cnt(f) == cnt);
2082    assert(b->ptr >= b->buf);
2083   }
2084  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2085 }
2086
2087 PerlIO_funcs PerlIO_perlio = {
2088  "perlio",
2089  sizeof(PerlIOBuf),
2090  PERLIO_K_BUFFERED,
2091  PerlIOBase_fileno,
2092  PerlIOBuf_fdopen,
2093  PerlIOBuf_open,
2094  PerlIOBuf_reopen,
2095  PerlIOBase_pushed,
2096  PerlIOBase_noop_ok,
2097  PerlIOBuf_read,
2098  PerlIOBuf_unread,
2099  PerlIOBuf_write,
2100  PerlIOBuf_seek,
2101  PerlIOBuf_tell,
2102  PerlIOBuf_close,
2103  PerlIOBuf_flush,
2104  PerlIOBuf_fill,
2105  PerlIOBase_eof,
2106  PerlIOBase_error,
2107  PerlIOBase_clearerr,
2108  PerlIOBuf_setlinebuf,
2109  PerlIOBuf_get_base,
2110  PerlIOBuf_bufsiz,
2111  PerlIOBuf_get_ptr,
2112  PerlIOBuf_get_cnt,
2113  PerlIOBuf_set_ptrcnt,
2114 };
2115
2116 /*--------------------------------------------------------------------------------------*/
2117 /* crlf - translation
2118    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2119    to hand back a line at a time and keeping a record of which nl we "lied" about.
2120    On write translate "\n" to CR,LF
2121  */
2122
2123 typedef struct
2124 {
2125  PerlIOBuf      base;         /* PerlIOBuf stuff */
2126  STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
2127 } PerlIOCrlf;
2128
2129 IV
2130 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2131 {
2132  IV code;
2133  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2134  code = PerlIOBase_pushed(f,mode);
2135  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08x\n",
2136               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2137               PerlIOBase(f)->flags);
2138  return code;
2139 }
2140
2141
2142 SSize_t
2143 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2144 {
2145  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2146  if (c->nl)
2147   {
2148    *(c->nl) = 0xd;
2149    c->nl = NULL;
2150   }
2151  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2152   return PerlIOBuf_unread(f,vbuf,count);
2153  else
2154   {
2155    const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2156    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2157    SSize_t unread = 0;
2158    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2159     PerlIO_flush(f);
2160    if (!b->buf)
2161     PerlIO_get_base(f);
2162    if (b->buf)
2163     {
2164      if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2165       {
2166        b->end = b->ptr = b->buf + b->bufsiz;
2167        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2168       }
2169      while (count > 0 && b->ptr > b->buf)
2170       {
2171        int ch = *--buf;
2172        if (ch == '\n')
2173         {
2174          if (b->ptr - 2 >= b->buf)
2175           {
2176            *--(b->ptr) = 0xa;
2177            *--(b->ptr) = 0xd;
2178            unread++;
2179            count--;
2180           }
2181          else
2182           {
2183            buf++;
2184            break;
2185           }
2186         }
2187        else
2188         {
2189          *--(b->ptr) = ch;
2190          unread++;
2191          count--;
2192         }
2193       }
2194     }
2195    return unread;
2196   }
2197 }
2198
2199 SSize_t
2200 PerlIOCrlf_get_cnt(PerlIO *f)
2201 {
2202  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2203  if (!b->buf)
2204   PerlIO_get_base(f);
2205  if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2206   {
2207    PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2208    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2209     {
2210      STDCHAR *nl   = b->ptr;
2211     scan:
2212      while (nl < b->end && *nl != 0xd)
2213       nl++;
2214      if (nl < b->end && *nl == 0xd)
2215       {
2216      test:
2217        if (nl+1 < b->end)
2218         {
2219          if (nl[1] == 0xa)
2220           {
2221            *nl   = '\n';
2222            c->nl = nl;
2223           }
2224          else
2225           {
2226            /* Not CR,LF but just CR */
2227            nl++;
2228            goto scan;
2229           }
2230         }
2231        else
2232         {
2233          /* Blast - found CR as last char in buffer */
2234          if (b->ptr < nl)
2235           {
2236            /* They may not care, defer work as long as possible */
2237            return (nl - b->ptr);
2238           }
2239          else
2240           {
2241            int code;
2242            dTHX;
2243            b->ptr++;               /* say we have read it as far as flush() is concerned */
2244            b->buf++;               /* Leave space an front of buffer */
2245            b->bufsiz--;            /* Buffer is thus smaller */
2246            code = PerlIO_fill(f);  /* Fetch some more */
2247            b->bufsiz++;            /* Restore size for next time */
2248            b->buf--;               /* Point at space */
2249            b->ptr = nl = b->buf;   /* Which is what we hand off */
2250            b->posn--;              /* Buffer starts here */
2251            *nl = 0xd;              /* Fill in the CR */
2252            if (code == 0)
2253             goto test;             /* fill() call worked */
2254            /* CR at EOF - just fall through */
2255           }
2256         }
2257       }
2258     }
2259    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2260   }
2261  return 0;
2262 }
2263
2264 void
2265 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2266 {
2267  PerlIOBuf *b  = PerlIOSelf(f,PerlIOBuf);
2268  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2269  IV flags = PerlIOBase(f)->flags;
2270  if (!b->buf)
2271   PerlIO_get_base(f);
2272  if (!ptr)
2273   {
2274    if (c->nl)
2275     ptr = c->nl+1;
2276    else
2277     {
2278      ptr = b->end;
2279      if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2280       ptr--;
2281     }
2282    ptr -= cnt;
2283   }
2284  else
2285   {
2286    /* Test code - delete when it works ... */
2287    STDCHAR *chk;
2288    if (c->nl)
2289     chk = c->nl+1;
2290    else
2291     {
2292      chk = b->end;
2293      if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2294       chk--;
2295     }
2296    chk -= cnt;
2297
2298    if (ptr != chk)
2299     {
2300      dTHX;
2301      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
2302                 ptr, chk, flags, c->nl, b->end, cnt);
2303     }
2304   }
2305  if (c->nl)
2306   {
2307    if (ptr > c->nl)
2308     {
2309      /* They have taken what we lied about */
2310      *(c->nl) = 0xd;
2311      c->nl = NULL;
2312      ptr++;
2313     }
2314   }
2315  b->ptr = ptr;
2316  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2317 }
2318
2319 SSize_t
2320 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2321 {
2322  if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2323   return PerlIOBuf_write(f,vbuf,count);
2324  else
2325   {
2326    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2327    const STDCHAR *buf  = (const STDCHAR *) vbuf;
2328    const STDCHAR *ebuf = buf+count;
2329    if (!b->buf)
2330     PerlIO_get_base(f);
2331    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2332     return 0;
2333    while (buf < ebuf)
2334     {
2335      STDCHAR *eptr = b->buf+b->bufsiz;
2336      PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2337      while (buf < ebuf && b->ptr < eptr)
2338       {
2339        if (*buf == '\n')
2340         {
2341          if ((b->ptr + 2) > eptr)
2342           {
2343            /* Not room for both */
2344            PerlIO_flush(f);
2345            break;
2346           }
2347          else
2348           {
2349            *(b->ptr)++ = 0xd; /* CR */
2350            *(b->ptr)++ = 0xa; /* LF */
2351            buf++;
2352            if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2353             {
2354              PerlIO_flush(f);
2355              break;
2356             }
2357           }
2358         }
2359        else
2360         {
2361          int ch = *buf++;
2362          *(b->ptr)++ = ch;
2363         }
2364        if (b->ptr >= eptr)
2365         {
2366          PerlIO_flush(f);
2367          break;
2368         }
2369       }
2370     }
2371    if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2372     PerlIO_flush(f);
2373    return (buf - (STDCHAR *) vbuf);
2374   }
2375 }
2376
2377 IV
2378 PerlIOCrlf_flush(PerlIO *f)
2379 {
2380  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2381  if (c->nl)
2382   {
2383    *(c->nl) = 0xd;
2384    c->nl = NULL;
2385   }
2386  return PerlIOBuf_flush(f);
2387 }
2388
2389 PerlIO_funcs PerlIO_crlf = {
2390  "crlf",
2391  sizeof(PerlIOCrlf),
2392  PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2393  PerlIOBase_fileno,
2394  PerlIOBuf_fdopen,
2395  PerlIOBuf_open,
2396  PerlIOBuf_reopen,
2397  PerlIOCrlf_pushed,
2398  PerlIOBase_noop_ok,   /* popped */
2399  PerlIOBuf_read,       /* generic read works with ptr/cnt lies ... */
2400  PerlIOCrlf_unread,    /* Put CR,LF in buffer for each '\n' */
2401  PerlIOCrlf_write,     /* Put CR,LF in buffer for each '\n' */
2402  PerlIOBuf_seek,
2403  PerlIOBuf_tell,
2404  PerlIOBuf_close,
2405  PerlIOCrlf_flush,
2406  PerlIOBuf_fill,
2407  PerlIOBase_eof,
2408  PerlIOBase_error,
2409  PerlIOBase_clearerr,
2410  PerlIOBuf_setlinebuf,
2411  PerlIOBuf_get_base,
2412  PerlIOBuf_bufsiz,
2413  PerlIOBuf_get_ptr,
2414  PerlIOCrlf_get_cnt,
2415  PerlIOCrlf_set_ptrcnt,
2416 };
2417
2418 #ifdef HAS_MMAP
2419 /*--------------------------------------------------------------------------------------*/
2420 /* mmap as "buffer" layer */
2421
2422 typedef struct
2423 {
2424  PerlIOBuf      base;         /* PerlIOBuf stuff */
2425  Mmap_t         mptr;        /* Mapped address */
2426  Size_t         len;          /* mapped length */
2427  STDCHAR        *bbuf;        /* malloced buffer if map fails */
2428 } PerlIOMmap;
2429
2430 static size_t page_size = 0;
2431
2432 IV
2433 PerlIOMmap_map(PerlIO *f)
2434 {
2435  dTHX;
2436  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2437  PerlIOBuf  *b = &m->base;
2438  IV flags = PerlIOBase(f)->flags;
2439  IV code  = 0;
2440  if (m->len)
2441   abort();
2442  if (flags & PERLIO_F_CANREAD)
2443   {
2444    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2445    int fd   = PerlIO_fileno(f);
2446    struct stat st;
2447    code = fstat(fd,&st);
2448    if (code == 0 && S_ISREG(st.st_mode))
2449     {
2450      SSize_t len = st.st_size - b->posn;
2451      if (len > 0)
2452       {
2453        Off_t posn;
2454        if (!page_size) {
2455 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2456            {
2457                SETERRNO(0,SS$_NORMAL);
2458 #   ifdef _SC_PAGESIZE
2459                page_size = sysconf(_SC_PAGESIZE);
2460 #   else
2461                page_size = sysconf(_SC_PAGE_SIZE);
2462 #   endif
2463                if ((long)page_size < 0) {
2464                    if (errno) {
2465                        SV *error = ERRSV;
2466                        char *msg;
2467                        STRLEN n_a;
2468                        (void)SvUPGRADE(error, SVt_PV);
2469                        msg = SvPVx(error, n_a);
2470                        Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2471                    }
2472                    else
2473                        Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2474                }
2475            }
2476 #else
2477 #   ifdef HAS_GETPAGESIZE
2478         page_size = getpagesize();
2479 #   else
2480 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
2481         page_size = PAGESIZE; /* compiletime, bad */
2482 #       endif
2483 #   endif
2484 #endif
2485         if ((IV)page_size <= 0)
2486             Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2487        }
2488        if (b->posn < 0)
2489         {
2490          /* This is a hack - should never happen - open should have set it ! */
2491          b->posn = PerlIO_tell(PerlIONext(f));
2492         }
2493        posn = (b->posn / page_size) * page_size;
2494        len  = st.st_size - posn;
2495        m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2496        if (m->mptr && m->mptr != (Mmap_t) -1)
2497         {
2498 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2499          madvise(m->mptr, len, MADV_SEQUENTIAL);
2500 #endif
2501          PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2502          b->end  = ((STDCHAR *)m->mptr) + len;
2503          b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
2504          b->ptr  = b->buf;
2505          m->len  = len;
2506         }
2507        else
2508         {
2509          b->buf = NULL;
2510         }
2511       }
2512      else
2513       {
2514        PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2515        b->buf = NULL;
2516        b->ptr = b->end = b->ptr;
2517        code = -1;
2518       }
2519     }
2520   }
2521  return code;
2522 }
2523
2524 IV
2525 PerlIOMmap_unmap(PerlIO *f)
2526 {
2527  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2528  PerlIOBuf  *b = &m->base;
2529  IV code = 0;
2530  if (m->len)
2531   {
2532    if (b->buf)
2533     {
2534      code = munmap(m->mptr, m->len);
2535      b->buf  = NULL;
2536      m->len  = 0;
2537      m->mptr = NULL;
2538      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2539       code = -1;
2540     }
2541    b->ptr = b->end = b->buf;
2542    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2543   }
2544  return code;
2545 }
2546
2547 STDCHAR *
2548 PerlIOMmap_get_base(PerlIO *f)
2549 {
2550  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2551  PerlIOBuf  *b = &m->base;
2552  if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2553   {
2554    /* Already have a readbuffer in progress */
2555    return b->buf;
2556   }
2557  if (b->buf)
2558   {
2559    /* We have a write buffer or flushed PerlIOBuf read buffer */
2560    m->bbuf = b->buf;  /* save it in case we need it again */
2561    b->buf  = NULL;    /* Clear to trigger below */
2562   }
2563  if (!b->buf)
2564   {
2565    PerlIOMmap_map(f);     /* Try and map it */
2566    if (!b->buf)
2567     {
2568      /* Map did not work - recover PerlIOBuf buffer if we have one */
2569      b->buf = m->bbuf;
2570     }
2571   }
2572  b->ptr  = b->end = b->buf;
2573  if (b->buf)
2574   return b->buf;
2575  return PerlIOBuf_get_base(f);
2576 }
2577
2578 SSize_t
2579 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2580 {
2581  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2582  PerlIOBuf  *b = &m->base;
2583  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2584   PerlIO_flush(f);
2585  if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2586   {
2587    b->ptr -= count;
2588    PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2589    return count;
2590   }
2591  if (m->len)
2592   {
2593    /* Loose the unwritable mapped buffer */
2594    PerlIO_flush(f);
2595    /* If flush took the "buffer" see if we have one from before */
2596    if (!b->buf && m->bbuf)
2597     b->buf = m->bbuf;
2598    if (!b->buf)
2599     {
2600      PerlIOBuf_get_base(f);
2601      m->bbuf = b->buf;
2602     }
2603   }
2604  return PerlIOBuf_unread(f,vbuf,count);
2605 }
2606
2607 SSize_t
2608 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2609 {
2610  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2611  PerlIOBuf  *b = &m->base;
2612  if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2613   {
2614    /* No, or wrong sort of, buffer */
2615    if (m->len)
2616     {
2617      if (PerlIOMmap_unmap(f) != 0)
2618       return 0;
2619     }
2620    /* If unmap took the "buffer" see if we have one from before */
2621    if (!b->buf && m->bbuf)
2622     b->buf = m->bbuf;
2623    if (!b->buf)
2624     {
2625      PerlIOBuf_get_base(f);
2626      m->bbuf = b->buf;
2627     }
2628   }
2629  return PerlIOBuf_write(f,vbuf,count);
2630 }
2631
2632 IV
2633 PerlIOMmap_flush(PerlIO *f)
2634 {
2635  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2636  PerlIOBuf  *b = &m->base;
2637  IV code = PerlIOBuf_flush(f);
2638  /* Now we are "synced" at PerlIOBuf level */
2639  if (b->buf)
2640   {
2641    if (m->len)
2642     {
2643      /* Unmap the buffer */
2644      if (PerlIOMmap_unmap(f) != 0)
2645       code = -1;
2646     }
2647    else
2648     {
2649      /* We seem to have a PerlIOBuf buffer which was not mapped
2650       * remember it in case we need one later
2651       */
2652      m->bbuf = b->buf;
2653     }
2654   }
2655  return code;
2656 }
2657
2658 IV
2659 PerlIOMmap_fill(PerlIO *f)
2660 {
2661  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2662  IV code = PerlIO_flush(f);
2663  if (code == 0 && !b->buf)
2664   {
2665    code = PerlIOMmap_map(f);
2666   }
2667  if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2668   {
2669    code = PerlIOBuf_fill(f);
2670   }
2671  return code;
2672 }
2673
2674 IV
2675 PerlIOMmap_close(PerlIO *f)
2676 {
2677  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2678  PerlIOBuf  *b = &m->base;
2679  IV code = PerlIO_flush(f);
2680  if (m->bbuf)
2681   {
2682    b->buf  = m->bbuf;
2683    m->bbuf = NULL;
2684    b->ptr  = b->end = b->buf;
2685   }
2686  if (PerlIOBuf_close(f) != 0)
2687   code = -1;
2688  return code;
2689 }
2690
2691
2692 PerlIO_funcs PerlIO_mmap = {
2693  "mmap",
2694  sizeof(PerlIOMmap),
2695  PERLIO_K_BUFFERED,
2696  PerlIOBase_fileno,
2697  PerlIOBuf_fdopen,
2698  PerlIOBuf_open,
2699  PerlIOBuf_reopen,
2700  PerlIOBase_pushed,
2701  PerlIOBase_noop_ok,
2702  PerlIOBuf_read,
2703  PerlIOMmap_unread,
2704  PerlIOMmap_write,
2705  PerlIOBuf_seek,
2706  PerlIOBuf_tell,
2707  PerlIOBuf_close,
2708  PerlIOMmap_flush,
2709  PerlIOMmap_fill,
2710  PerlIOBase_eof,
2711  PerlIOBase_error,
2712  PerlIOBase_clearerr,
2713  PerlIOBuf_setlinebuf,
2714  PerlIOMmap_get_base,
2715  PerlIOBuf_bufsiz,
2716  PerlIOBuf_get_ptr,
2717  PerlIOBuf_get_cnt,
2718  PerlIOBuf_set_ptrcnt,
2719 };
2720
2721 #endif /* HAS_MMAP */
2722
2723 void
2724 PerlIO_init(void)
2725 {
2726  if (!_perlio)
2727   {
2728    atexit(&PerlIO_cleanup);
2729   }
2730 }
2731
2732 #undef PerlIO_stdin
2733 PerlIO *
2734 PerlIO_stdin(void)
2735 {
2736  if (!_perlio)
2737   PerlIO_stdstreams();
2738  return &_perlio[1];
2739 }
2740
2741 #undef PerlIO_stdout
2742 PerlIO *
2743 PerlIO_stdout(void)
2744 {
2745  if (!_perlio)
2746   PerlIO_stdstreams();
2747  return &_perlio[2];
2748 }
2749
2750 #undef PerlIO_stderr
2751 PerlIO *
2752 PerlIO_stderr(void)
2753 {
2754  if (!_perlio)
2755   PerlIO_stdstreams();
2756  return &_perlio[3];
2757 }
2758
2759 /*--------------------------------------------------------------------------------------*/
2760
2761 #undef PerlIO_getname
2762 char *
2763 PerlIO_getname(PerlIO *f, char *buf)
2764 {
2765  dTHX;
2766  Perl_croak(aTHX_ "Don't know how to get file name");
2767  return NULL;
2768 }
2769
2770
2771 /*--------------------------------------------------------------------------------------*/
2772 /* Functions which can be called on any kind of PerlIO implemented
2773    in terms of above
2774 */
2775
2776 #undef PerlIO_getc
2777 int
2778 PerlIO_getc(PerlIO *f)
2779 {
2780  STDCHAR buf[1];
2781  SSize_t count = PerlIO_read(f,buf,1);
2782  if (count == 1)
2783   {
2784    return (unsigned char) buf[0];
2785   }
2786  return EOF;
2787 }
2788
2789 #undef PerlIO_ungetc
2790 int
2791 PerlIO_ungetc(PerlIO *f, int ch)
2792 {
2793  if (ch != EOF)
2794   {
2795    STDCHAR buf = ch;
2796    if (PerlIO_unread(f,&buf,1) == 1)
2797     return ch;
2798   }
2799  return EOF;
2800 }
2801
2802 #undef PerlIO_putc
2803 int
2804 PerlIO_putc(PerlIO *f, int ch)
2805 {
2806  STDCHAR buf = ch;
2807  return PerlIO_write(f,&buf,1);
2808 }
2809
2810 #undef PerlIO_puts
2811 int
2812 PerlIO_puts(PerlIO *f, const char *s)
2813 {
2814  STRLEN len = strlen(s);
2815  return PerlIO_write(f,s,len);
2816 }
2817
2818 #undef PerlIO_rewind
2819 void
2820 PerlIO_rewind(PerlIO *f)
2821 {
2822  PerlIO_seek(f,(Off_t)0,SEEK_SET);
2823  PerlIO_clearerr(f);
2824 }
2825
2826 #undef PerlIO_vprintf
2827 int
2828 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2829 {
2830  dTHX;
2831  SV *sv = newSVpvn("",0);
2832  char *s;
2833  STRLEN len;
2834 #ifdef NEED_VA_COPY
2835  va_list apc;
2836  Perl_va_copy(ap, apc);
2837  sv_vcatpvf(sv, fmt, &apc);
2838 #else
2839  sv_vcatpvf(sv, fmt, &ap);
2840 #endif
2841  s = SvPV(sv,len);
2842  return PerlIO_write(f,s,len);
2843 }
2844
2845 #undef PerlIO_printf
2846 int
2847 PerlIO_printf(PerlIO *f,const char *fmt,...)
2848 {
2849  va_list ap;
2850  int result;
2851  va_start(ap,fmt);
2852  result = PerlIO_vprintf(f,fmt,ap);
2853  va_end(ap);
2854  return result;
2855 }
2856
2857 #undef PerlIO_stdoutf
2858 int
2859 PerlIO_stdoutf(const char *fmt,...)
2860 {
2861  va_list ap;
2862  int result;
2863  va_start(ap,fmt);
2864  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2865  va_end(ap);
2866  return result;
2867 }
2868
2869 #undef PerlIO_tmpfile
2870 PerlIO *
2871 PerlIO_tmpfile(void)
2872 {
2873  /* I have no idea how portable mkstemp() is ... */
2874 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
2875  PerlIO *f = NULL;
2876  FILE *stdio = tmpfile();
2877  if (stdio)
2878   {
2879    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2880    s->stdio  = stdio;
2881   }
2882  return f;
2883 #else
2884  dTHX;
2885  SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2886  int fd = mkstemp(SvPVX(sv));
2887  PerlIO *f = NULL;
2888  if (fd >= 0)
2889   {
2890    f = PerlIO_fdopen(fd,"w+");
2891    if (f)
2892     {
2893      PerlIOBase(f)->flags |= PERLIO_F_TEMP;
2894     }
2895    PerlLIO_unlink(SvPVX(sv));
2896    SvREFCNT_dec(sv);
2897   }
2898  return f;
2899 #endif
2900 }
2901
2902 #undef HAS_FSETPOS
2903 #undef HAS_FGETPOS
2904
2905 #endif /* USE_SFIO */
2906 #endif /* PERLIO_IS_STDIO */
2907
2908 /*======================================================================================*/
2909 /* Now some functions in terms of above which may be needed even if
2910    we are not in true PerlIO mode
2911  */
2912
2913 #ifndef HAS_FSETPOS
2914 #undef PerlIO_setpos
2915 int
2916 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2917 {
2918  return PerlIO_seek(f,*pos,0);
2919 }
2920 #else
2921 #ifndef PERLIO_IS_STDIO
2922 #undef PerlIO_setpos
2923 int
2924 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
2925 {
2926 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2927  return fsetpos64(f, pos);
2928 #else
2929  return fsetpos(f, pos);
2930 #endif
2931 }
2932 #endif
2933 #endif
2934
2935 #ifndef HAS_FGETPOS
2936 #undef PerlIO_getpos
2937 int
2938 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2939 {
2940  *pos = PerlIO_tell(f);
2941  return *pos == -1 ? -1 : 0;
2942 }
2943 #else
2944 #ifndef PERLIO_IS_STDIO
2945 #undef PerlIO_getpos
2946 int
2947 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
2948 {
2949 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
2950  return fgetpos64(f, pos);
2951 #else
2952  return fgetpos(f, pos);
2953 #endif
2954 }
2955 #endif
2956 #endif
2957
2958 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2959
2960 int
2961 vprintf(char *pat, char *args)
2962 {
2963     _doprnt(pat, args, stdout);
2964     return 0;           /* wrong, but perl doesn't use the return value */
2965 }
2966
2967 int
2968 vfprintf(FILE *fd, char *pat, char *args)
2969 {
2970     _doprnt(pat, args, fd);
2971     return 0;           /* wrong, but perl doesn't use the return value */
2972 }
2973
2974 #endif
2975
2976 #ifndef PerlIO_vsprintf
2977 int
2978 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
2979 {
2980  int val = vsprintf(s, fmt, ap);
2981  if (n >= 0)
2982   {
2983    if (strlen(s) >= (STRLEN)n)
2984     {
2985      dTHX;
2986      (void)PerlIO_puts(Perl_error_log,
2987                        "panic: sprintf overflow - memory corrupted!\n");
2988      my_exit(1);
2989     }
2990   }
2991  return val;
2992 }
2993 #endif
2994
2995 #ifndef PerlIO_sprintf
2996 int
2997 PerlIO_sprintf(char *s, int n, const char *fmt,...)
2998 {
2999  va_list ap;
3000  int result;
3001  va_start(ap,fmt);
3002  result = PerlIO_vsprintf(s, n, fmt, ap);
3003  va_end(ap);
3004  return result;
3005 }
3006 #endif
3007
3008 #endif /* !PERL_IMPLICIT_SYS */
3009