perlio.c

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