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