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