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  dTHX;
 147  if (cnt < -1 && ckWARN_d(WARN_INTERNAL))
 148   Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt);
 149 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
 150  FILE_cnt(f) = cnt;
 151 #else
 152  Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
 153 #endif
 154 }
 155
 156 #undef PerlIO_set_ptrcnt
 157 void
 158 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 159 {
 160 #ifdef FILE_bufsiz
 161  dTHX;
 162  STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
 163  int ec = e - ptr;
 164  if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL))
 165   Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1);
 166  if (cnt != ec && ckWARN_d(WARN_INTERNAL))
 167   Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec);
 168 #endif
 169 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
 170  FILE_ptr(f) = ptr;
 171 #else
 172  dTHX;
 173  Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system");
 174 #endif
 175 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
 176  FILE_cnt(f) = cnt;
 177 #else
 178  dTHX;
 179  Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system");
 180 #endif
 181 }
 182
 183 #undef PerlIO_get_cnt
 184 int
 185 PerlIO_get_cnt(PerlIO *f)
 186 {
 187 #ifdef FILE_cnt
 188  return FILE_cnt(f);
 189 #else
 190  dTHX;
 191  Perl_croak(aTHX_ "Cannot get 'cnt' of FILE * on this system");
 192  return -1;
 193 #endif
 194 }
 195
 196 #undef PerlIO_get_bufsiz
 197 int
 198 PerlIO_get_bufsiz(PerlIO *f)
 199 {
 200 #ifdef FILE_bufsiz
 201  return FILE_bufsiz(f);
 202 #else
 203  dTHX;
 204  Perl_croak(aTHX_ "Cannot get 'bufsiz' of FILE * on this system");
 205  return -1;
 206 #endif
 207 }
 208
 209 #undef PerlIO_get_ptr
 210 STDCHAR *
 211 PerlIO_get_ptr(PerlIO *f)
 212 {
 213 #ifdef FILE_ptr
 214  return FILE_ptr(f);
 215 #else
 216  dTHX;
 217  Perl_croak(aTHX_ "Cannot get 'ptr' of FILE * on this system");
 218  return NULL;
 219 #endif
 220 }
 221
 222 #undef PerlIO_get_base
 223 STDCHAR *
 224 PerlIO_get_base(PerlIO *f)
 225 {
 226 #ifdef FILE_base
 227  return FILE_base(f);
 228 #else
 229  dTHX;
 230  Perl_croak(aTHX_ "Cannot get 'base' of FILE * on this system");
 231  return NULL;
 232 #endif
 233 }
 234
 235 #undef PerlIO_has_base
 236 int
 237 PerlIO_has_base(PerlIO *f)
 238 {
 239 #ifdef FILE_base
 240  return 1;
 241 #else
 242  return 0;
 243 #endif
 244 }
 245
 246 #undef PerlIO_puts
 247 int
 248 PerlIO_puts(PerlIO *f, const char *s)
 249 {
 250  return fputs(s,f);
 251 }
 252
 253 #undef PerlIO_open
 254 PerlIO *
 255 PerlIO_open(const char *path, const char *mode)
 256 {
 257  return fopen(path,mode);
 258 }
 259
 260 #undef PerlIO_fdopen
 261 PerlIO *
 262 PerlIO_fdopen(int fd, const char *mode)
 263 {
 264  return fdopen(fd,mode);
 265 }
 266
 267 #undef PerlIO_reopen
 268 PerlIO *
 269 PerlIO_reopen(const char *name, const char *mode, PerlIO *f)
 270 {
 271  return freopen(name,mode,f);
 272 }
 273
 274 #undef PerlIO_close
 275 int
 276 PerlIO_close(PerlIO *f)
 277 {
 278  return fclose(f);
 279 }
 280
 281 #undef PerlIO_eof
 282 int
 283 PerlIO_eof(PerlIO *f)
 284 {
 285  return feof(f);
 286 }
 287
 288 #undef PerlIO_getname
 289 char *
 290 PerlIO_getname(PerlIO *f, char *buf)
 291 {
 292 #ifdef VMS
 293  return fgetname(f,buf);
 294 #else
 295  dTHX;
 296  Perl_croak(aTHX_ "Don't know how to get file name");
 297  return NULL;
 298 #endif
 299 }
 300
 301 #undef PerlIO_getc
 302 int
 303 PerlIO_getc(PerlIO *f)
 304 {
 305  return fgetc(f);
 306 }
 307
 308 #undef PerlIO_error
 309 int
 310 PerlIO_error(PerlIO *f)
 311 {
 312  return ferror(f);
 313 }
 314
 315 #undef PerlIO_clearerr
 316 void
 317 PerlIO_clearerr(PerlIO *f)
 318 {
 319  clearerr(f);
 320 }
 321
 322 #undef PerlIO_flush
 323 int
 324 PerlIO_flush(PerlIO *f)
 325 {
 326  return Fflush(f);
 327 }
 328
 329 #undef PerlIO_fileno
 330 int
 331 PerlIO_fileno(PerlIO *f)
 332 {
 333  return fileno(f);
 334 }
 335
 336 #undef PerlIO_setlinebuf
 337 void
 338 PerlIO_setlinebuf(PerlIO *f)
 339 {
 340 #ifdef HAS_SETLINEBUF
 341     setlinebuf(f);
 342 #else
 343 #  ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
 344     setvbuf(f, Nullch, _IOLBF, BUFSIZ);
 345 #  else
 346     setvbuf(f, Nullch, _IOLBF, 0);
 347 #  endif
 348 #endif
 349 }
 350
 351 #undef PerlIO_putc
 352 int
 353 PerlIO_putc(PerlIO *f, int ch)
 354 {
 355  return putc(ch,f);
 356 }
 357
 358 #undef PerlIO_ungetc
 359 int
 360 PerlIO_ungetc(PerlIO *f, int ch)
 361 {
 362  return ungetc(ch,f);
 363 }
 364
 365 #undef PerlIO_read
 366 SSize_t
 367 PerlIO_read(PerlIO *f, void *buf, Size_t count)
 368 {
 369  return fread(buf,1,count,f);
 370 }
 371
 372 #undef PerlIO_write
 373 SSize_t
 374 PerlIO_write(PerlIO *f, const void *buf, Size_t count)
 375 {
 376  return fwrite1(buf,1,count,f);
 377 }
 378
 379 #undef PerlIO_vprintf
 380 int
 381 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
 382 {
 383  return vfprintf(f,fmt,ap);
 384 }
 385
 386 #undef PerlIO_tell
 387 Off_t
 388 PerlIO_tell(PerlIO *f)
 389 {
 390 #ifdef HAS_FTELLO
 391  return ftello(f);
 392 #else
 393  return ftell(f);
 394 #endif
 395 }
 396
 397 #undef PerlIO_seek
 398 int
 399 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
 400 {
 401 #ifdef HAS_FSEEKO
 402  return fseeko(f,offset,whence);
 403 #else
 404  return fseek(f,offset,whence);
 405 #endif
 406 }
 407
 408 #undef PerlIO_rewind
 409 void
 410 PerlIO_rewind(PerlIO *f)
 411 {
 412  rewind(f);
 413 }
 414
 415 #undef PerlIO_printf
 416 int
 417 PerlIO_printf(PerlIO *f,const char *fmt,...)
 418 {
 419  va_list ap;
 420  int result;
 421  va_start(ap,fmt);
 422  result = vfprintf(f,fmt,ap);
 423  va_end(ap);
 424  return result;
 425 }
 426
 427 #undef PerlIO_stdoutf
 428 int
 429 PerlIO_stdoutf(const char *fmt,...)
 430 {
 431  va_list ap;
 432  int result;
 433  va_start(ap,fmt);
 434  result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
 435  va_end(ap);
 436  return result;
 437 }
 438
 439 #undef PerlIO_tmpfile
 440 PerlIO *
 441 PerlIO_tmpfile(void)
 442 {
 443  return tmpfile();
 444 }
 445
 446 #undef PerlIO_importFILE
 447 PerlIO *
 448 PerlIO_importFILE(FILE *f, int fl)
 449 {
 450  return f;
 451 }
 452
 453 #undef PerlIO_exportFILE
 454 FILE *
 455 PerlIO_exportFILE(PerlIO *f, int fl)
 456 {
 457  return f;
 458 }
 459
 460 #undef PerlIO_findFILE
 461 FILE *
 462 PerlIO_findFILE(PerlIO *f)
 463 {
 464  return f;
 465 }
 466
 467 #undef PerlIO_releaseFILE
 468 void
 469 PerlIO_releaseFILE(PerlIO *p, FILE *f)
 470 {
 471 }
 472
 473 void
 474 PerlIO_init(void)
 475 {
 476  /* Does nothing (yet) except force this file to be included
 477     in perl binary. That allows this file to force inclusion
 478     of other functions that may be required by loadable
 479     extensions e.g. for FileHandle::tmpfile
 480  */
 481 }
 482
 483 #endif /* USE_SFIO */
 484 #endif /* PERLIO_IS_STDIO */
 485
 486 #ifndef HAS_FSETPOS
 487 #undef PerlIO_setpos
 488 int
 489 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 490 {
 491  return PerlIO_seek(f,*pos,0);
 492 }
 493 #else
 494 #ifndef PERLIO_IS_STDIO
 495 #undef PerlIO_setpos
 496 int
 497 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
 498 {
 499  return fsetpos(f, pos);
 500 }
 501 #endif
 502 #endif
 503
 504 #ifndef HAS_FGETPOS
 505 #undef PerlIO_getpos
 506 int
 507 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 508 {
 509  *pos = PerlIO_tell(f);
 510  return 0;
 511 }
 512 #else
 513 #ifndef PERLIO_IS_STDIO
 514 #undef PerlIO_getpos
 515 int
 516 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 517 {
 518  return fgetpos(f, pos);
 519 }
 520 #endif
 521 #endif
 522
 523 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
 524
 525 int
 526 vprintf(char *pat, char *args)
 527 {
 528     _doprnt(pat, args, stdout);
 529     return 0;           /* wrong, but perl doesn't use the return value */
 530 }
 531
 532 int
 533 vfprintf(FILE *fd, char *pat, char *args)
 534 {
 535     _doprnt(pat, args, fd);
 536     return 0;           /* wrong, but perl doesn't use the return value */
 537 }
 538
 539 #endif
 540
 541 #ifndef PerlIO_vsprintf
 542 int
 543 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
 544 {
 545  int val = vsprintf(s, fmt, ap);
 546  if (n >= 0)
 547   {
 548    if (strlen(s) >= (STRLEN)n)
 549     {
 550      PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
 551      {
 552       dTHX;
 553       my_exit(1);
 554      }
 555     }
 556   }
 557  return val;
 558 }
 559 #endif
 560
 561 #ifndef PerlIO_sprintf
 562 int
 563 PerlIO_sprintf(char *s, int n, const char *fmt,...)
 564 {
 565  va_list ap;
 566  int result;
 567  va_start(ap,fmt);
 568  result = PerlIO_vsprintf(s, n, fmt, ap);
 569  va_end(ap);
 570  return result;
 571 }
 572 #endif
 573
 574 #endif /* !PERL_IMPLICIT_SYS */
 575