perlio.c

   1 /*    perlio.c
   2  *
   3  *    Copyright (c) 1996-1999, 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
  11 #define VOIDUSED 1
  12 #include "config.h"
  13
  14 #define PERLIO_NOT_STDIO 0
  15 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  16 #define PerlIO FILE
  17 #endif
  18 /*
  19  * This file provides those parts of PerlIO abstraction
  20  * which are not #defined in iperlsys.h.
  21  * Which these are depends on various Configure #ifdef's
  22  */
  23
  24 #include "EXTERN.h"
  25 #define PERL_IN_PERLIO_C
  26 #include "perl.h"
  27
  28 #if !defined(PERL_IMPLICIT_SYS)
  29
  30 #ifdef PERLIO_IS_STDIO
  31
  32 void
  33 PerlIO_init(void)
  34 {
  35  /* Does nothing (yet) except force this file to be included
  36     in perl binary. That allows this file to force inclusion
  37     of other functions that may be required by loadable
  38     extensions e.g. for FileHandle::tmpfile
  39  */
  40 }
  41
  42 #undef PerlIO_tmpfile
  43 PerlIO *
  44 PerlIO_tmpfile(void)
  45 {
  46  return tmpfile();
  47 }
  48
  49 #else /* PERLIO_IS_STDIO */
  50
  51 #ifdef USE_SFIO
  52
  53 #undef HAS_FSETPOS
  54 #undef HAS_FGETPOS
  55
  56 /* This section is just to make sure these functions
  57    get pulled in from libsfio.a
  58 */
  59
  60 #undef PerlIO_tmpfile
  61 PerlIO *
  62 PerlIO_tmpfile(void)
  63 {
  64  return sftmp(0);
  65 }
  66
  67 void
  68 PerlIO_init(void)
  69 {
  70  /* Force this file to be included  in perl binary. Which allows
  71   *  this file to force inclusion  of other functions that may be
  72   *  required by loadable  extensions e.g. for FileHandle::tmpfile
  73   */
  74
  75  /* Hack
  76   * sfio does its own 'autoflush' on stdout in common cases.
  77   * Flush results in a lot of lseek()s to regular files and
  78   * lot of small writes to pipes.
  79   */
  80  sfset(sfstdout,SF_SHARE,0);
  81 }
  82
  83 #else /* USE_SFIO */
  84
  85 /* Implement all the PerlIO interface using stdio.
  86    - this should be only file to include <stdio.h>
  87 */
  88
  89 #undef PerlIO_stderr
  90 PerlIO *
  91 PerlIO_stderr(void)
  92 {
  93  return (PerlIO *) stderr;
  94 }
  95
  96 #undef PerlIO_stdin
  97 PerlIO *
  98 PerlIO_stdin(void)
  99 {
 100  return (PerlIO *) stdin;
 101 }
 102
 103 #undef PerlIO_stdout
 104 PerlIO *
 105 PerlIO_stdout(void)
 106 {
 107  return (PerlIO *) stdout;
 108 }
 109
 110 #undef PerlIO_fast_gets
 111 int
 112 PerlIO_fast_gets(PerlIO *f)
 113 {
 114 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
 115  return 1;
 116 #else
 117  return 0;
 118 #endif
 119 }
 120
 121 #undef PerlIO_has_cntptr
 122 int
 123 PerlIO_has_cntptr(PerlIO *f)
 124 {
 125 #if defined(USE_STDIO_PTR)
 126  return 1;
 127 #else
 128  return 0;
 129 #endif
 130 }
 131
 132 #undef PerlIO_canset_cnt
 133 int
 134 PerlIO_canset_cnt(PerlIO *f)
 135 {
 136 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
 137  return 1;
 138 #else
 139  return 0;
 140 #endif
 141 }
 142
 143 #undef PerlIO_set_cnt
 144 void
 145 PerlIO_set_cnt(PerlIO *f, int cnt)
 146 {
 147  dTHX;
 148  if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
 149   Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
 150 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
 151  FILE_cnt(f) = cnt;
 152 #else
 153  Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
 154 #endif
 155 }
 156
 157 #undef PerlIO_set_ptrcnt
 158 void
 159 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 160 {
 161  dTHX;
 162 #ifdef FILE_bufsiz
 163  STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
 164  int ec = e - ptr;
 165  if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
 166   Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
 167  if (cnt != ec && ckWARN_d(WARN_INTERNAL))
 168   Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
 169 #endif
 170 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
 171   FILE_ptr(f) = ptr;
 172 #else
 173   Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
 174 #endif
 175 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
 176   FILE_cnt(f) = cnt;
 177 #else
 178   Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
 179 #endif
 180 }
 181
 182 #undef PerlIO_get_cnt
 183 int
 184 PerlIO_get_cnt(PerlIO *f)
 185 {
 186 #ifdef FILE_cnt
 187  return FILE_cnt(f);
 188 #else
 189  dTHX;
 190  Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
 191  return -1;
 192 #endif
 193 }
 194
 195 #undef PerlIO_get_bufsiz
 196 int
 197 PerlIO_get_bufsiz(PerlIO *f)
 198 {
 199 #ifdef FILE_bufsiz
 200  return FILE_bufsiz(f);
 201 #else
 202  dTHX;
 203  Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
 204  return -1;
 205 #endif
 206 }
 207
 208 #undef PerlIO_get_ptr
 209 STDCHAR *
 210 PerlIO_get_ptr(PerlIO *f)
 211 {
 212 #ifdef FILE_ptr
 213  return FILE_ptr(f);
 214 #else
 215  dTHX;
 216  Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
 217  return NULL;
 218 #endif
 219 }
 220
 221 #undef PerlIO_get_base
 222 STDCHAR *
 223 PerlIO_get_base(PerlIO *f)
 224 {
 225 #ifdef FILE_base
 226  return FILE_base(f);
 227 #else
 228  dTHX;
 229  Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
 230  return NULL;
 231 #endif
 232 }
 233
 234 #undef PerlIO_has_base
 235 int
 236 PerlIO_has_base(PerlIO *f)
 237 {
 238 #ifdef FILE_base
 239  return 1;
 240 #else
 241  return 0;
 242 #endif
 243 }
 244
 245 #undef PerlIO_puts
 246 int
 247 PerlIO_puts(PerlIO *f, const char *s)
 248 {
 249  return fputs(s,f);
 250 }
 251
 252 #undef PerlIO_open
 253 PerlIO *
 254 PerlIO_open(const char *path, const char *mode)
 255 {
 256  return fopen(path,mode);
 257 }
 258
 259 #undef PerlIO_fdopen
 260 PerlIO *
 261 PerlIO_fdopen(int fd, const char *mode)
 262 {
 263  return fdopen(fd,mode);
 264 }
 265
 266 #undef PerlIO_reopen
 267 PerlIO *
 268 PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
 269 {
 270  return freopen(name,mode,f);
 271 }
 272
 273 #undef PerlIO_close
 274 int
 275 PerlIO_close(PerlIO *f)
 276 {
 277  return fclose(f);
 278 }
 279
 280 #undef PerlIO_eof
 281 int
 282 PerlIO_eof(PerlIO *f)
 283 {
 284  return feof(f);
 285 }
 286
 287 #undef PerlIO_getname
 288 char *
 289 PerlIO_getname(PerlIO *f, char *buf)
 290 {
 291 #ifdef VMS
 292  return fgetname(f,buf);
 293 #else
 294  dTHX;
 295  Perl_croak(aTHX_ "Don't know how to get file name");
 296  return NULL;
 297 #endif
 298 }
 299
 300 #undef PerlIO_getc
 301 int
 302 PerlIO_getc(PerlIO *f)
 303 {
 304  return fgetc(f);
 305 }
 306
 307 #undef PerlIO_error
 308 int
 309 PerlIO_error(PerlIO *f)
 310 {
 311  return ferror(f);
 312 }
 313
 314 #undef PerlIO_clearerr
 315 void
 316 PerlIO_clearerr(PerlIO *f)
 317 {
 318  clearerr(f);
 319 }
 320
 321 #undef PerlIO_flush
 322 int
 323 PerlIO_flush(PerlIO *f)
 324 {
 325  return Fflush(f);
 326 }
 327
 328 #undef PerlIO_fileno
 329 int
 330 PerlIO_fileno(PerlIO *f)
 331 {
 332  return fileno(f);
 333 }
 334
 335 #undef PerlIO_setlinebuf
 336 void
 337 PerlIO_setlinebuf(PerlIO *f)
 338 {
 339 #ifdef HAS_SETLINEBUF
 340     setlinebuf(f);
 341 #else
 342 #  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
 343     setvbuf(f, Nullch, _IOLBF, BUFSIZ);
 344 #  else
 345     setvbuf(f, Nullch, _IOLBF, 0);
 346 #  endif
 347 #endif
 348 }
 349
 350 #undef PerlIO_putc
 351 int
 352 PerlIO_putc(PerlIO *f, int ch)
 353 {
 354  return putc(ch,f);
 355 }
 356
 357 #undef PerlIO_ungetc
 358 int
 359 PerlIO_ungetc(PerlIO *f, int ch)
 360 {
 361  return ungetc(ch,f);
 362 }
 363
 364 #undef PerlIO_read
 365 SSize_t
 366 PerlIO_read(PerlIO *f, void *buf, Size_t count)
 367 {
 368  return fread(buf,1,count,f);
 369 }
 370
 371 #undef PerlIO_write
 372 SSize_t
 373 PerlIO_write(PerlIO *f, const void *buf, Size_t count)
 374 {
 375  return fwrite1(buf,1,count,f);
 376 }
 377
 378 #undef PerlIO_vprintf
 379 int
 380 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
 381 {
 382  return vfprintf(f,fmt,ap);
 383 }
 384
 385 #undef PerlIO_tell
 386 Off_t
 387 PerlIO_tell(PerlIO *f)
 388 {
 389 #if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
 390  return ftello(f);
 391 #else
 392  return ftell(f);
 393 #endif
 394 }
 395
 396 #undef PerlIO_seek
 397 int
 398 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 399 {
 400 #if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
 401  return fseeko(f,offset,whence);
 402 #else
 403  return fseek(f,offset,whence);
 404 #endif
 405 }
 406
 407 #undef PerlIO_rewind
 408 void
 409 PerlIO_rewind(PerlIO *f)
 410 {
 411  rewind(f);
 412 }
 413
 414 #undef PerlIO_printf
 415 int
 416 PerlIO_printf(PerlIO *f,const char *fmt,...)
 417 {
 418  va_list ap;
 419  int result;
 420  va_start(ap,fmt);
 421  result = vfprintf(f,fmt,ap);
 422  va_end(ap);
 423  return result;
 424 }
 425
 426 #undef PerlIO_stdoutf
 427 int
 428 PerlIO_stdoutf(const char *fmt,...)
 429 {
 430  va_list ap;
 431  int result;
 432  va_start(ap,fmt);
 433  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 434  va_end(ap);
 435  return result;
 436 }
 437
 438 #undef PerlIO_tmpfile
 439 PerlIO *
 440 PerlIO_tmpfile(void)
 441 {
 442  return tmpfile();
 443 }
 444
 445 #undef PerlIO_importFILE
 446 PerlIO *
 447 PerlIO_importFILE(FILE *f, int fl)
 448 {
 449  return f;
 450 }
 451
 452 #undef PerlIO_exportFILE
 453 FILE *
 454 PerlIO_exportFILE(PerlIO *f, int fl)
 455 {
 456  return f;
 457 }
 458
 459 #undef PerlIO_findFILE
 460 FILE *
 461 PerlIO_findFILE(PerlIO *f)
 462 {
 463  return f;
 464 }
 465
 466 #undef PerlIO_releaseFILE
 467 void
 468 PerlIO_releaseFILE(PerlIO *p, FILE *f)
 469 {
 470 }
 471
 472 void
 473 PerlIO_init(void)
 474 {
 475  /* Does nothing (yet) except force this file to be included
 476     in perl binary. That allows this file to force inclusion
 477     of other functions that may be required by loadable
 478     extensions e.g. for FileHandle::tmpfile
 479  */
 480 }
 481
 482 #endif /* USE_SFIO */
 483 #endif /* PERLIO_IS_STDIO */
 484
 485 #ifndef HAS_FSETPOS
 486 #undef PerlIO_setpos
 487 int
 488 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 489 {
 490  return PerlIO_seek(f,*pos,0);
 491 }
 492 #else
 493 #ifndef PERLIO_IS_STDIO
 494 #undef PerlIO_setpos
 495 int
 496 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 497 {
 498 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 499  return fsetpos64(f, pos);
 500 #else
 501  return fsetpos(f, pos);
 502 #endif
 503 }
 504 #endif
 505 #endif
 506
 507 #ifndef HAS_FGETPOS
 508 #undef PerlIO_getpos
 509 int
 510 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 511 {
 512  *pos = PerlIO_tell(f);
 513  return 0;
 514 }
 515 #else
 516 #ifndef PERLIO_IS_STDIO
 517 #undef PerlIO_getpos
 518 int
 519 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 520 {
 521 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 522  return fgetpos64(f, pos);
 523 #else
 524  return fgetpos(f, pos);
 525 #endif
 526 }
 527 #endif
 528 #endif
 529
 530 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 531
 532 int
 533 vprintf(char *pat, char *args)
 534 {
 535     _doprnt(pat, args, stdout);
 536     return 0;           /* wrong, but perl doesn't use the return value */
 537 }
 538
 539 int
 540 vfprintf(FILE *fd, char *pat, char *args)
 541 {
 542     _doprnt(pat, args, fd);
 543     return 0;           /* wrong, but perl doesn't use the return value */
 544 }
 545
 546 #endif
 547
 548 #ifndef PerlIO_vsprintf
 549 int
 550 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 551 {
 552  int val = vsprintf(s, fmt, ap);
 553  if (n >= 0)
 554   {
 555    if (strlen(s) >= (STRLEN)n)
 556     {
 557      dTHX;
 558      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
 559      my_exit(1);
 560     }
 561   }
 562  return val;
 563 }
 564 #endif
 565
 566 #ifndef PerlIO_sprintf
 567 int
 568 PerlIO_sprintf(char *s, int n, const char *fmt,...)
 569 {
 570  va_list ap;
 571  int result;
 572  va_start(ap,fmt);
 573  result = PerlIO_vsprintf(s, n, fmt, ap);
 574  va_end(ap);
 575  return result;
 576 }
 577 #endif
 578
 579 #endif /* !PERL_IMPLICIT_SYS */
 580