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