perlio.c

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