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