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(void)
  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(void)
  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 < -1)
 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 STDCHAR *ptr;
 162 int cnt;
 163 {
 164 #ifdef FILE_bufsiz
 165  STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
 166  int ec = e - ptr;
 167  if (ptr > e + 1)
 168   warn("Setting ptr %p > end+1 %p\n", ptr, e + 1);
 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) = 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 STDCHAR *
 212 PerlIO_get_ptr(f)
 213 PerlIO *f;
 214 {
 215 #ifdef FILE_ptr
 216  return 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 STDCHAR *
 225 PerlIO_get_base(f)
 226 PerlIO *f;
 227 {
 228 #ifdef FILE_base
 229  return 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 #undef PerlIO_reopen
 276 PerlIO *
 277 PerlIO_reopen(name, mode, f)
 278 const char *name;
 279 const char *mode;
 280 PerlIO *f;
 281 {
 282  return freopen(name,mode,f);
 283 }
 284
 285 #undef PerlIO_close
 286 int
 287 PerlIO_close(f)
 288 PerlIO *f;
 289 {
 290  return fclose(f);
 291 }
 292
 293 #undef PerlIO_eof
 294 int
 295 PerlIO_eof(f)
 296 PerlIO *f;
 297 {
 298  return feof(f);
 299 }
 300
 301 #undef PerlIO_getname
 302 char *
 303 PerlIO_getname(f,buf)
 304 PerlIO *f;
 305 char *buf;
 306 {
 307 #ifdef VMS
 308  return fgetname(f,buf);
 309 #else
 310  croak("Don't know how to get file name");
 311  return NULL;
 312 #endif
 313 }
 314
 315 #undef PerlIO_getc
 316 int
 317 PerlIO_getc(f)
 318 PerlIO *f;
 319 {
 320  return fgetc(f);
 321 }
 322
 323 #undef PerlIO_error
 324 int
 325 PerlIO_error(f)
 326 PerlIO *f;
 327 {
 328  return ferror(f);
 329 }
 330
 331 #undef PerlIO_clearerr
 332 void
 333 PerlIO_clearerr(f)
 334 PerlIO *f;
 335 {
 336  clearerr(f);
 337 }
 338
 339 #undef PerlIO_flush
 340 int
 341 PerlIO_flush(f)
 342 PerlIO *f;
 343 {
 344  return Fflush(f);
 345 }
 346
 347 #undef PerlIO_fileno
 348 int
 349 PerlIO_fileno(f)
 350 PerlIO *f;
 351 {
 352  return fileno(f);
 353 }
 354
 355 #undef PerlIO_setlinebuf
 356 void
 357 PerlIO_setlinebuf(f)
 358 PerlIO *f;
 359 {
 360 #ifdef HAS_SETLINEBUF
 361     setlinebuf(f);
 362 #else
 363 #  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
 364     setvbuf(f, Nullch, _IOLBF, BUFSIZ);
 365 #  else
 366     setvbuf(f, Nullch, _IOLBF, 0);
 367 #  endif
 368 #endif
 369 }
 370
 371 #undef PerlIO_putc
 372 int
 373 PerlIO_putc(f,ch)
 374 PerlIO *f;
 375 int ch;
 376 {
 377  return putc(ch,f);
 378 }
 379
 380 #undef PerlIO_ungetc
 381 int
 382 PerlIO_ungetc(f,ch)
 383 PerlIO *f;
 384 int ch;
 385 {
 386  return ungetc(ch,f);
 387 }
 388
 389 #undef PerlIO_read
 390 SSize_t
 391 PerlIO_read(f,buf,count)
 392 PerlIO *f;
 393 void *buf;
 394 Size_t count;
 395 {
 396  return fread(buf,1,count,f);
 397 }
 398
 399 #undef PerlIO_write
 400 SSize_t
 401 PerlIO_write(f,buf,count)
 402 PerlIO *f;
 403 const void *buf;
 404 Size_t count;
 405 {
 406  return fwrite1(buf,1,count,f);
 407 }
 408
 409 #undef PerlIO_vprintf
 410 int
 411 PerlIO_vprintf(f,fmt,ap)
 412 PerlIO *f;
 413 const char *fmt;
 414 va_list ap;
 415 {
 416  return vfprintf(f,fmt,ap);
 417 }
 418
 419
 420 #undef PerlIO_tell
 421 long
 422 PerlIO_tell(f)
 423 PerlIO *f;
 424 {
 425  return ftell(f);
 426 }
 427
 428 #undef PerlIO_seek
 429 int
 430 PerlIO_seek(f,offset,whence)
 431 PerlIO *f;
 432 off_t offset;
 433 int whence;
 434 {
 435  return fseek(f,offset,whence);
 436 }
 437
 438 #undef PerlIO_rewind
 439 void
 440 PerlIO_rewind(f)
 441 PerlIO *f;
 442 {
 443  rewind(f);
 444 }
 445
 446 #undef PerlIO_printf
 447 int
 448 #ifdef I_STDARG
 449 PerlIO_printf(PerlIO *f,const char *fmt,...)
 450 #else
 451 PerlIO_printf(f,fmt,va_alist)
 452 PerlIO *f;
 453 const char *fmt;
 454 va_dcl
 455 #endif
 456 {
 457  va_list ap;
 458  int result;
 459 #ifdef I_STDARG
 460  va_start(ap,fmt);
 461 #else
 462  va_start(ap);
 463 #endif
 464  result = vfprintf(f,fmt,ap);
 465  va_end(ap);
 466  return result;
 467 }
 468
 469 #undef PerlIO_stdoutf
 470 int
 471 #ifdef I_STDARG
 472 PerlIO_stdoutf(const char *fmt,...)
 473 #else
 474 PerlIO_stdoutf(fmt, va_alist)
 475 const char *fmt;
 476 va_dcl
 477 #endif
 478 {
 479  va_list ap;
 480  int result;
 481 #ifdef I_STDARG
 482  va_start(ap,fmt);
 483 #else
 484  va_start(ap);
 485 #endif
 486  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 487  va_end(ap);
 488  return result;
 489 }
 490
 491 #undef PerlIO_tmpfile
 492 PerlIO *
 493 PerlIO_tmpfile()
 494 {
 495  return tmpfile();
 496 }
 497
 498 #undef PerlIO_importFILE
 499 PerlIO *
 500 PerlIO_importFILE(f,fl)
 501 FILE *f;
 502 int fl;
 503 {
 504  return f;
 505 }
 506
 507 #undef PerlIO_exportFILE
 508 FILE *
 509 PerlIO_exportFILE(f,fl)
 510 PerlIO *f;
 511 int fl;
 512 {
 513  return f;
 514 }
 515
 516 #undef PerlIO_findFILE
 517 FILE *
 518 PerlIO_findFILE(f)
 519 PerlIO *f;
 520 {
 521  return f;
 522 }
 523
 524 #undef PerlIO_releaseFILE
 525 void
 526 PerlIO_releaseFILE(p,f)
 527 PerlIO *p;
 528 FILE *f;
 529 {
 530 }
 531
 532 void
 533 PerlIO_init()
 534 {
 535  /* Does nothing (yet) except force this file to be included
 536     in perl binary. That allows this file to force inclusion
 537     of other functions that may be required by loadable
 538     extensions e.g. for FileHandle::tmpfile
 539  */
 540 }
 541
 542 #endif /* USE_SFIO */
 543 #endif /* PERLIO_IS_STDIO */
 544
 545 #ifndef HAS_FSETPOS
 546 #undef PerlIO_setpos
 547 int
 548 PerlIO_setpos(f,pos)
 549 PerlIO *f;
 550 const Fpos_t *pos;
 551 {
 552  return PerlIO_seek(f,*pos,0);
 553 }
 554 #else
 555 #ifndef PERLIO_IS_STDIO
 556 #undef PerlIO_setpos
 557 int
 558 PerlIO_setpos(f,pos)
 559 PerlIO *f;
 560 const Fpos_t *pos;
 561 {
 562  return fsetpos(f, pos);
 563 }
 564 #endif
 565 #endif
 566
 567 #ifndef HAS_FGETPOS
 568 #undef PerlIO_getpos
 569 int
 570 PerlIO_getpos(f,pos)
 571 PerlIO *f;
 572 Fpos_t *pos;
 573 {
 574  *pos = PerlIO_tell(f);
 575  return 0;
 576 }
 577 #else
 578 #ifndef PERLIO_IS_STDIO
 579 #undef PerlIO_getpos
 580 int
 581 PerlIO_getpos(f,pos)
 582 PerlIO *f;
 583 Fpos_t *pos;
 584 {
 585  return fgetpos(f, pos);
 586 }
 587 #endif
 588 #endif
 589
 590 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 591
 592 int
 593 vprintf(pat, args)
 594 char *pat, *args;
 595 {
 596     _doprnt(pat, args, stdout);
 597     return 0;           /* wrong, but perl doesn't use the return value */
 598 }
 599
 600 int
 601 vfprintf(fd, pat, args)
 602 FILE *fd;
 603 char *pat, *args;
 604 {
 605     _doprnt(pat, args, fd);
 606     return 0;           /* wrong, but perl doesn't use the return value */
 607 }
 608
 609 #endif
 610
 611 #ifndef PerlIO_vsprintf
 612 int
 613 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 614 {
 615  int val = vsprintf(s, fmt, ap);
 616  if (n >= 0)
 617   {
 618    if (strlen(s) >= (STRLEN)n)
 619     {
 620      PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
 621      my_exit(1);
 622     }
 623   }
 624  return val;
 625 }
 626 #endif
 627
 628 #ifndef PerlIO_sprintf
 629 int
 630 #ifdef I_STDARG
 631 PerlIO_sprintf(char *s, int n, const char *fmt,...)
 632 #else
 633 PerlIO_sprintf(s, n, fmt, va_alist)
 634 char *s;
 635 int n;
 636 const char *fmt;
 637 va_dcl
 638 #endif
 639 {
 640  va_list ap;
 641  int result;
 642 #ifdef I_STDARG
 643  va_start(ap,fmt);
 644 #else
 645  va_start(ap);
 646 #endif
 647  result = PerlIO_vsprintf(s, n, fmt, ap);
 648  va_end(ap);
 649  return result;
 650 }
 651 #endif
 652