1 /* perlio.c 2 * 3 * Copyright (c) 1996-2001, 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 #include "config.h" 13 14 #define PERLIO_NOT_STDIO 0 15 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) 16 #define PerlIO FILE 17 #endif 18 /* 19 * This file provides those parts of PerlIO abstraction 20 * which are not #defined in iperlsys.h. 21 * Which these are depends on various Configure #ifdef's 22 */ 23 24 #include "EXTERN.h" 25 #define PERL_IN_PERLIO_C 26 #include "perl.h" 27 28 #if !defined(PERL_IMPLICIT_SYS) 29 30 #ifdef PERLIO_IS_STDIO 31 32 void 33 PerlIO_init(void) 34 { 35 /* Does nothing (yet) except force this file to be included 36 in perl binary. That allows this file to force inclusion 37 of other functions that may be required by loadable 38 extensions e.g. for FileHandle::tmpfile 39 */ 40 } 41 42 #undef PerlIO_tmpfile 43 PerlIO * 44 PerlIO_tmpfile(void) 45 { 46 return tmpfile(); 47 } 48 49 #else /* PERLIO_IS_STDIO */ 50 51 #ifdef USE_SFIO 52 53 #undef HAS_FSETPOS 54 #undef HAS_FGETPOS 55 56 /* This section is just to make sure these functions 57 get pulled in from libsfio.a 58 */ 59 60 #undef PerlIO_tmpfile 61 PerlIO * 62 PerlIO_tmpfile(void) 63 { 64 return sftmp(0); 65 } 66 67 void 68 PerlIO_init(void) 69 { 70 /* Force this file to be included in perl binary. Which allows 71 * this file to force inclusion of other functions that may be 72 * required by loadable extensions e.g. for FileHandle::tmpfile 73 */ 74 75 /* Hack 76 * sfio does its own 'autoflush' on stdout in common cases. 77 * Flush results in a lot of lseek()s to regular files and 78 * lot of small writes to pipes. 79 */ 80 sfset(sfstdout,SF_SHARE,0); 81 } 82 83 #else /* USE_SFIO */ 84 85 /* Implement all the PerlIO interface using stdio. 86 - this should be only file to include <stdio.h> 87 */ 88 89 #undef PerlIO_stderr 90 PerlIO * 91 PerlIO_stderr(void) 92 { 93 return (PerlIO *) stderr; 94 } 95 96 #undef PerlIO_stdin 97 PerlIO * 98 PerlIO_stdin(void) 99 { 100 return (PerlIO *) stdin; 101 } 102 103 #undef PerlIO_stdout 104 PerlIO * 105 PerlIO_stdout(void) 106 { 107 return (PerlIO *) stdout; 108 } 109 110 #undef PerlIO_fast_gets 111 int 112 PerlIO_fast_gets(PerlIO *f) 113 { 114 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) 115 return 1; 116 #else 117 return 0; 118 #endif 119 } 120 121 #undef PerlIO_has_cntptr 122 int 123 PerlIO_has_cntptr(PerlIO *f) 124 { 125 #if defined(USE_STDIO_PTR) 126 return 1; 127 #else 128 return 0; 129 #endif 130 } 131 132 #undef PerlIO_canset_cnt 133 int 134 PerlIO_canset_cnt(PerlIO *f) 135 { 136 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) 137 return 1; 138 #else 139 return 0; 140 #endif 141 } 142 143 #undef PerlIO_set_cnt 144 void 145 PerlIO_set_cnt(PerlIO *f, int cnt) 146 { 147 dTHX; 148 if (cnt < -1 && ckWARN_d(WARN_INTERNAL)) 149 Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); 150 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) 151 FILE_cnt(f) = cnt; 152 #else 153 Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system"); 154 #endif 155 } 156 157 #undef PerlIO_set_ptrcnt 158 void 159 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) 160 { 161 dTHX; 162 #ifdef FILE_bufsiz 163 STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); 164 int ec = e - ptr; 165 if (ptr > e + 1 && ckWARN_d(WARN_INTERNAL)) 166 Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1); 167 if (cnt != ec && ckWARN_d(WARN_INTERNAL)) 168 Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec); 169 #endif 170 #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) 171 FILE_ptr(f) = ptr; 172 #else 173 Perl_croak(aTHX_ "Cannot set 'ptr' of FILE * on this system"); 174 #endif 175 #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) && defined (STDIO_PTR_LVAL_NOCHANGE_CNT) 176 FILE_cnt(f) = cnt; 177 #else 178 #if defined(STDIO_PTR_LVAL_SETS_CNT) 179 assert (FILE_cnt(f) == cnt); 180 #else 181 Perl_croak(aTHX_ "Cannot set 'cnt' of FILE * on this system when setting 'ptr'"); 182 #endif 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 #ifdef USE_SFIO 493 PerlIO_setpos(PerlIO *f, const Off_t *pos) 494 #else 495 PerlIO_setpos(PerlIO *f, const Fpos_t *pos) 496 #endif 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 #ifdef USE_SFIO 519 PerlIO_getpos(PerlIO *f, Off_t *pos) 520 { 521 *pos = PerlIO_seek(f,0,0); 522 return 0; 523 } 524 #else 525 PerlIO_getpos(PerlIO *f, Fpos_t *pos) 526 { 527 *pos = PerlIO_tell(f); 528 return 0; 529 } 530 #endif 531 #else 532 #ifndef PERLIO_IS_STDIO 533 #undef PerlIO_getpos 534 int 535 PerlIO_getpos(PerlIO *f, Fpos_t *pos) 536 { 537 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 538 return fgetpos64(f, pos); 539 #else 540 return fgetpos(f, pos); 541 #endif 542 } 543 #endif 544 #endif 545 546 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) 547 548 int 549 vprintf(char *pat, char *args) 550 { 551 _doprnt(pat, args, stdout); 552 return 0; /* wrong, but perl doesn't use the return value */ 553 } 554 555 int 556 vfprintf(FILE *fd, char *pat, char *args) 557 { 558 _doprnt(pat, args, fd); 559 return 0; /* wrong, but perl doesn't use the return value */ 560 } 561 562 #endif 563 564 #ifndef PerlIO_vsprintf 565 int 566 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) 567 { 568 int val = vsprintf(s, fmt, ap); 569 if (n >= 0) 570 { 571 if (strlen(s) >= (STRLEN)n) 572 { 573 dTHX; 574 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n"); 575 my_exit(1); 576 } 577 } 578 return val; 579 } 580 #endif 581 582 #ifndef PerlIO_sprintf 583 int 584 PerlIO_sprintf(char *s, int n, const char *fmt,...) 585 { 586 va_list ap; 587 int result; 588 va_start(ap,fmt); 589 result = PerlIO_vsprintf(s, n, fmt, ap); 590 va_end(ap); 591 return result; 592 } 593 #endif 594 595 #endif /* !PERL_IMPLICIT_SYS */ 596 597