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
  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) && defined (STDIO_PTR_LVAL_NOCHANGE_CNT)
 176   FILE_cnt(f) = cnt;
 177 #else
 178 #if defined(STDIO_PTR_LVAL_SETS_CNT)
 179   assert (FILE_cnt(f) == cnt);
 180 #else
 181   Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system when setting 'ptr'");
 182 #endif
 183 #endif
 184 }
 185
 186 #undef PerlIO_get_cnt
 187 int
 188 PerlIO_get_cnt(PerlIO *f)
 189 {
 190 #ifdef FILE_cnt
 191  return FILE_cnt(f);
 192 #else
 193  dTHX;
 194  Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
 195  return -1;
 196 #endif
 197 }
 198
 199 #undef PerlIO_get_bufsiz
 200 int
 201 PerlIO_get_bufsiz(PerlIO *f)
 202 {
 203 #ifdef FILE_bufsiz
 204  return FILE_bufsiz(f);
 205 #else
 206  dTHX;
 207  Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
 208  return -1;
 209 #endif
 210 }
 211
 212 #undef PerlIO_get_ptr
 213 STDCHAR *
 214 PerlIO_get_ptr(PerlIO *f)
 215 {
 216 #ifdef FILE_ptr
 217  return FILE_ptr(f);
 218 #else
 219  dTHX;
 220  Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
 221  return NULL;
 222 #endif
 223 }
 224
 225 #undef PerlIO_get_base
 226 STDCHAR *
 227 PerlIO_get_base(PerlIO *f)
 228 {
 229 #ifdef FILE_base
 230  return FILE_base(f);
 231 #else
 232  dTHX;
 233  Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
 234  return NULL;
 235 #endif
 236 }
 237
 238 #undef PerlIO_has_base
 239 int
 240 PerlIO_has_base(PerlIO *f)
 241 {
 242 #ifdef FILE_base
 243  return 1;
 244 #else
 245  return 0;
 246 #endif
 247 }
 248
 249 #undef PerlIO_puts
 250 int
 251 PerlIO_puts(PerlIO *f, const char *s)
 252 {
 253  return fputs(s,f);
 254 }
 255
 256 #undef PerlIO_open
 257 PerlIO *
 258 PerlIO_open(const char *path, const char *mode)
 259 {
 260  return fopen(path,mode);
 261 }
 262
 263 #undef PerlIO_fdopen
 264 PerlIO *
 265 PerlIO_fdopen(int fd, const char *mode)
 266 {
 267  return fdopen(fd,mode);
 268 }
 269
 270 #undef PerlIO_reopen
 271 PerlIO *
 272 PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
 273 {
 274  return freopen(name,mode,f);
 275 }
 276
 277 #undef PerlIO_close
 278 int
 279 PerlIO_close(PerlIO *f)
 280 {
 281  return fclose(f);
 282 }
 283
 284 #undef PerlIO_eof
 285 int
 286 PerlIO_eof(PerlIO *f)
 287 {
 288  return feof(f);
 289 }
 290
 291 #undef PerlIO_getname
 292 char *
 293 PerlIO_getname(PerlIO *f, char *buf)
 294 {
 295 #ifdef VMS
 296  return fgetname(f,buf);
 297 #else
 298  dTHX;
 299  Perl_croak(aTHX_ "Don't know how to get file name");
 300  return NULL;
 301 #endif
 302 }
 303
 304 #undef PerlIO_getc
 305 int
 306 PerlIO_getc(PerlIO *f)
 307 {
 308  return fgetc(f);
 309 }
 310
 311 #undef PerlIO_error
 312 int
 313 PerlIO_error(PerlIO *f)
 314 {
 315  return ferror(f);
 316 }
 317
 318 #undef PerlIO_clearerr
 319 void
 320 PerlIO_clearerr(PerlIO *f)
 321 {
 322  clearerr(f);
 323 }
 324
 325 #undef PerlIO_flush
 326 int
 327 PerlIO_flush(PerlIO *f)
 328 {
 329  return Fflush(f);
 330 }
 331
 332 #undef PerlIO_fileno
 333 int
 334 PerlIO_fileno(PerlIO *f)
 335 {
 336  return fileno(f);
 337 }
 338
 339 #undef PerlIO_setlinebuf
 340 void
 341 PerlIO_setlinebuf(PerlIO *f)
 342 {
 343 #ifdef HAS_SETLINEBUF
 344     setlinebuf(f);
 345 #else
 346 #  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
 347     setvbuf(f, Nullch, _IOLBF, BUFSIZ);
 348 #  else
 349     setvbuf(f, Nullch, _IOLBF, 0);
 350 #  endif
 351 #endif
 352 }
 353
 354 #undef PerlIO_putc
 355 int
 356 PerlIO_putc(PerlIO *f, int ch)
 357 {
 358  return putc(ch,f);
 359 }
 360
 361 #undef PerlIO_ungetc
 362 int
 363 PerlIO_ungetc(PerlIO *f, int ch)
 364 {
 365  return ungetc(ch,f);
 366 }
 367
 368 #undef PerlIO_read
 369 SSize_t
 370 PerlIO_read(PerlIO *f, void *buf, Size_t count)
 371 {
 372  return fread(buf,1,count,f);
 373 }
 374
 375 #undef PerlIO_write
 376 SSize_t
 377 PerlIO_write(PerlIO *f, const void *buf, Size_t count)
 378 {
 379  return fwrite1(buf,1,count,f);
 380 }
 381
 382 #undef PerlIO_vprintf
 383 int
 384 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
 385 {
 386  return vfprintf(f,fmt,ap);
 387 }
 388
 389 #undef PerlIO_tell
 390 Off_t
 391 PerlIO_tell(PerlIO *f)
 392 {
 393 #if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
 394  return ftello(f);
 395 #else
 396  return ftell(f);
 397 #endif
 398 }
 399
 400 #undef PerlIO_seek
 401 int
 402 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 403 {
 404 #if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
 405  return fseeko(f,offset,whence);
 406 #else
 407  return fseek(f,offset,whence);
 408 #endif
 409 }
 410
 411 #undef PerlIO_rewind
 412 void
 413 PerlIO_rewind(PerlIO *f)
 414 {
 415  rewind(f);
 416 }
 417
 418 #undef PerlIO_printf
 419 int
 420 PerlIO_printf(PerlIO *f,const char *fmt,...)
 421 {
 422  va_list ap;
 423  int result;
 424  va_start(ap,fmt);
 425  result = vfprintf(f,fmt,ap);
 426  va_end(ap);
 427  return result;
 428 }
 429
 430 #undef PerlIO_stdoutf
 431 int
 432 PerlIO_stdoutf(const char *fmt,...)
 433 {
 434  va_list ap;
 435  int result;
 436  va_start(ap,fmt);
 437  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 438  va_end(ap);
 439  return result;
 440 }
 441
 442 #undef PerlIO_tmpfile
 443 PerlIO *
 444 PerlIO_tmpfile(void)
 445 {
 446  return tmpfile();
 447 }
 448
 449 #undef PerlIO_importFILE
 450 PerlIO *
 451 PerlIO_importFILE(FILE *f, int fl)
 452 {
 453  return f;
 454 }
 455
 456 #undef PerlIO_exportFILE
 457 FILE *
 458 PerlIO_exportFILE(PerlIO *f, int fl)
 459 {
 460  return f;
 461 }
 462
 463 #undef PerlIO_findFILE
 464 FILE *
 465 PerlIO_findFILE(PerlIO *f)
 466 {
 467  return f;
 468 }
 469
 470 #undef PerlIO_releaseFILE
 471 void
 472 PerlIO_releaseFILE(PerlIO *p, FILE *f)
 473 {
 474 }
 475
 476 void
 477 PerlIO_init(void)
 478 {
 479  /* Does nothing (yet) except force this file to be included
 480     in perl binary. That allows this file to force inclusion
 481     of other functions that may be required by loadable
 482     extensions e.g. for FileHandle::tmpfile
 483  */
 484 }
 485
 486 #endif /* USE_SFIO */
 487 #endif /* PERLIO_IS_STDIO */
 488
 489 #ifndef HAS_FSETPOS
 490 #undef PerlIO_setpos
 491 int
 492 #ifdef USE_SFIO
 493 PerlIO_setpos(PerlIO *f, const Off_t *pos)
 494 #else
 495 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 496 #endif
 497 {
 498  return PerlIO_seek(f,*pos,0);
 499 }
 500 #else
 501 #ifndef PERLIO_IS_STDIO
 502 #undef PerlIO_setpos
 503 int
 504 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 505 {
 506 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 507  return fsetpos64(f, pos);
 508 #else
 509  return fsetpos(f, pos);
 510 #endif
 511 }
 512 #endif
 513 #endif
 514
 515 #ifndef HAS_FGETPOS
 516 #undef PerlIO_getpos
 517 int
 518 #ifdef USE_SFIO
 519 PerlIO_getpos(PerlIO *f, Off_t *pos)
 520 {
 521  *pos = PerlIO_seek(f,0,0);
 522  return 0;
 523 }
 524 #else
 525 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 526 {
 527  *pos = PerlIO_tell(f);
 528  return 0;
 529 }
 530 #endif
 531 #else
 532 #ifndef PERLIO_IS_STDIO
 533 #undef PerlIO_getpos
 534 int
 535 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 536 {
 537 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
 538  return fgetpos64(f, pos);
 539 #else
 540  return fgetpos(f, pos);
 541 #endif
 542 }
 543 #endif
 544 #endif
 545
 546 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 547
 548 int
 549 vprintf(char *pat, char *args)
 550 {
 551     _doprnt(pat, args, stdout);
 552     return 0;           /* wrong, but perl doesn't use the return value */
 553 }
 554
 555 int
 556 vfprintf(FILE *fd, char *pat, char *args)
 557 {
 558     _doprnt(pat, args, fd);
 559     return 0;           /* wrong, but perl doesn't use the return value */
 560 }
 561
 562 #endif
 563
 564 #ifndef PerlIO_vsprintf
 565 int
 566 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 567 {
 568  int val = vsprintf(s, fmt, ap);
 569  if (n >= 0)
 570   {
 571    if (strlen(s) >= (STRLEN)n)
 572     {
 573      dTHX;
 574      PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
 575      my_exit(1);
 576     }
 577   }
 578  return val;
 579 }
 580 #endif
 581
 582 #ifndef PerlIO_sprintf
 583 int
 584 PerlIO_sprintf(char *s, int n, const char *fmt,...)
 585 {
 586  va_list ap;
 587  int result;
 588  va_start(ap,fmt);
 589  result = PerlIO_vsprintf(s, n, fmt, ap);
 590  va_end(ap);
 591  return result;
 592 }
 593 #endif
 594
 595 #endif /* !PERL_IMPLICIT_SYS */
 596