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