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