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