1 /* 2 * perlio.c Copyright (c) 1996-2002, Nick Ing-Simmons You may distribute 3 * under the terms of either the GNU General Public License or the 4 * Artistic License, as specified in the README file. 5 */ 6 7 /* 8 * Hour after hour for nearly three weary days he had jogged up and down, 9 * over passes, and through long dales, and across many streams. 10 */ 11 12 /* 13 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get 14 * at the dispatch tables, even when we do not need it for other reasons. 15 * Invent a dSYS macro to abstract this out 16 */ 17 #ifdef PERL_IMPLICIT_SYS 18 #define dSYS dTHX 19 #else 20 #define dSYS dNOOP 21 #endif 22 23 #define VOIDUSED 1 24 #ifdef PERL_MICRO 25 # include "uconfig.h" 26 #else 27 # include "config.h" 28 #endif 29 30 #define PERLIO_NOT_STDIO 0 31 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) 32 /* 33 * #define PerlIO FILE 34 */ 35 #endif 36 /* 37 * This file provides those parts of PerlIO abstraction 38 * which are not #defined in perlio.h. 39 * Which these are depends on various Configure #ifdef's 40 */ 41 42 #include "EXTERN.h" 43 #define PERL_IN_PERLIO_C 44 #include "perl.h" 45 46 #ifdef PERL_IMPLICIT_CONTEXT 47 #undef dSYS 48 #define dSYS dTHX 49 #endif 50 51 #include "XSUB.h" 52 53 int 54 perlsio_binmode(FILE *fp, int iotype, int mode) 55 { 56 /* 57 * This used to be contents of do_binmode in doio.c 58 */ 59 #ifdef DOSISH 60 # if defined(atarist) || defined(__MINT__) 61 if (!fflush(fp)) { 62 if (mode & O_BINARY) 63 ((FILE *) fp)->_flag |= _IOBIN; 64 else 65 ((FILE *) fp)->_flag &= ~_IOBIN; 66 return 1; 67 } 68 return 0; 69 # else 70 dTHX; 71 #ifdef NETWARE 72 if (PerlLIO_setmode(fp, mode) != -1) { 73 #else 74 if (PerlLIO_setmode(fileno(fp), mode) != -1) { 75 #endif 76 # if defined(WIN32) && defined(__BORLANDC__) 77 /* 78 * The translation mode of the stream is maintained independent of 79 * the translation mode of the fd in the Borland RTL (heavy 80 * digging through their runtime sources reveal). User has to set 81 * the mode explicitly for the stream (though they don't document 82 * this anywhere). GSAR 97-5-24 83 */ 84 fseek(fp, 0L, 0); 85 if (mode & O_BINARY) 86 fp->flags |= _F_BIN; 87 else 88 fp->flags &= ~_F_BIN; 89 # endif 90 return 1; 91 } 92 else 93 return 0; 94 # endif 95 #else 96 # if defined(USEMYBINMODE) 97 dTHX; 98 if (my_binmode(fp, iotype, mode) != FALSE) 99 return 1; 100 else 101 return 0; 102 # else 103 return 1; 104 # endif 105 #endif 106 } 107 108 #ifndef O_ACCMODE 109 #define O_ACCMODE 3 /* Assume traditional implementation */ 110 #endif 111 112 int 113 PerlIO_intmode2str(int rawmode, char *mode, int *writing) 114 { 115 int result = rawmode & O_ACCMODE; 116 int ix = 0; 117 int ptype; 118 switch (result) { 119 case O_RDONLY: 120 ptype = IoTYPE_RDONLY; 121 break; 122 case O_WRONLY: 123 ptype = IoTYPE_WRONLY; 124 break; 125 case O_RDWR: 126 default: 127 ptype = IoTYPE_RDWR; 128 break; 129 } 130 if (writing) 131 *writing = (result != O_RDONLY); 132 133 if (result == O_RDONLY) { 134 mode[ix++] = 'r'; 135 } 136 #ifdef O_APPEND 137 else if (rawmode & O_APPEND) { 138 mode[ix++] = 'a'; 139 if (result != O_WRONLY) 140 mode[ix++] = '+'; 141 } 142 #endif 143 else { 144 if (result == O_WRONLY) 145 mode[ix++] = 'w'; 146 else { 147 mode[ix++] = 'r'; 148 mode[ix++] = '+'; 149 } 150 } 151 if (rawmode & O_BINARY) 152 mode[ix++] = 'b'; 153 mode[ix] = '\0'; 154 return ptype; 155 } 156 157 #ifndef PERLIO_LAYERS 158 int 159 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 160 { 161 if (!names || !*names 162 || strEQ(names, ":crlf") 163 || strEQ(names, ":raw") 164 || strEQ(names, ":bytes") 165 ) { 166 return 0; 167 } 168 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); 169 /* 170 * NOTREACHED 171 */ 172 return -1; 173 } 174 175 void 176 PerlIO_destruct(pTHX) 177 { 178 } 179 180 int 181 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) 182 { 183 #ifdef USE_SFIO 184 return 1; 185 #else 186 return perlsio_binmode(fp, iotype, mode); 187 #endif 188 } 189 190 PerlIO * 191 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 192 { 193 #ifdef PERL_MICRO 194 return NULL; 195 #else 196 #ifdef PERL_IMPLICIT_SYS 197 return PerlSIO_fdupopen(f); 198 #else 199 #ifdef WIN32 200 return win32_fdupopen(f); 201 #else 202 if (f) { 203 int fd = PerlLIO_dup(PerlIO_fileno(f)); 204 if (fd >= 0) { 205 char mode[8]; 206 int omode = fcntl(fd, F_GETFL); 207 #ifdef DJGPP 208 omode = djgpp_get_stream_mode(f); 209 #endif 210 PerlIO_intmode2str(omode,mode,NULL); 211 /* the r+ is a hack */ 212 return PerlIO_fdopen(fd, mode); 213 } 214 return NULL; 215 } 216 else { 217 SETERRNO(EBADF, SS$_IVCHAN); 218 } 219 #endif 220 return NULL; 221 #endif 222 #endif 223 } 224 225 226 /* 227 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries 228 */ 229 230 PerlIO * 231 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 232 int imode, int perm, PerlIO *old, int narg, SV **args) 233 { 234 if (narg) { 235 if (narg > 1) { 236 Perl_croak(aTHX_ "More than one argument to open"); 237 } 238 if (*args == &PL_sv_undef) 239 return PerlIO_tmpfile(); 240 else { 241 char *name = SvPV_nolen(*args); 242 if (*mode == '#') { 243 fd = PerlLIO_open3(name, imode, perm); 244 if (fd >= 0) 245 return PerlIO_fdopen(fd, (char *) mode + 1); 246 } 247 else if (old) { 248 return PerlIO_reopen(name, mode, old); 249 } 250 else { 251 return PerlIO_open(name, mode); 252 } 253 } 254 } 255 else { 256 return PerlIO_fdopen(fd, (char *) mode); 257 } 258 return NULL; 259 } 260 261 XS(XS_PerlIO__Layer__find) 262 { 263 dXSARGS; 264 if (items < 2) 265 Perl_croak(aTHX_ "Usage class->find(name[,load])"); 266 else { 267 char *name = SvPV_nolen(ST(1)); 268 ST(0) = (strEQ(name, "crlf") 269 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; 270 XSRETURN(1); 271 } 272 } 273 274 275 void 276 Perl_boot_core_PerlIO(pTHX) 277 { 278 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 279 } 280 281 #endif 282 283 284 #ifdef PERLIO_IS_STDIO 285 286 void 287 PerlIO_init(pTHX) 288 { 289 /* 290 * Does nothing (yet) except force this file to be included in perl 291 * binary. That allows this file to force inclusion of other functions 292 * that may be required by loadable extensions e.g. for 293 * FileHandle::tmpfile 294 */ 295 } 296 297 #undef PerlIO_tmpfile 298 PerlIO * 299 PerlIO_tmpfile(void) 300 { 301 return tmpfile(); 302 } 303 304 #else /* PERLIO_IS_STDIO */ 305 306 #ifdef USE_SFIO 307 308 #undef HAS_FSETPOS 309 #undef HAS_FGETPOS 310 311 /* 312 * This section is just to make sure these functions get pulled in from 313 * libsfio.a 314 */ 315 316 #undef PerlIO_tmpfile 317 PerlIO * 318 PerlIO_tmpfile(void) 319 { 320 return sftmp(0); 321 } 322 323 void 324 PerlIO_init(pTHX) 325 { 326 /* 327 * Force this file to be included in perl binary. Which allows this 328 * file to force inclusion of other functions that may be required by 329 * loadable extensions e.g. for FileHandle::tmpfile 330 */ 331 332 /* 333 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush 334 * results in a lot of lseek()s to regular files and lot of small 335 * writes to pipes. 336 */ 337 sfset(sfstdout, SF_SHARE, 0); 338 } 339 340 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */ 341 PerlIO * 342 PerlIO_importFILE(FILE *stdio, const char *mode) 343 { 344 int fd = fileno(stdio); 345 if (!mode || !*mode) { 346 mode = "r+"; 347 } 348 return PerlIO_fdopen(fd, mode); 349 } 350 351 FILE * 352 PerlIO_findFILE(PerlIO *pio) 353 { 354 int fd = PerlIO_fileno(pio); 355 FILE *f = fdopen(fd, "r+"); 356 PerlIO_flush(pio); 357 if (!f && errno == EINVAL) 358 f = fdopen(fd, "w"); 359 if (!f && errno == EINVAL) 360 f = fdopen(fd, "r"); 361 return f; 362 } 363 364 365 #else /* USE_SFIO */ 366 /*======================================================================================*/ 367 /* 368 * Implement all the PerlIO interface ourselves. 369 */ 370 371 #include "perliol.h" 372 373 /* 374 * We _MUST_ have <unistd.h> if we are using lseek() and may have large 375 * files 376 */ 377 #ifdef I_UNISTD 378 #include <unistd.h> 379 #endif 380 #ifdef HAS_MMAP 381 #include <sys/mman.h> 382 #endif 383 384 385 void PerlIO_debug(const char *fmt, ...) 386 __attribute__ ((format(__printf__, 1, 2))); 387 388 void 389 PerlIO_debug(const char *fmt, ...) 390 { 391 static int dbg = 0; 392 va_list ap; 393 dSYS; 394 va_start(ap, fmt); 395 if (!dbg) { 396 char *s = PerlEnv_getenv("PERLIO_DEBUG"); 397 if (s && *s) 398 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); 399 else 400 dbg = -1; 401 } 402 if (dbg > 0) { 403 dTHX; 404 #ifdef USE_ITHREADS 405 /* Use fixed buffer as sv_catpvf etc. needs SVs */ 406 char buffer[1024]; 407 char *s; 408 STRLEN len; 409 s = CopFILE(PL_curcop); 410 if (!s) 411 s = "(none)"; 412 sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); 413 len = strlen(buffer); 414 vsprintf(buffer+len, fmt, ap); 415 PerlLIO_write(dbg, buffer, strlen(buffer)); 416 #else 417 SV *sv = newSVpvn("", 0); 418 char *s; 419 STRLEN len; 420 s = CopFILE(PL_curcop); 421 if (!s) 422 s = "(none)"; 423 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s, 424 (IV) CopLINE(PL_curcop)); 425 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); 426 427 s = SvPV(sv, len); 428 PerlLIO_write(dbg, s, len); 429 SvREFCNT_dec(sv); 430 #endif 431 } 432 va_end(ap); 433 } 434 435 /*--------------------------------------------------------------------------------------*/ 436 437 /* 438 * Inner level routines 439 */ 440 441 /* 442 * Table of pointers to the PerlIO structs (malloc'ed) 443 */ 444 #define PERLIO_TABLE_SIZE 64 445 446 PerlIO * 447 PerlIO_allocate(pTHX) 448 { 449 /* 450 * Find a free slot in the table, allocating new table as necessary 451 */ 452 PerlIO **last; 453 PerlIO *f; 454 last = &PL_perlio; 455 while ((f = *last)) { 456 int i; 457 last = (PerlIO **) (f); 458 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 459 if (!*++f) { 460 return f; 461 } 462 } 463 } 464 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO); 465 if (!f) { 466 return NULL; 467 } 468 *last = f; 469 return f + 1; 470 } 471 472 #undef PerlIO_fdupopen 473 PerlIO * 474 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) 475 { 476 if (PerlIOValid(f)) { 477 PerlIO_funcs *tab = PerlIOBase(f)->tab; 478 PerlIO *new; 479 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param); 480 new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags); 481 return new; 482 } 483 else { 484 SETERRNO(EBADF, SS$_IVCHAN); 485 return NULL; 486 } 487 } 488 489 void 490 PerlIO_cleantable(pTHX_ PerlIO **tablep) 491 { 492 PerlIO *table = *tablep; 493 if (table) { 494 int i; 495 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0])); 496 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { 497 PerlIO *f = table + i; 498 if (*f) { 499 PerlIO_close(f); 500 } 501 } 502 Safefree(table); 503 *tablep = NULL; 504 } 505 } 506 507 508 PerlIO_list_t * 509 PerlIO_list_alloc(pTHX) 510 { 511 PerlIO_list_t *list; 512 Newz('L', list, 1, PerlIO_list_t); 513 list->refcnt = 1; 514 return list; 515 } 516 517 void 518 PerlIO_list_free(pTHX_ PerlIO_list_t *list) 519 { 520 if (list) { 521 if (--list->refcnt == 0) { 522 if (list->array) { 523 IV i; 524 for (i = 0; i < list->cur; i++) { 525 if (list->array[i].arg) 526 SvREFCNT_dec(list->array[i].arg); 527 } 528 Safefree(list->array); 529 } 530 Safefree(list); 531 } 532 } 533 } 534 535 void 536 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) 537 { 538 PerlIO_pair_t *p; 539 if (list->cur >= list->len) { 540 list->len += 8; 541 if (list->array) 542 Renew(list->array, list->len, PerlIO_pair_t); 543 else 544 New('l', list->array, list->len, PerlIO_pair_t); 545 } 546 p = &(list->array[list->cur++]); 547 p->funcs = funcs; 548 if ((p->arg = arg)) { 549 SvREFCNT_inc(arg); 550 } 551 } 552 553 PerlIO_list_t * 554 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) 555 { 556 PerlIO_list_t *list = (PerlIO_list_t *) NULL; 557 if (proto) { 558 int i; 559 list = PerlIO_list_alloc(aTHX); 560 for (i=0; i < proto->cur; i++) { 561 SV *arg = Nullsv; 562 if (proto->array[i].arg) 563 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param); 564 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); 565 } 566 } 567 return list; 568 } 569 570 void 571 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) 572 { 573 #ifdef USE_ITHREADS 574 PerlIO **table = &proto->Iperlio; 575 PerlIO *f; 576 PL_perlio = NULL; 577 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); 578 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); 579 PerlIO_allocate(aTHX); /* root slot is never used */ 580 PerlIO_debug("Clone %p from %p\n",aTHX,proto); 581 while ((f = *table)) { 582 int i; 583 table = (PerlIO **) (f++); 584 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 585 if (*f) { 586 (void) fp_dup(f, 0, param); 587 } 588 f++; 589 } 590 } 591 #endif 592 } 593 594 void 595 PerlIO_destruct(pTHX) 596 { 597 PerlIO **table = &PL_perlio; 598 PerlIO *f; 599 #ifdef USE_ITHREADS 600 PerlIO_debug("Destruct %p\n",aTHX); 601 #endif 602 while ((f = *table)) { 603 int i; 604 table = (PerlIO **) (f++); 605 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 606 PerlIO *x = f; 607 PerlIOl *l; 608 while ((l = *x)) { 609 if (l->tab->kind & PERLIO_K_DESTRUCT) { 610 PerlIO_debug("Destruct popping %s\n", l->tab->name); 611 PerlIO_flush(x); 612 PerlIO_pop(aTHX_ x); 613 } 614 else { 615 x = PerlIONext(x); 616 } 617 } 618 f++; 619 } 620 } 621 } 622 623 void 624 PerlIO_pop(pTHX_ PerlIO *f) 625 { 626 PerlIOl *l = *f; 627 if (l) { 628 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name); 629 if (l->tab->Popped) { 630 /* 631 * If popped returns non-zero do not free its layer structure 632 * it has either done so itself, or it is shared and still in 633 * use 634 */ 635 if ((*l->tab->Popped) (aTHX_ f) != 0) 636 return; 637 } 638 *f = l->next; 639 Safefree(l); 640 } 641 } 642 643 /*--------------------------------------------------------------------------------------*/ 644 /* 645 * XS Interface for perl code 646 */ 647 648 PerlIO_funcs * 649 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) 650 { 651 IV i; 652 if ((SSize_t) len <= 0) 653 len = strlen(name); 654 for (i = 0; i < PL_known_layers->cur; i++) { 655 PerlIO_funcs *f = PL_known_layers->array[i].funcs; 656 if (memEQ(f->name, name, len)) { 657 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); 658 return f; 659 } 660 } 661 if (load && PL_subname && PL_def_layerlist 662 && PL_def_layerlist->cur >= 2) { 663 SV *pkgsv = newSVpvn("PerlIO", 6); 664 SV *layer = newSVpvn(name, len); 665 ENTER; 666 /* 667 * The two SVs are magically freed by load_module 668 */ 669 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv); 670 LEAVE; 671 return PerlIO_find_layer(aTHX_ name, len, 0); 672 } 673 PerlIO_debug("Cannot find %.*s\n", (int) len, name); 674 return NULL; 675 } 676 677 #ifdef USE_ATTRIBUTES_FOR_PERLIO 678 679 static int 680 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) 681 { 682 if (SvROK(sv)) { 683 IO *io = GvIOn((GV *) SvRV(sv)); 684 PerlIO *ifp = IoIFP(io); 685 PerlIO *ofp = IoOFP(io); 686 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp); 687 } 688 return 0; 689 } 690 691 static int 692 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) 693 { 694 if (SvROK(sv)) { 695 IO *io = GvIOn((GV *) SvRV(sv)); 696 PerlIO *ifp = IoIFP(io); 697 PerlIO *ofp = IoOFP(io); 698 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp); 699 } 700 return 0; 701 } 702 703 static int 704 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) 705 { 706 Perl_warn(aTHX_ "clear %" SVf, sv); 707 return 0; 708 } 709 710 static int 711 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) 712 { 713 Perl_warn(aTHX_ "free %" SVf, sv); 714 return 0; 715 } 716 717 MGVTBL perlio_vtab = { 718 perlio_mg_get, 719 perlio_mg_set, 720 NULL, /* len */ 721 perlio_mg_clear, 722 perlio_mg_free 723 }; 724 725 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) 726 { 727 dXSARGS; 728 SV *sv = SvRV(ST(1)); 729 AV *av = newAV(); 730 MAGIC *mg; 731 int count = 0; 732 int i; 733 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0); 734 SvRMAGICAL_off(sv); 735 mg = mg_find(sv, PERL_MAGIC_ext); 736 mg->mg_virtual = &perlio_vtab; 737 mg_magical(sv); 738 Perl_warn(aTHX_ "attrib %" SVf, sv); 739 for (i = 2; i < items; i++) { 740 STRLEN len; 741 const char *name = SvPV(ST(i), len); 742 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1); 743 if (layer) { 744 av_push(av, SvREFCNT_inc(layer)); 745 } 746 else { 747 ST(count) = ST(i); 748 count++; 749 } 750 } 751 SvREFCNT_dec(av); 752 XSRETURN(count); 753 } 754 755 #endif /* USE_ATTIBUTES_FOR_PERLIO */ 756 757 SV * 758 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) 759 { 760 HV *stash = gv_stashpv("PerlIO::Layer", TRUE); 761 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash); 762 return sv; 763 } 764 765 XS(XS_PerlIO__Layer__find) 766 { 767 dXSARGS; 768 if (items < 2) 769 Perl_croak(aTHX_ "Usage class->find(name[,load])"); 770 else { 771 STRLEN len = 0; 772 char *name = SvPV(ST(1), len); 773 bool load = (items > 2) ? SvTRUE(ST(2)) : 0; 774 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load); 775 ST(0) = 776 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : 777 &PL_sv_undef; 778 XSRETURN(1); 779 } 780 } 781 782 void 783 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 784 { 785 if (!PL_known_layers) 786 PL_known_layers = PerlIO_list_alloc(aTHX); 787 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv); 788 PerlIO_debug("define %s %p\n", tab->name, (void*)tab); 789 } 790 791 int 792 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) 793 { 794 if (names) { 795 const char *s = names; 796 while (*s) { 797 while (isSPACE(*s) || *s == ':') 798 s++; 799 if (*s) { 800 STRLEN llen = 0; 801 const char *e = s; 802 const char *as = Nullch; 803 STRLEN alen = 0; 804 if (!isIDFIRST(*s)) { 805 /* 806 * Message is consistent with how attribute lists are 807 * passed. Even though this means "foo : : bar" is 808 * seen as an invalid separator character. 809 */ 810 char q = ((*s == '\'') ? '"' : '\''); 811 if (ckWARN(WARN_LAYER)) 812 Perl_warner(aTHX_ packWARN(WARN_LAYER), 813 "perlio: invalid separator character %c%c%c in layer specification list %s", 814 q, *s, q, s); 815 SETERRNO(EINVAL, LIB$_INVARG); 816 return -1; 817 } 818 do { 819 e++; 820 } while (isALNUM(*e)); 821 llen = e - s; 822 if (*e == '(') { 823 int nesting = 1; 824 as = ++e; 825 while (nesting) { 826 switch (*e++) { 827 case ')': 828 if (--nesting == 0) 829 alen = (e - 1) - as; 830 break; 831 case '(': 832 ++nesting; 833 break; 834 case '\\': 835 /* 836 * It's a nul terminated string, not allowed 837 * to \ the terminating null. Anything other 838 * character is passed over. 839 */ 840 if (*e++) { 841 break; 842 } 843 /* 844 * Drop through 845 */ 846 case '\0': 847 e--; 848 if (ckWARN(WARN_LAYER)) 849 Perl_warner(aTHX_ packWARN(WARN_LAYER), 850 "perlio: argument list not closed for layer \"%.*s\"", 851 (int) (e - s), s); 852 return -1; 853 default: 854 /* 855 * boring. 856 */ 857 break; 858 } 859 } 860 } 861 if (e > s) { 862 bool warn_layer = ckWARN(WARN_LAYER); 863 PerlIO_funcs *layer = 864 PerlIO_find_layer(aTHX_ s, llen, 1); 865 if (layer) { 866 PerlIO_list_push(aTHX_ av, layer, 867 (as) ? newSVpvn(as, 868 alen) : 869 &PL_sv_undef); 870 } 871 else { 872 if (warn_layer) 873 Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"", 874 (int) llen, s); 875 return -1; 876 } 877 } 878 s = e; 879 } 880 } 881 } 882 return 0; 883 } 884 885 void 886 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) 887 { 888 PerlIO_funcs *tab = &PerlIO_perlio; 889 #ifdef PERLIO_USING_CRLF 890 tab = &PerlIO_crlf; 891 #else 892 if (PerlIO_stdio.Set_ptrcnt) 893 tab = &PerlIO_stdio; 894 #endif 895 PerlIO_debug("Pushing %s\n", tab->name); 896 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), 897 &PL_sv_undef); 898 } 899 900 SV * 901 PerlIO_arg_fetch(PerlIO_list_t *av, IV n) 902 { 903 return av->array[n].arg; 904 } 905 906 PerlIO_funcs * 907 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) 908 { 909 if (n >= 0 && n < av->cur) { 910 PerlIO_debug("Layer %" IVdf " is %s\n", n, 911 av->array[n].funcs->name); 912 return av->array[n].funcs; 913 } 914 if (!def) 915 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); 916 return def; 917 } 918 919 IV 920 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 921 { 922 if (PerlIOValid(f)) { 923 PerlIO_flush(f); 924 PerlIO_pop(aTHX_ f); 925 return 0; 926 } 927 return -1; 928 } 929 930 PerlIO_funcs PerlIO_remove = { 931 sizeof(PerlIO_funcs), 932 "pop", 933 0, 934 PERLIO_K_DUMMY | PERLIO_K_UTF8, 935 PerlIOPop_pushed, 936 NULL, 937 NULL, 938 NULL, 939 NULL, 940 NULL, 941 NULL, 942 NULL, 943 NULL, 944 NULL, 945 NULL, 946 NULL, /* flush */ 947 NULL, /* fill */ 948 NULL, 949 NULL, 950 NULL, 951 NULL, 952 NULL, /* get_base */ 953 NULL, /* get_bufsiz */ 954 NULL, /* get_ptr */ 955 NULL, /* get_cnt */ 956 NULL, /* set_ptrcnt */ 957 }; 958 959 PerlIO_list_t * 960 PerlIO_default_layers(pTHX) 961 { 962 if (!PL_def_layerlist) { 963 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); 964 PerlIO_funcs *osLayer = &PerlIO_unix; 965 PL_def_layerlist = PerlIO_list_alloc(aTHX); 966 PerlIO_define_layer(aTHX_ & PerlIO_unix); 967 #if defined(WIN32) && !defined(UNDER_CE) 968 PerlIO_define_layer(aTHX_ & PerlIO_win32); 969 #if 0 970 osLayer = &PerlIO_win32; 971 #endif 972 #endif 973 PerlIO_define_layer(aTHX_ & PerlIO_raw); 974 PerlIO_define_layer(aTHX_ & PerlIO_perlio); 975 PerlIO_define_layer(aTHX_ & PerlIO_stdio); 976 PerlIO_define_layer(aTHX_ & PerlIO_crlf); 977 #ifdef HAS_MMAP 978 PerlIO_define_layer(aTHX_ & PerlIO_mmap); 979 #endif 980 PerlIO_define_layer(aTHX_ & PerlIO_utf8); 981 PerlIO_define_layer(aTHX_ & PerlIO_remove); 982 PerlIO_define_layer(aTHX_ & PerlIO_byte); 983 PerlIO_list_push(aTHX_ PL_def_layerlist, 984 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), 985 &PL_sv_undef); 986 if (s) { 987 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); 988 } 989 else { 990 PerlIO_default_buffer(aTHX_ PL_def_layerlist); 991 } 992 } 993 if (PL_def_layerlist->cur < 2) { 994 PerlIO_default_buffer(aTHX_ PL_def_layerlist); 995 } 996 return PL_def_layerlist; 997 } 998 999 void 1000 Perl_boot_core_PerlIO(pTHX) 1001 { 1002 #ifdef USE_ATTRIBUTES_FOR_PERLIO 1003 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, 1004 __FILE__); 1005 #endif 1006 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); 1007 } 1008 1009 PerlIO_funcs * 1010 PerlIO_default_layer(pTHX_ I32 n) 1011 { 1012 PerlIO_list_t *av = PerlIO_default_layers(aTHX); 1013 if (n < 0) 1014 n += av->cur; 1015 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio); 1016 } 1017 1018 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) 1019 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) 1020 1021 void 1022 PerlIO_stdstreams(pTHX) 1023 { 1024 if (!PL_perlio) { 1025 PerlIO_allocate(aTHX); 1026 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); 1027 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); 1028 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); 1029 } 1030 } 1031 1032 PerlIO * 1033 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg) 1034 { 1035 if (tab->fsize != sizeof(PerlIO_funcs)) { 1036 mismatch: 1037 Perl_croak(aTHX_ "Layer does not match this perl"); 1038 } 1039 if (tab->size) { 1040 PerlIOl *l = NULL; 1041 if (tab->size < sizeof(PerlIOl)) { 1042 goto mismatch; 1043 } 1044 /* Real layer with a data area */ 1045 Newc('L',l,tab->size,char,PerlIOl); 1046 if (l && f) { 1047 Zero(l, tab->size, char); 1048 l->next = *f; 1049 l->tab = tab; 1050 *f = l; 1051 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, 1052 (mode) ? mode : "(Null)", (void*)arg); 1053 if ((*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) { 1054 PerlIO_pop(aTHX_ f); 1055 return NULL; 1056 } 1057 } 1058 } 1059 else if (f) { 1060 /* Pseudo-layer where push does its own stack adjust */ 1061 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, 1062 (mode) ? mode : "(Null)", (void*)arg); 1063 if ((*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) { 1064 return NULL; 1065 } 1066 } 1067 return f; 1068 } 1069 1070 IV 1071 PerlIOBase_binmode(pTHX_ PerlIO *f) 1072 { 1073 if (PerlIOValid(f)) { 1074 /* Is layer suitable for raw stream ? */ 1075 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { 1076 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ 1077 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1078 } 1079 else { 1080 /* Not suitable - pop it */ 1081 PerlIO_pop(aTHX_ f); 1082 } 1083 return 0; 1084 } 1085 return -1; 1086 } 1087 1088 IV 1089 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1090 { 1091 1092 if (PerlIOValid(f)) { 1093 PerlIO *t; 1094 PerlIOl *l; 1095 PerlIO_flush(f); 1096 /* 1097 * Strip all layers that are not suitable for a raw stream 1098 */ 1099 t = f; 1100 while (t && (l = *t)) { 1101 if (l->tab->Binmode) { 1102 /* Has a handler - normal case */ 1103 if ((*l->tab->Binmode)(aTHX_ f) == 0) { 1104 if (*t == l) { 1105 /* Layer still there - move down a layer */ 1106 t = PerlIONext(t); 1107 } 1108 } 1109 else { 1110 return -1; 1111 } 1112 } 1113 else { 1114 /* No handler - pop it */ 1115 PerlIO_pop(aTHX_ t); 1116 } 1117 } 1118 if (PerlIOValid(f)) { 1119 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); 1120 return 0; 1121 } 1122 } 1123 return -1; 1124 } 1125 1126 int 1127 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, 1128 PerlIO_list_t *layers, IV n, IV max) 1129 { 1130 int code = 0; 1131 while (n < max) { 1132 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); 1133 if (tab) { 1134 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { 1135 code = -1; 1136 break; 1137 } 1138 } 1139 n++; 1140 } 1141 return code; 1142 } 1143 1144 int 1145 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) 1146 { 1147 int code = 0; 1148 if (f && names) { 1149 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX); 1150 code = PerlIO_parse_layers(aTHX_ layers, names); 1151 if (code == 0) { 1152 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); 1153 } 1154 PerlIO_list_free(aTHX_ layers); 1155 } 1156 return code; 1157 } 1158 1159 1160 /*--------------------------------------------------------------------------------------*/ 1161 /* 1162 * Given the abstraction above the public API functions 1163 */ 1164 1165 int 1166 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) 1167 { 1168 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", 1169 (void*)f, PerlIOBase(f)->tab->name, iotype, mode, 1170 (names) ? names : "(Null)"); 1171 if (names) { 1172 /* Do not flush etc. if (e.g.) switching encodings. 1173 if a pushed layer knows it needs to flush lower layers 1174 (for example :unix which is never going to call them) 1175 it can do the flush when it is pushed. 1176 */ 1177 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; 1178 } 1179 else { 1180 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ 1181 #ifdef PERLIO_USING_CRLF 1182 /* Legacy binmode only has meaning if O_TEXT has a value distinct from 1183 O_BINARY so we can look for it in mode. 1184 */ 1185 if (!(mode & O_BINARY)) { 1186 /* Text mode */ 1187 /* FIXME?: Looking down the layer stack seems wrong, 1188 but is a way of reaching past (say) an encoding layer 1189 to flip CRLF-ness of the layer(s) below 1190 */ 1191 while (*f) { 1192 /* Perhaps we should turn on bottom-most aware layer 1193 e.g. Ilya's idea that UNIX TTY could serve 1194 */ 1195 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) { 1196 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 1197 /* Not in text mode - flush any pending stuff and flip it */ 1198 PerlIO_flush(f); 1199 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 1200 } 1201 /* Only need to turn it on in one layer so we are done */ 1202 return TRUE; 1203 } 1204 f = PerlIONext(f); 1205 } 1206 /* Not finding a CRLF aware layer presumably means we are binary 1207 which is not what was requested - so we failed 1208 We _could_ push :crlf layer but so could caller 1209 */ 1210 return FALSE; 1211 } 1212 #endif 1213 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw 1214 So code that used to be here is now in PerlIORaw_pushed(). 1215 */ 1216 return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE; 1217 } 1218 } 1219 1220 int 1221 PerlIO__close(pTHX_ PerlIO *f) 1222 { 1223 if (PerlIOValid(f)) 1224 return (*PerlIOBase(f)->tab->Close) (aTHX_ f); 1225 else { 1226 SETERRNO(EBADF, SS$_IVCHAN); 1227 return -1; 1228 } 1229 } 1230 1231 int 1232 Perl_PerlIO_close(pTHX_ PerlIO *f) 1233 { 1234 int code = -1; 1235 if (PerlIOValid(f)) { 1236 code = (*PerlIOBase(f)->tab->Close) (aTHX_ f); 1237 while (*f) { 1238 PerlIO_pop(aTHX_ f); 1239 } 1240 } 1241 return code; 1242 } 1243 1244 int 1245 Perl_PerlIO_fileno(pTHX_ PerlIO *f) 1246 { 1247 if (PerlIOValid(f)) 1248 return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f); 1249 else { 1250 SETERRNO(EBADF, SS$_IVCHAN); 1251 return -1; 1252 } 1253 } 1254 1255 static const char * 1256 PerlIO_context_layers(pTHX_ const char *mode) 1257 { 1258 const char *type = NULL; 1259 /* 1260 * Need to supply default layer info from open.pm 1261 */ 1262 if (PL_curcop) { 1263 SV *layers = PL_curcop->cop_io; 1264 if (layers) { 1265 STRLEN len; 1266 type = SvPV(layers, len); 1267 if (type && mode[0] != 'r') { 1268 /* 1269 * Skip to write part 1270 */ 1271 const char *s = strchr(type, 0); 1272 if (s && (STRLEN)(s - type) < len) { 1273 type = s + 1; 1274 } 1275 } 1276 } 1277 } 1278 return type; 1279 } 1280 1281 static PerlIO_funcs * 1282 PerlIO_layer_from_ref(pTHX_ SV *sv) 1283 { 1284 /* 1285 * For any scalar type load the handler which is bundled with perl 1286 */ 1287 if (SvTYPE(sv) < SVt_PVAV) 1288 return PerlIO_find_layer(aTHX_ "scalar", 6, 1); 1289 1290 /* 1291 * For other types allow if layer is known but don't try and load it 1292 */ 1293 switch (SvTYPE(sv)) { 1294 case SVt_PVAV: 1295 return PerlIO_find_layer(aTHX_ "Array", 5, 0); 1296 case SVt_PVHV: 1297 return PerlIO_find_layer(aTHX_ "Hash", 4, 0); 1298 case SVt_PVCV: 1299 return PerlIO_find_layer(aTHX_ "Code", 4, 0); 1300 case SVt_PVGV: 1301 return PerlIO_find_layer(aTHX_ "Glob", 4, 0); 1302 } 1303 return NULL; 1304 } 1305 1306 PerlIO_list_t * 1307 PerlIO_resolve_layers(pTHX_ const char *layers, 1308 const char *mode, int narg, SV **args) 1309 { 1310 PerlIO_list_t *def = PerlIO_default_layers(aTHX); 1311 int incdef = 1; 1312 if (!PL_perlio) 1313 PerlIO_stdstreams(aTHX); 1314 if (narg) { 1315 SV *arg = *args; 1316 /* 1317 * If it is a reference but not an object see if we have a handler 1318 * for it 1319 */ 1320 if (SvROK(arg) && !sv_isobject(arg)) { 1321 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); 1322 if (handler) { 1323 def = PerlIO_list_alloc(aTHX); 1324 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); 1325 incdef = 0; 1326 } 1327 /* 1328 * Don't fail if handler cannot be found :via(...) etc. may do 1329 * something sensible else we will just stringfy and open 1330 * resulting string. 1331 */ 1332 } 1333 } 1334 if (!layers) 1335 layers = PerlIO_context_layers(aTHX_ mode); 1336 if (layers && *layers) { 1337 PerlIO_list_t *av; 1338 if (incdef) { 1339 IV i = def->cur; 1340 av = PerlIO_list_alloc(aTHX); 1341 for (i = 0; i < def->cur; i++) { 1342 PerlIO_list_push(aTHX_ av, def->array[i].funcs, 1343 def->array[i].arg); 1344 } 1345 } 1346 else { 1347 av = def; 1348 } 1349 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { 1350 return av; 1351 } 1352 else { 1353 PerlIO_list_free(aTHX_ av); 1354 return (PerlIO_list_t *) NULL; 1355 } 1356 } 1357 else { 1358 if (incdef) 1359 def->refcnt++; 1360 return def; 1361 } 1362 } 1363 1364 PerlIO * 1365 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 1366 int imode, int perm, PerlIO *f, int narg, SV **args) 1367 { 1368 if (!f && narg == 1 && *args == &PL_sv_undef) { 1369 if ((f = PerlIO_tmpfile())) { 1370 if (!layers) 1371 layers = PerlIO_context_layers(aTHX_ mode); 1372 if (layers && *layers) 1373 PerlIO_apply_layers(aTHX_ f, mode, layers); 1374 } 1375 } 1376 else { 1377 PerlIO_list_t *layera = NULL; 1378 IV n; 1379 PerlIO_funcs *tab = NULL; 1380 if (PerlIOValid(f)) { 1381 /* 1382 * This is "reopen" - it is not tested as perl does not use it 1383 * yet 1384 */ 1385 PerlIOl *l = *f; 1386 layera = PerlIO_list_alloc(aTHX); 1387 while (l) { 1388 SV *arg = (l->tab->Getarg) 1389 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0) 1390 : &PL_sv_undef; 1391 PerlIO_list_push(aTHX_ layera, l->tab, arg); 1392 l = *PerlIONext(&l); 1393 } 1394 } 1395 else { 1396 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); 1397 if (!layera) { 1398 return NULL; 1399 } 1400 } 1401 /* 1402 * Start at "top" of layer stack 1403 */ 1404 n = layera->cur - 1; 1405 while (n >= 0) { 1406 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); 1407 if (t && t->Open) { 1408 tab = t; 1409 break; 1410 } 1411 n--; 1412 } 1413 if (tab) { 1414 /* 1415 * Found that layer 'n' can do opens - call it 1416 */ 1417 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { 1418 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); 1419 } 1420 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", 1421 tab->name, layers, mode, fd, imode, perm, 1422 (void*)f, narg, (void*)args); 1423 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, 1424 f, narg, args); 1425 if (f) { 1426 if (n + 1 < layera->cur) { 1427 /* 1428 * More layers above the one that we used to open - 1429 * apply them now 1430 */ 1431 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { 1432 /* If pushing layers fails close the file */ 1433 PerlIO_close(f); 1434 f = NULL; 1435 } 1436 } 1437 } 1438 } 1439 PerlIO_list_free(aTHX_ layera); 1440 } 1441 return f; 1442 } 1443 1444 1445 SSize_t 1446 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 1447 { 1448 if (PerlIOValid(f)) 1449 return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count); 1450 else { 1451 SETERRNO(EBADF, SS$_IVCHAN); 1452 return -1; 1453 } 1454 } 1455 1456 SSize_t 1457 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1458 { 1459 if (PerlIOValid(f)) 1460 return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count); 1461 else { 1462 SETERRNO(EBADF, SS$_IVCHAN); 1463 return -1; 1464 } 1465 } 1466 1467 SSize_t 1468 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1469 { 1470 if (PerlIOValid(f)) 1471 return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count); 1472 else { 1473 SETERRNO(EBADF, SS$_IVCHAN); 1474 return -1; 1475 } 1476 } 1477 1478 int 1479 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 1480 { 1481 if (PerlIOValid(f)) 1482 return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence); 1483 else { 1484 SETERRNO(EBADF, SS$_IVCHAN); 1485 return -1; 1486 } 1487 } 1488 1489 Off_t 1490 Perl_PerlIO_tell(pTHX_ PerlIO *f) 1491 { 1492 if (PerlIOValid(f)) 1493 return (*PerlIOBase(f)->tab->Tell) (aTHX_ f); 1494 else { 1495 SETERRNO(EBADF, SS$_IVCHAN); 1496 return -1; 1497 } 1498 } 1499 1500 int 1501 Perl_PerlIO_flush(pTHX_ PerlIO *f) 1502 { 1503 if (f) { 1504 if (*f) { 1505 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1506 if (tab && tab->Flush) { 1507 return (*tab->Flush) (aTHX_ f); 1508 } 1509 else { 1510 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name); 1511 SETERRNO(EBADF, SS$_IVCHAN); 1512 return -1; 1513 } 1514 } 1515 else { 1516 PerlIO_debug("Cannot flush f=%p\n", (void*)f); 1517 SETERRNO(EBADF, SS$_IVCHAN); 1518 return -1; 1519 } 1520 } 1521 else { 1522 /* 1523 * Is it good API design to do flush-all on NULL, a potentially 1524 * errorneous input? Maybe some magical value (PerlIO* 1525 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar 1526 * things on fflush(NULL), but should we be bound by their design 1527 * decisions? --jhi 1528 */ 1529 PerlIO **table = &PL_perlio; 1530 int code = 0; 1531 while ((f = *table)) { 1532 int i; 1533 table = (PerlIO **) (f++); 1534 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1535 if (*f && PerlIO_flush(f) != 0) 1536 code = -1; 1537 f++; 1538 } 1539 } 1540 return code; 1541 } 1542 } 1543 1544 void 1545 PerlIOBase_flush_linebuf(pTHX) 1546 { 1547 PerlIO **table = &PL_perlio; 1548 PerlIO *f; 1549 while ((f = *table)) { 1550 int i; 1551 table = (PerlIO **) (f++); 1552 for (i = 1; i < PERLIO_TABLE_SIZE; i++) { 1553 if (*f 1554 && (PerlIOBase(f)-> 1555 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1556 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) 1557 PerlIO_flush(f); 1558 f++; 1559 } 1560 } 1561 } 1562 1563 int 1564 Perl_PerlIO_fill(pTHX_ PerlIO *f) 1565 { 1566 if (PerlIOValid(f)) 1567 return (*PerlIOBase(f)->tab->Fill) (aTHX_ f); 1568 else { 1569 SETERRNO(EBADF, SS$_IVCHAN); 1570 return -1; 1571 } 1572 } 1573 1574 int 1575 PerlIO_isutf8(PerlIO *f) 1576 { 1577 if (PerlIOValid(f)) 1578 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; 1579 else { 1580 SETERRNO(EBADF, SS$_IVCHAN); 1581 return -1; 1582 } 1583 } 1584 1585 int 1586 Perl_PerlIO_eof(pTHX_ PerlIO *f) 1587 { 1588 if (PerlIOValid(f)) 1589 return (*PerlIOBase(f)->tab->Eof) (aTHX_ f); 1590 else { 1591 SETERRNO(EBADF, SS$_IVCHAN); 1592 return -1; 1593 } 1594 } 1595 1596 int 1597 Perl_PerlIO_error(pTHX_ PerlIO *f) 1598 { 1599 if (PerlIOValid(f)) 1600 return (*PerlIOBase(f)->tab->Error) (aTHX_ f); 1601 else { 1602 SETERRNO(EBADF, SS$_IVCHAN); 1603 return -1; 1604 } 1605 } 1606 1607 void 1608 Perl_PerlIO_clearerr(pTHX_ PerlIO *f) 1609 { 1610 if (PerlIOValid(f)) 1611 (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f); 1612 else 1613 SETERRNO(EBADF, SS$_IVCHAN); 1614 } 1615 1616 void 1617 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f) 1618 { 1619 if (PerlIOValid(f)) 1620 (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f); 1621 else 1622 SETERRNO(EBADF, SS$_IVCHAN); 1623 } 1624 1625 int 1626 PerlIO_has_base(PerlIO *f) 1627 { 1628 if (PerlIOValid(f)) { 1629 return (PerlIOBase(f)->tab->Get_base != NULL); 1630 } 1631 return 0; 1632 } 1633 1634 int 1635 PerlIO_fast_gets(PerlIO *f) 1636 { 1637 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) { 1638 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1639 return (tab->Set_ptrcnt != NULL); 1640 } 1641 return 0; 1642 } 1643 1644 int 1645 PerlIO_has_cntptr(PerlIO *f) 1646 { 1647 if (PerlIOValid(f)) { 1648 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1649 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); 1650 } 1651 return 0; 1652 } 1653 1654 int 1655 PerlIO_canset_cnt(PerlIO *f) 1656 { 1657 if (PerlIOValid(f)) { 1658 PerlIOl *l = PerlIOBase(f); 1659 return (l->tab->Set_ptrcnt != NULL); 1660 } 1661 return 0; 1662 } 1663 1664 STDCHAR * 1665 Perl_PerlIO_get_base(pTHX_ PerlIO *f) 1666 { 1667 if (PerlIOValid(f)) 1668 return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f); 1669 return NULL; 1670 } 1671 1672 int 1673 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) 1674 { 1675 if (PerlIOValid(f)) 1676 return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f); 1677 return 0; 1678 } 1679 1680 STDCHAR * 1681 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) 1682 { 1683 if (PerlIOValid(f)) { 1684 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1685 if (tab->Get_ptr == NULL) 1686 return NULL; 1687 return (*tab->Get_ptr) (aTHX_ f); 1688 } 1689 return NULL; 1690 } 1691 1692 int 1693 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) 1694 { 1695 if (PerlIOValid(f)) { 1696 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1697 if (tab->Get_cnt == NULL) 1698 return 0; 1699 return (*tab->Get_cnt) (aTHX_ f); 1700 } 1701 return 0; 1702 } 1703 1704 void 1705 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt) 1706 { 1707 if (PerlIOValid(f)) { 1708 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt); 1709 } 1710 } 1711 1712 void 1713 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt) 1714 { 1715 if (PerlIOValid(f)) { 1716 PerlIO_funcs *tab = PerlIOBase(f)->tab; 1717 if (tab->Set_ptrcnt == NULL) { 1718 Perl_croak(aTHX_ "PerlIO buffer snooping abuse"); 1719 } 1720 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt); 1721 } 1722 } 1723 1724 1725 /*--------------------------------------------------------------------------------------*/ 1726 /* 1727 * utf8 and raw dummy layers 1728 */ 1729 1730 IV 1731 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1732 { 1733 if (PerlIOValid(f)) { 1734 if (tab->kind & PERLIO_K_UTF8) 1735 PerlIOBase(f)->flags |= PERLIO_F_UTF8; 1736 else 1737 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; 1738 return 0; 1739 } 1740 return -1; 1741 } 1742 1743 PerlIO_funcs PerlIO_utf8 = { 1744 sizeof(PerlIO_funcs), 1745 "utf8", 1746 0, 1747 PERLIO_K_DUMMY | PERLIO_K_UTF8, 1748 PerlIOUtf8_pushed, 1749 NULL, 1750 NULL, 1751 NULL, 1752 NULL, 1753 NULL, 1754 NULL, 1755 NULL, 1756 NULL, 1757 NULL, 1758 NULL, 1759 NULL, /* flush */ 1760 NULL, /* fill */ 1761 NULL, 1762 NULL, 1763 NULL, 1764 NULL, 1765 NULL, /* get_base */ 1766 NULL, /* get_bufsiz */ 1767 NULL, /* get_ptr */ 1768 NULL, /* get_cnt */ 1769 NULL, /* set_ptrcnt */ 1770 }; 1771 1772 PerlIO_funcs PerlIO_byte = { 1773 sizeof(PerlIO_funcs), 1774 "bytes", 1775 0, 1776 PERLIO_K_DUMMY, 1777 PerlIOUtf8_pushed, 1778 NULL, 1779 NULL, 1780 NULL, 1781 NULL, 1782 NULL, 1783 NULL, 1784 NULL, 1785 NULL, 1786 NULL, 1787 NULL, 1788 NULL, /* flush */ 1789 NULL, /* fill */ 1790 NULL, 1791 NULL, 1792 NULL, 1793 NULL, 1794 NULL, /* get_base */ 1795 NULL, /* get_bufsiz */ 1796 NULL, /* get_ptr */ 1797 NULL, /* get_cnt */ 1798 NULL, /* set_ptrcnt */ 1799 }; 1800 1801 PerlIO * 1802 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 1803 IV n, const char *mode, int fd, int imode, int perm, 1804 PerlIO *old, int narg, SV **args) 1805 { 1806 PerlIO_funcs *tab = PerlIO_default_btm(); 1807 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 1808 old, narg, args); 1809 } 1810 1811 PerlIO_funcs PerlIO_raw = { 1812 sizeof(PerlIO_funcs), 1813 "raw", 1814 0, 1815 PERLIO_K_DUMMY, 1816 PerlIORaw_pushed, 1817 PerlIOBase_popped, 1818 PerlIORaw_open, 1819 NULL, 1820 NULL, 1821 NULL, 1822 NULL, 1823 NULL, 1824 NULL, 1825 NULL, 1826 NULL, 1827 NULL, /* flush */ 1828 NULL, /* fill */ 1829 NULL, 1830 NULL, 1831 NULL, 1832 NULL, 1833 NULL, /* get_base */ 1834 NULL, /* get_bufsiz */ 1835 NULL, /* get_ptr */ 1836 NULL, /* get_cnt */ 1837 NULL, /* set_ptrcnt */ 1838 }; 1839 /*--------------------------------------------------------------------------------------*/ 1840 /*--------------------------------------------------------------------------------------*/ 1841 /* 1842 * "Methods" of the "base class" 1843 */ 1844 1845 IV 1846 PerlIOBase_fileno(pTHX_ PerlIO *f) 1847 { 1848 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1; 1849 } 1850 1851 char * 1852 PerlIO_modestr(PerlIO * f, char *buf) 1853 { 1854 char *s = buf; 1855 if (PerlIOValid(f)) { 1856 IV flags = PerlIOBase(f)->flags; 1857 if (flags & PERLIO_F_APPEND) { 1858 *s++ = 'a'; 1859 if (flags & PERLIO_F_CANREAD) { 1860 *s++ = '+'; 1861 } 1862 } 1863 else if (flags & PERLIO_F_CANREAD) { 1864 *s++ = 'r'; 1865 if (flags & PERLIO_F_CANWRITE) 1866 *s++ = '+'; 1867 } 1868 else if (flags & PERLIO_F_CANWRITE) { 1869 *s++ = 'w'; 1870 if (flags & PERLIO_F_CANREAD) { 1871 *s++ = '+'; 1872 } 1873 } 1874 #ifdef PERLIO_USING_CRLF 1875 if (!(flags & PERLIO_F_CRLF)) 1876 *s++ = 'b'; 1877 #endif 1878 } 1879 *s = '\0'; 1880 return buf; 1881 } 1882 1883 1884 IV 1885 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 1886 { 1887 PerlIOl *l = PerlIOBase(f); 1888 #if 0 1889 const char *omode = mode; 1890 char temp[8]; 1891 #endif 1892 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | 1893 PERLIO_F_TRUNCATE | PERLIO_F_APPEND); 1894 if (tab->Set_ptrcnt != NULL) 1895 l->flags |= PERLIO_F_FASTGETS; 1896 if (mode) { 1897 if (*mode == '#' || *mode == 'I') 1898 mode++; 1899 switch (*mode++) { 1900 case 'r': 1901 l->flags |= PERLIO_F_CANREAD; 1902 break; 1903 case 'a': 1904 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; 1905 break; 1906 case 'w': 1907 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; 1908 break; 1909 default: 1910 SETERRNO(EINVAL, LIB$_INVARG); 1911 return -1; 1912 } 1913 while (*mode) { 1914 switch (*mode++) { 1915 case '+': 1916 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; 1917 break; 1918 case 'b': 1919 l->flags &= ~PERLIO_F_CRLF; 1920 break; 1921 case 't': 1922 l->flags |= PERLIO_F_CRLF; 1923 break; 1924 default: 1925 SETERRNO(EINVAL, LIB$_INVARG); 1926 return -1; 1927 } 1928 } 1929 } 1930 else { 1931 if (l->next) { 1932 l->flags |= l->next->flags & 1933 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | 1934 PERLIO_F_APPEND); 1935 } 1936 } 1937 #if 0 1938 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", 1939 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", 1940 l->flags, PerlIO_modestr(f, temp)); 1941 #endif 1942 return 0; 1943 } 1944 1945 IV 1946 PerlIOBase_popped(pTHX_ PerlIO *f) 1947 { 1948 return 0; 1949 } 1950 1951 SSize_t 1952 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 1953 { 1954 /* 1955 * Save the position as current head considers it 1956 */ 1957 Off_t old = PerlIO_tell(f); 1958 SSize_t done; 1959 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv); 1960 PerlIOSelf(f, PerlIOBuf)->posn = old; 1961 done = PerlIOBuf_unread(aTHX_ f, vbuf, count); 1962 return done; 1963 } 1964 1965 SSize_t 1966 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 1967 { 1968 STDCHAR *buf = (STDCHAR *) vbuf; 1969 if (f) { 1970 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) 1971 return 0; 1972 while (count > 0) { 1973 SSize_t avail = PerlIO_get_cnt(f); 1974 SSize_t take = 0; 1975 if (avail > 0) 1976 take = ((SSize_t)count < avail) ? count : avail; 1977 if (take > 0) { 1978 STDCHAR *ptr = PerlIO_get_ptr(f); 1979 Copy(ptr, buf, take, STDCHAR); 1980 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); 1981 count -= take; 1982 buf += take; 1983 } 1984 if (count > 0 && avail <= 0) { 1985 if (PerlIO_fill(f) != 0) 1986 break; 1987 } 1988 } 1989 return (buf - (STDCHAR *) vbuf); 1990 } 1991 return 0; 1992 } 1993 1994 IV 1995 PerlIOBase_noop_ok(pTHX_ PerlIO *f) 1996 { 1997 return 0; 1998 } 1999 2000 IV 2001 PerlIOBase_noop_fail(pTHX_ PerlIO *f) 2002 { 2003 return -1; 2004 } 2005 2006 IV 2007 PerlIOBase_close(pTHX_ PerlIO *f) 2008 { 2009 IV code = 0; 2010 PerlIO *n = PerlIONext(f); 2011 if (PerlIO_flush(f) != 0) 2012 code = -1; 2013 if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0) 2014 code = -1; 2015 PerlIOBase(f)->flags &= 2016 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); 2017 return code; 2018 } 2019 2020 IV 2021 PerlIOBase_eof(pTHX_ PerlIO *f) 2022 { 2023 if (PerlIOValid(f)) { 2024 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; 2025 } 2026 return 1; 2027 } 2028 2029 IV 2030 PerlIOBase_error(pTHX_ PerlIO *f) 2031 { 2032 if (PerlIOValid(f)) { 2033 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; 2034 } 2035 return 1; 2036 } 2037 2038 void 2039 PerlIOBase_clearerr(pTHX_ PerlIO *f) 2040 { 2041 if (PerlIOValid(f)) { 2042 PerlIO *n = PerlIONext(f); 2043 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); 2044 if (PerlIOValid(n)) 2045 PerlIO_clearerr(n); 2046 } 2047 } 2048 2049 void 2050 PerlIOBase_setlinebuf(pTHX_ PerlIO *f) 2051 { 2052 if (PerlIOValid(f)) { 2053 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; 2054 } 2055 } 2056 2057 SV * 2058 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) 2059 { 2060 if (!arg) 2061 return Nullsv; 2062 #ifdef sv_dup 2063 if (param) { 2064 return sv_dup(arg, param); 2065 } 2066 else { 2067 return newSVsv(arg); 2068 } 2069 #else 2070 return newSVsv(arg); 2071 #endif 2072 } 2073 2074 PerlIO * 2075 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2076 { 2077 PerlIO *nexto = PerlIONext(o); 2078 if (PerlIOValid(nexto)) { 2079 PerlIO_funcs *tab = PerlIOBase(nexto)->tab; 2080 f = (*tab->Dup)(aTHX_ f, nexto, param, flags); 2081 } 2082 if (f) { 2083 PerlIO_funcs *self = PerlIOBase(o)->tab; 2084 SV *arg = Nullsv; 2085 char buf[8]; 2086 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", 2087 self->name, (void*)f, (void*)o, (void*)param); 2088 if (self->Getarg) { 2089 arg = (*self->Getarg)(aTHX_ o,param,flags); 2090 } 2091 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); 2092 if (arg) { 2093 SvREFCNT_dec(arg); 2094 } 2095 } 2096 return f; 2097 } 2098 2099 #define PERLIO_MAX_REFCOUNTABLE_FD 2048 2100 #ifdef USE_THREADS 2101 perl_mutex PerlIO_mutex; 2102 #endif 2103 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD]; 2104 2105 void 2106 PerlIO_init(pTHX) 2107 { 2108 /* Place holder for stdstreams call ??? */ 2109 #ifdef USE_THREADS 2110 MUTEX_INIT(&PerlIO_mutex); 2111 #endif 2112 } 2113 2114 void 2115 PerlIOUnix_refcnt_inc(int fd) 2116 { 2117 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2118 #ifdef USE_THREADS 2119 MUTEX_LOCK(&PerlIO_mutex); 2120 #endif 2121 PerlIO_fd_refcnt[fd]++; 2122 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]); 2123 #ifdef USE_THREADS 2124 MUTEX_UNLOCK(&PerlIO_mutex); 2125 #endif 2126 } 2127 } 2128 2129 int 2130 PerlIOUnix_refcnt_dec(int fd) 2131 { 2132 int cnt = 0; 2133 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2134 #ifdef USE_THREADS 2135 MUTEX_LOCK(&PerlIO_mutex); 2136 #endif 2137 cnt = --PerlIO_fd_refcnt[fd]; 2138 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt); 2139 #ifdef USE_THREADS 2140 MUTEX_UNLOCK(&PerlIO_mutex); 2141 #endif 2142 } 2143 return cnt; 2144 } 2145 2146 void 2147 PerlIO_cleanup(pTHX) 2148 { 2149 int i; 2150 #ifdef USE_ITHREADS 2151 PerlIO_debug("Cleanup layers for %p\n",aTHX); 2152 #else 2153 PerlIO_debug("Cleanup layers\n"); 2154 #endif 2155 /* Raise STDIN..STDERR refcount so we don't close them */ 2156 for (i=0; i < 3; i++) 2157 PerlIOUnix_refcnt_inc(i); 2158 PerlIO_cleantable(aTHX_ &PL_perlio); 2159 /* Restore STDIN..STDERR refcount */ 2160 for (i=0; i < 3; i++) 2161 PerlIOUnix_refcnt_dec(i); 2162 2163 if (PL_known_layers) { 2164 PerlIO_list_free(aTHX_ PL_known_layers); 2165 PL_known_layers = NULL; 2166 } 2167 if(PL_def_layerlist) { 2168 PerlIO_list_free(aTHX_ PL_def_layerlist); 2169 PL_def_layerlist = NULL; 2170 } 2171 } 2172 2173 2174 2175 /*--------------------------------------------------------------------------------------*/ 2176 /* 2177 * Bottom-most level for UNIX-like case 2178 */ 2179 2180 typedef struct { 2181 struct _PerlIO base; /* The generic part */ 2182 int fd; /* UNIX like file descriptor */ 2183 int oflags; /* open/fcntl flags */ 2184 } PerlIOUnix; 2185 2186 int 2187 PerlIOUnix_oflags(const char *mode) 2188 { 2189 int oflags = -1; 2190 if (*mode == 'I' || *mode == '#') 2191 mode++; 2192 switch (*mode) { 2193 case 'r': 2194 oflags = O_RDONLY; 2195 if (*++mode == '+') { 2196 oflags = O_RDWR; 2197 mode++; 2198 } 2199 break; 2200 2201 case 'w': 2202 oflags = O_CREAT | O_TRUNC; 2203 if (*++mode == '+') { 2204 oflags |= O_RDWR; 2205 mode++; 2206 } 2207 else 2208 oflags |= O_WRONLY; 2209 break; 2210 2211 case 'a': 2212 oflags = O_CREAT | O_APPEND; 2213 if (*++mode == '+') { 2214 oflags |= O_RDWR; 2215 mode++; 2216 } 2217 else 2218 oflags |= O_WRONLY; 2219 break; 2220 } 2221 if (*mode == 'b') { 2222 oflags |= O_BINARY; 2223 oflags &= ~O_TEXT; 2224 mode++; 2225 } 2226 else if (*mode == 't') { 2227 oflags |= O_TEXT; 2228 oflags &= ~O_BINARY; 2229 mode++; 2230 } 2231 /* 2232 * Always open in binary mode 2233 */ 2234 oflags |= O_BINARY; 2235 if (*mode || oflags == -1) { 2236 SETERRNO(EINVAL, LIB$_INVARG); 2237 oflags = -1; 2238 } 2239 return oflags; 2240 } 2241 2242 IV 2243 PerlIOUnix_fileno(pTHX_ PerlIO *f) 2244 { 2245 return PerlIOSelf(f, PerlIOUnix)->fd; 2246 } 2247 2248 IV 2249 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2250 { 2251 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2252 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); 2253 if (*PerlIONext(f)) { 2254 /* We never call down so do any pending stuff now */ 2255 PerlIO_flush(PerlIONext(f)); 2256 s->fd = PerlIO_fileno(PerlIONext(f)); 2257 /* 2258 * XXX could (or should) we retrieve the oflags from the open file 2259 * handle rather than believing the "mode" we are passed in? XXX 2260 * Should the value on NULL mode be 0 or -1? 2261 */ 2262 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1; 2263 } 2264 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2265 return code; 2266 } 2267 2268 PerlIO * 2269 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2270 IV n, const char *mode, int fd, int imode, 2271 int perm, PerlIO *f, int narg, SV **args) 2272 { 2273 if (PerlIOValid(f)) { 2274 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) 2275 (*PerlIOBase(f)->tab->Close)(aTHX_ f); 2276 } 2277 if (narg > 0) { 2278 char *path = SvPV_nolen(*args); 2279 if (*mode == '#') 2280 mode++; 2281 else { 2282 imode = PerlIOUnix_oflags(mode); 2283 perm = 0666; 2284 } 2285 if (imode != -1) { 2286 fd = PerlLIO_open3(path, imode, perm); 2287 } 2288 } 2289 if (fd >= 0) { 2290 PerlIOUnix *s; 2291 if (*mode == 'I') 2292 mode++; 2293 if (!f) { 2294 f = PerlIO_allocate(aTHX); 2295 } 2296 if (!PerlIOValid(f)) { 2297 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2298 return NULL; 2299 } 2300 } 2301 s = PerlIOSelf(f, PerlIOUnix); 2302 s->fd = fd; 2303 s->oflags = imode; 2304 PerlIOBase(f)->flags |= PERLIO_F_OPEN; 2305 PerlIOUnix_refcnt_inc(fd); 2306 return f; 2307 } 2308 else { 2309 if (f) { 2310 /* 2311 * FIXME: pop layers ??? 2312 */ 2313 } 2314 return NULL; 2315 } 2316 } 2317 2318 PerlIO * 2319 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2320 { 2321 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix); 2322 int fd = os->fd; 2323 if (flags & PERLIO_DUP_FD) { 2324 fd = PerlLIO_dup(fd); 2325 } 2326 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { 2327 f = PerlIOBase_dup(aTHX_ f, o, param, flags); 2328 if (f) { 2329 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ 2330 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); 2331 s->fd = fd; 2332 PerlIOUnix_refcnt_inc(fd); 2333 return f; 2334 } 2335 } 2336 return NULL; 2337 } 2338 2339 2340 SSize_t 2341 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2342 { 2343 int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2344 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || 2345 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { 2346 return 0; 2347 } 2348 while (1) { 2349 SSize_t len = PerlLIO_read(fd, vbuf, count); 2350 if (len >= 0 || errno != EINTR) { 2351 if (len < 0) 2352 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2353 else if (len == 0 && count != 0) 2354 PerlIOBase(f)->flags |= PERLIO_F_EOF; 2355 return len; 2356 } 2357 PERL_ASYNC_CHECK(); 2358 } 2359 } 2360 2361 SSize_t 2362 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2363 { 2364 int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2365 while (1) { 2366 SSize_t len = PerlLIO_write(fd, vbuf, count); 2367 if (len >= 0 || errno != EINTR) { 2368 if (len < 0) 2369 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 2370 return len; 2371 } 2372 PERL_ASYNC_CHECK(); 2373 } 2374 } 2375 2376 IV 2377 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 2378 { 2379 Off_t new = 2380 PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence); 2381 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 2382 return (new == (Off_t) - 1) ? -1 : 0; 2383 } 2384 2385 Off_t 2386 PerlIOUnix_tell(pTHX_ PerlIO *f) 2387 { 2388 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR); 2389 } 2390 2391 2392 IV 2393 PerlIOUnix_close(pTHX_ PerlIO *f) 2394 { 2395 int fd = PerlIOSelf(f, PerlIOUnix)->fd; 2396 int code = 0; 2397 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { 2398 if (PerlIOUnix_refcnt_dec(fd) > 0) { 2399 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2400 return 0; 2401 } 2402 } 2403 else { 2404 SETERRNO(EBADF,SS$_IVCHAN); 2405 return -1; 2406 } 2407 while (PerlLIO_close(fd) != 0) { 2408 if (errno != EINTR) { 2409 code = -1; 2410 break; 2411 } 2412 PERL_ASYNC_CHECK(); 2413 } 2414 if (code == 0) { 2415 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; 2416 } 2417 return code; 2418 } 2419 2420 PerlIO_funcs PerlIO_unix = { 2421 sizeof(PerlIO_funcs), 2422 "unix", 2423 sizeof(PerlIOUnix), 2424 PERLIO_K_RAW, 2425 PerlIOUnix_pushed, 2426 PerlIOBase_popped, 2427 PerlIOUnix_open, 2428 PerlIOBase_binmode, /* binmode */ 2429 NULL, 2430 PerlIOUnix_fileno, 2431 PerlIOUnix_dup, 2432 PerlIOUnix_read, 2433 PerlIOBase_unread, 2434 PerlIOUnix_write, 2435 PerlIOUnix_seek, 2436 PerlIOUnix_tell, 2437 PerlIOUnix_close, 2438 PerlIOBase_noop_ok, /* flush */ 2439 PerlIOBase_noop_fail, /* fill */ 2440 PerlIOBase_eof, 2441 PerlIOBase_error, 2442 PerlIOBase_clearerr, 2443 PerlIOBase_setlinebuf, 2444 NULL, /* get_base */ 2445 NULL, /* get_bufsiz */ 2446 NULL, /* get_ptr */ 2447 NULL, /* get_cnt */ 2448 NULL, /* set_ptrcnt */ 2449 }; 2450 2451 /*--------------------------------------------------------------------------------------*/ 2452 /* 2453 * stdio as a layer 2454 */ 2455 2456 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE) 2457 /* perl5.8 - This ensures the last minute VMS ungetc fix is not 2458 broken by the last second glibc 2.3 fix 2459 */ 2460 #define STDIO_BUFFER_WRITABLE 2461 #endif 2462 2463 2464 typedef struct { 2465 struct _PerlIO base; 2466 FILE *stdio; /* The stream */ 2467 } PerlIOStdio; 2468 2469 IV 2470 PerlIOStdio_fileno(pTHX_ PerlIO *f) 2471 { 2472 FILE *s; 2473 if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) { 2474 return PerlSIO_fileno(s); 2475 } 2476 errno = EBADF; 2477 return -1; 2478 } 2479 2480 char * 2481 PerlIOStdio_mode(const char *mode, char *tmode) 2482 { 2483 char *ret = tmode; 2484 while (*mode) { 2485 *tmode++ = *mode++; 2486 } 2487 #ifdef PERLIO_USING_CRLF 2488 *tmode++ = 'b'; 2489 #endif 2490 *tmode = '\0'; 2491 return ret; 2492 } 2493 2494 IV 2495 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 2496 { 2497 PerlIO *n; 2498 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { 2499 PerlIO_funcs *toptab = PerlIOBase(n)->tab; 2500 if (toptab == tab) { 2501 /* Top is already stdio - pop self (duplicate) and use original */ 2502 PerlIO_pop(aTHX_ f); 2503 return 0; 2504 } else { 2505 int fd = PerlIO_fileno(n); 2506 char tmode[8]; 2507 FILE *stdio; 2508 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, 2509 mode = PerlIOStdio_mode(mode, tmode)))) { 2510 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2511 /* We never call down so do any pending stuff now */ 2512 PerlIO_flush(PerlIONext(f)); 2513 } 2514 else { 2515 return -1; 2516 } 2517 } 2518 } 2519 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 2520 } 2521 2522 2523 PerlIO * 2524 PerlIO_importFILE(FILE *stdio, const char *mode) 2525 { 2526 dTHX; 2527 PerlIO *f = NULL; 2528 if (stdio) { 2529 PerlIOStdio *s; 2530 if (!mode || !*mode) { 2531 /* We need to probe to see how we can open the stream 2532 so start with read/write and then try write and read 2533 we dup() so that we can fclose without loosing the fd. 2534 2535 Note that the errno value set by a failing fdopen 2536 varies between stdio implementations. 2537 */ 2538 int fd = PerlLIO_dup(fileno(stdio)); 2539 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+")); 2540 if (!f2) { 2541 f2 = PerlSIO_fdopen(fd, (mode = "w")); 2542 } 2543 if (!f2) { 2544 f2 = PerlSIO_fdopen(fd, (mode = "r")); 2545 } 2546 if (!f2) { 2547 /* Don't seem to be able to open */ 2548 PerlLIO_close(fd); 2549 return f; 2550 } 2551 fclose(f2); 2552 } 2553 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio, mode, Nullsv))) { 2554 s = PerlIOSelf(f, PerlIOStdio); 2555 s->stdio = stdio; 2556 } 2557 } 2558 return f; 2559 } 2560 2561 PerlIO * 2562 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 2563 IV n, const char *mode, int fd, int imode, 2564 int perm, PerlIO *f, int narg, SV **args) 2565 { 2566 char tmode[8]; 2567 if (PerlIOValid(f)) { 2568 char *path = SvPV_nolen(*args); 2569 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); 2570 FILE *stdio; 2571 PerlIOUnix_refcnt_dec(fileno(s->stdio)); 2572 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)), 2573 s->stdio); 2574 if (!s->stdio) 2575 return NULL; 2576 s->stdio = stdio; 2577 PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2578 return f; 2579 } 2580 else { 2581 if (narg > 0) { 2582 char *path = SvPV_nolen(*args); 2583 if (*mode == '#') { 2584 mode++; 2585 fd = PerlLIO_open3(path, imode, perm); 2586 } 2587 else { 2588 FILE *stdio = PerlSIO_fopen(path, mode); 2589 if (stdio) { 2590 PerlIOStdio *s; 2591 if (!f) { 2592 f = PerlIO_allocate(aTHX); 2593 } 2594 if ((f = PerlIO_push(aTHX_ f, self, 2595 (mode = PerlIOStdio_mode(mode, tmode)), 2596 PerlIOArg))) { 2597 s = PerlIOSelf(f, PerlIOStdio); 2598 s->stdio = stdio; 2599 PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2600 } 2601 return f; 2602 } 2603 else { 2604 return NULL; 2605 } 2606 } 2607 } 2608 if (fd >= 0) { 2609 FILE *stdio = NULL; 2610 int init = 0; 2611 if (*mode == 'I') { 2612 init = 1; 2613 mode++; 2614 } 2615 if (init) { 2616 switch (fd) { 2617 case 0: 2618 stdio = PerlSIO_stdin; 2619 break; 2620 case 1: 2621 stdio = PerlSIO_stdout; 2622 break; 2623 case 2: 2624 stdio = PerlSIO_stderr; 2625 break; 2626 } 2627 } 2628 else { 2629 stdio = PerlSIO_fdopen(fd, mode = 2630 PerlIOStdio_mode(mode, tmode)); 2631 } 2632 if (stdio) { 2633 PerlIOStdio *s; 2634 if (!f) { 2635 f = PerlIO_allocate(aTHX); 2636 } 2637 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { 2638 s = PerlIOSelf(f, PerlIOStdio); 2639 s->stdio = stdio; 2640 PerlIOUnix_refcnt_inc(fileno(s->stdio)); 2641 } 2642 return f; 2643 } 2644 } 2645 } 2646 return NULL; 2647 } 2648 2649 PerlIO * 2650 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 2651 { 2652 /* This assumes no layers underneath - which is what 2653 happens, but is not how I remember it. NI-S 2001/10/16 2654 */ 2655 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { 2656 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; 2657 if (flags & PERLIO_DUP_FD) { 2658 int fd = PerlLIO_dup(fileno(stdio)); 2659 if (fd >= 0) { 2660 char mode[8]; 2661 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); 2662 } 2663 else { 2664 /* FIXME: To avoid messy error recovery if dup fails 2665 re-use the existing stdio as though flag was not set 2666 */ 2667 } 2668 } 2669 PerlIOSelf(f, PerlIOStdio)->stdio = stdio; 2670 PerlIOUnix_refcnt_inc(fileno(stdio)); 2671 } 2672 return f; 2673 } 2674 2675 IV 2676 PerlIOStdio_close(pTHX_ PerlIO *f) 2677 { 2678 #ifdef SOCKS5_VERSION_NAME 2679 int optval; 2680 Sock_size_t optlen = sizeof(int); 2681 #endif 2682 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2683 if (!stdio) { 2684 errno = EBADF; 2685 return -1; 2686 } 2687 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) { 2688 /* Do not close it but do flush any buffers */ 2689 return PerlIO_flush(f); 2690 } 2691 return ( 2692 #ifdef SOCKS5_VERSION_NAME 2693 (getsockopt 2694 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval, 2695 &optlen) < 2696 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f)) 2697 #else 2698 PerlSIO_fclose(stdio) 2699 #endif 2700 ); 2701 2702 } 2703 2704 2705 2706 SSize_t 2707 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 2708 { 2709 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; 2710 SSize_t got = 0; 2711 if (count == 1) { 2712 STDCHAR *buf = (STDCHAR *) vbuf; 2713 /* 2714 * Perl is expecting PerlIO_getc() to fill the buffer Linux's 2715 * stdio does not do that for fread() 2716 */ 2717 int ch = PerlSIO_fgetc(s); 2718 if (ch != EOF) { 2719 *buf = ch; 2720 got = 1; 2721 } 2722 } 2723 else 2724 got = PerlSIO_fread(vbuf, 1, count, s); 2725 return got; 2726 } 2727 2728 SSize_t 2729 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2730 { 2731 SSize_t unread = 0; 2732 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio; 2733 2734 #ifdef STDIO_BUFFER_WRITABLE 2735 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 2736 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 2737 STDCHAR *base = PerlIO_get_base(f); 2738 SSize_t cnt = PerlIO_get_cnt(f); 2739 STDCHAR *ptr = PerlIO_get_ptr(f); 2740 SSize_t avail = ptr - base; 2741 if (avail > 0) { 2742 if (avail > count) { 2743 avail = count; 2744 } 2745 ptr -= avail; 2746 Move(buf-avail,ptr,avail,STDCHAR); 2747 count -= avail; 2748 unread += avail; 2749 PerlIO_set_ptrcnt(f,ptr,cnt+avail); 2750 if (PerlSIO_feof(s) && unread >= 0) 2751 PerlSIO_clearerr(s); 2752 } 2753 } 2754 else 2755 #endif 2756 if (PerlIO_has_cntptr(f)) { 2757 /* We can get pointer to buffer but not its base 2758 Do ungetc() but check chars are ending up in the 2759 buffer 2760 */ 2761 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); 2762 STDCHAR *buf = ((STDCHAR *) vbuf) + count; 2763 while (count > 0) { 2764 int ch = *--buf & 0xFF; 2765 if (ungetc(ch,s) != ch) { 2766 /* ungetc did not work */ 2767 break; 2768 } 2769 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { 2770 /* Did not change pointer as expected */ 2771 fgetc(s); /* get char back again */ 2772 break; 2773 } 2774 /* It worked ! */ 2775 count--; 2776 unread++; 2777 } 2778 } 2779 2780 if (count > 0) { 2781 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 2782 } 2783 return unread; 2784 } 2785 2786 SSize_t 2787 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 2788 { 2789 return PerlSIO_fwrite(vbuf, 1, count, 2790 PerlIOSelf(f, PerlIOStdio)->stdio); 2791 } 2792 2793 IV 2794 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 2795 { 2796 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2797 return PerlSIO_fseek(stdio, offset, whence); 2798 } 2799 2800 Off_t 2801 PerlIOStdio_tell(pTHX_ PerlIO *f) 2802 { 2803 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2804 return PerlSIO_ftell(stdio); 2805 } 2806 2807 IV 2808 PerlIOStdio_flush(pTHX_ PerlIO *f) 2809 { 2810 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2811 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { 2812 return PerlSIO_fflush(stdio); 2813 } 2814 else { 2815 #if 0 2816 /* 2817 * FIXME: This discards ungetc() and pre-read stuff which is not 2818 * right if this is just a "sync" from a layer above Suspect right 2819 * design is to do _this_ but not have layer above flush this 2820 * layer read-to-read 2821 */ 2822 /* 2823 * Not writeable - sync by attempting a seek 2824 */ 2825 int err = errno; 2826 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) 2827 errno = err; 2828 #endif 2829 } 2830 return 0; 2831 } 2832 2833 IV 2834 PerlIOStdio_eof(pTHX_ PerlIO *f) 2835 { 2836 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio); 2837 } 2838 2839 IV 2840 PerlIOStdio_error(pTHX_ PerlIO *f) 2841 { 2842 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio); 2843 } 2844 2845 void 2846 PerlIOStdio_clearerr(pTHX_ PerlIO *f) 2847 { 2848 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio); 2849 } 2850 2851 void 2852 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f) 2853 { 2854 #ifdef HAS_SETLINEBUF 2855 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio); 2856 #else 2857 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0); 2858 #endif 2859 } 2860 2861 #ifdef FILE_base 2862 STDCHAR * 2863 PerlIOStdio_get_base(pTHX_ PerlIO *f) 2864 { 2865 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2866 return (STDCHAR*)PerlSIO_get_base(stdio); 2867 } 2868 2869 Size_t 2870 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) 2871 { 2872 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2873 return PerlSIO_get_bufsiz(stdio); 2874 } 2875 #endif 2876 2877 #ifdef USE_STDIO_PTR 2878 STDCHAR * 2879 PerlIOStdio_get_ptr(pTHX_ PerlIO *f) 2880 { 2881 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2882 return (STDCHAR*)PerlSIO_get_ptr(stdio); 2883 } 2884 2885 SSize_t 2886 PerlIOStdio_get_cnt(pTHX_ PerlIO *f) 2887 { 2888 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2889 return PerlSIO_get_cnt(stdio); 2890 } 2891 2892 void 2893 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 2894 { 2895 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2896 if (ptr != NULL) { 2897 #ifdef STDIO_PTR_LVALUE 2898 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */ 2899 #ifdef STDIO_PTR_LVAL_SETS_CNT 2900 if (PerlSIO_get_cnt(stdio) != (cnt)) { 2901 assert(PerlSIO_get_cnt(stdio) == (cnt)); 2902 } 2903 #endif 2904 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) 2905 /* 2906 * Setting ptr _does_ change cnt - we are done 2907 */ 2908 return; 2909 #endif 2910 #else /* STDIO_PTR_LVALUE */ 2911 PerlProc_abort(); 2912 #endif /* STDIO_PTR_LVALUE */ 2913 } 2914 /* 2915 * Now (or only) set cnt 2916 */ 2917 #ifdef STDIO_CNT_LVALUE 2918 PerlSIO_set_cnt(stdio, cnt); 2919 #else /* STDIO_CNT_LVALUE */ 2920 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) 2921 PerlSIO_set_ptr(stdio, 2922 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - 2923 cnt)); 2924 #else /* STDIO_PTR_LVAL_SETS_CNT */ 2925 PerlProc_abort(); 2926 #endif /* STDIO_PTR_LVAL_SETS_CNT */ 2927 #endif /* STDIO_CNT_LVALUE */ 2928 } 2929 2930 2931 #endif 2932 2933 IV 2934 PerlIOStdio_fill(pTHX_ PerlIO *f) 2935 { 2936 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 2937 int c; 2938 /* 2939 * fflush()ing read-only streams can cause trouble on some stdio-s 2940 */ 2941 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { 2942 if (PerlSIO_fflush(stdio) != 0) 2943 return EOF; 2944 } 2945 c = PerlSIO_fgetc(stdio); 2946 if (c == EOF) 2947 return EOF; 2948 2949 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) 2950 2951 #ifdef STDIO_BUFFER_WRITABLE 2952 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { 2953 /* Fake ungetc() to the real buffer in case system's ungetc 2954 goes elsewhere 2955 */ 2956 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); 2957 SSize_t cnt = PerlSIO_get_cnt(stdio); 2958 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); 2959 if (ptr == base+1) { 2960 *--ptr = (STDCHAR) c; 2961 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); 2962 if (PerlSIO_feof(stdio)) 2963 PerlSIO_clearerr(stdio); 2964 return 0; 2965 } 2966 } 2967 else 2968 #endif 2969 if (PerlIO_has_cntptr(f)) { 2970 STDCHAR ch = c; 2971 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { 2972 return 0; 2973 } 2974 } 2975 #endif 2976 2977 #if defined(VMS) 2978 /* An ungetc()d char is handled separately from the regular 2979 * buffer, so we stuff it in the buffer ourselves. 2980 * Should never get called as should hit code above 2981 */ 2982 *(--((*stdio)->_ptr)) = (unsigned char) c; 2983 (*stdio)->_cnt++; 2984 #else 2985 /* If buffer snoop scheme above fails fall back to 2986 using ungetc(). 2987 */ 2988 if (PerlSIO_ungetc(c, stdio) != c) 2989 return EOF; 2990 #endif 2991 return 0; 2992 } 2993 2994 2995 2996 PerlIO_funcs PerlIO_stdio = { 2997 sizeof(PerlIO_funcs), 2998 "stdio", 2999 sizeof(PerlIOStdio), 3000 PERLIO_K_BUFFERED|PERLIO_K_RAW, 3001 PerlIOStdio_pushed, 3002 PerlIOBase_popped, 3003 PerlIOStdio_open, 3004 PerlIOBase_binmode, /* binmode */ 3005 NULL, 3006 PerlIOStdio_fileno, 3007 PerlIOStdio_dup, 3008 PerlIOStdio_read, 3009 PerlIOStdio_unread, 3010 PerlIOStdio_write, 3011 PerlIOStdio_seek, 3012 PerlIOStdio_tell, 3013 PerlIOStdio_close, 3014 PerlIOStdio_flush, 3015 PerlIOStdio_fill, 3016 PerlIOStdio_eof, 3017 PerlIOStdio_error, 3018 PerlIOStdio_clearerr, 3019 PerlIOStdio_setlinebuf, 3020 #ifdef FILE_base 3021 PerlIOStdio_get_base, 3022 PerlIOStdio_get_bufsiz, 3023 #else 3024 NULL, 3025 NULL, 3026 #endif 3027 #ifdef USE_STDIO_PTR 3028 PerlIOStdio_get_ptr, 3029 PerlIOStdio_get_cnt, 3030 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) 3031 PerlIOStdio_set_ptrcnt 3032 #else /* STDIO_PTR_LVALUE */ 3033 NULL 3034 #endif /* STDIO_PTR_LVALUE */ 3035 #else /* USE_STDIO_PTR */ 3036 NULL, 3037 NULL, 3038 NULL 3039 #endif /* USE_STDIO_PTR */ 3040 }; 3041 3042 /* Note that calls to PerlIO_exportFILE() are reversed using 3043 * PerlIO_releaseFILE(), not importFILE. */ 3044 FILE * 3045 PerlIO_exportFILE(PerlIO * f, const char *mode) 3046 { 3047 dTHX; 3048 FILE *stdio = NULL; 3049 if (PerlIOValid(f)) { 3050 char buf[8]; 3051 PerlIO_flush(f); 3052 if (!mode || !*mode) { 3053 mode = PerlIO_modestr(f, buf); 3054 } 3055 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); 3056 if (stdio) { 3057 PerlIOl *l = *f; 3058 /* De-link any lower layers so new :stdio sticks */ 3059 *f = NULL; 3060 if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) { 3061 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); 3062 s->stdio = stdio; 3063 /* Link previous lower layers under new one */ 3064 *PerlIONext(f) = l; 3065 } 3066 else { 3067 /* restore layers list */ 3068 *f = l; 3069 } 3070 } 3071 } 3072 return stdio; 3073 } 3074 3075 3076 FILE * 3077 PerlIO_findFILE(PerlIO *f) 3078 { 3079 PerlIOl *l = *f; 3080 while (l) { 3081 if (l->tab == &PerlIO_stdio) { 3082 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3083 return s->stdio; 3084 } 3085 l = *PerlIONext(&l); 3086 } 3087 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ 3088 return PerlIO_exportFILE(f, Nullch); 3089 } 3090 3091 /* Use this to reverse PerlIO_exportFILE calls. */ 3092 void 3093 PerlIO_releaseFILE(PerlIO *p, FILE *f) 3094 { 3095 PerlIOl *l; 3096 while ((l = *p)) { 3097 if (l->tab == &PerlIO_stdio) { 3098 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); 3099 if (s->stdio == f) { 3100 dTHX; 3101 PerlIO_pop(aTHX_ p); 3102 return; 3103 } 3104 } 3105 p = PerlIONext(p); 3106 } 3107 return; 3108 } 3109 3110 /*--------------------------------------------------------------------------------------*/ 3111 /* 3112 * perlio buffer layer 3113 */ 3114 3115 IV 3116 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3117 { 3118 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3119 int fd = PerlIO_fileno(f); 3120 if (fd >= 0 && PerlLIO_isatty(fd)) { 3121 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; 3122 } 3123 if (*PerlIONext(f)) { 3124 Off_t posn = PerlIO_tell(PerlIONext(f)); 3125 if (posn != (Off_t) - 1) { 3126 b->posn = posn; 3127 } 3128 } 3129 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 3130 } 3131 3132 PerlIO * 3133 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 3134 IV n, const char *mode, int fd, int imode, int perm, 3135 PerlIO *f, int narg, SV **args) 3136 { 3137 if (PerlIOValid(f)) { 3138 PerlIO *next = PerlIONext(f); 3139 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); 3140 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3141 next, narg, args); 3142 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { 3143 return NULL; 3144 } 3145 } 3146 else { 3147 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); 3148 int init = 0; 3149 if (*mode == 'I') { 3150 init = 1; 3151 /* 3152 * mode++; 3153 */ 3154 } 3155 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, 3156 f, narg, args); 3157 if (f) { 3158 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { 3159 /* 3160 * if push fails during open, open fails. close will pop us. 3161 */ 3162 PerlIO_close (f); 3163 return NULL; 3164 } else { 3165 fd = PerlIO_fileno(f); 3166 if (init && fd == 2) { 3167 /* 3168 * Initial stderr is unbuffered 3169 */ 3170 PerlIOBase(f)->flags |= PERLIO_F_UNBUF; 3171 } 3172 #ifdef PERLIO_USING_CRLF 3173 # ifdef PERLIO_IS_BINMODE_FD 3174 if (PERLIO_IS_BINMODE_FD(fd)) 3175 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch); 3176 else 3177 # endif 3178 /* 3179 * do something about failing setmode()? --jhi 3180 */ 3181 PerlLIO_setmode(fd, O_BINARY); 3182 #endif 3183 } 3184 } 3185 } 3186 return f; 3187 } 3188 3189 /* 3190 * This "flush" is akin to sfio's sync in that it handles files in either 3191 * read or write state 3192 */ 3193 IV 3194 PerlIOBuf_flush(pTHX_ PerlIO *f) 3195 { 3196 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3197 int code = 0; 3198 PerlIO *n = PerlIONext(f); 3199 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { 3200 /* 3201 * write() the buffer 3202 */ 3203 STDCHAR *buf = b->buf; 3204 STDCHAR *p = buf; 3205 while (p < b->ptr) { 3206 SSize_t count = PerlIO_write(n, p, b->ptr - p); 3207 if (count > 0) { 3208 p += count; 3209 } 3210 else if (count < 0 || PerlIO_error(n)) { 3211 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3212 code = -1; 3213 break; 3214 } 3215 } 3216 b->posn += (p - buf); 3217 } 3218 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3219 STDCHAR *buf = PerlIO_get_base(f); 3220 /* 3221 * Note position change 3222 */ 3223 b->posn += (b->ptr - buf); 3224 if (b->ptr < b->end) { 3225 /* We did not consume all of it - try and seek downstream to 3226 our logical position 3227 */ 3228 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { 3229 /* Reload n as some layers may pop themselves on seek */ 3230 b->posn = PerlIO_tell(n = PerlIONext(f)); 3231 } 3232 else { 3233 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read 3234 data is lost for good - so return saying "ok" having undone 3235 the position adjust 3236 */ 3237 b->posn -= (b->ptr - buf); 3238 return code; 3239 } 3240 } 3241 } 3242 b->ptr = b->end = b->buf; 3243 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 3244 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ 3245 if (PerlIOValid(n) && PerlIO_flush(n) != 0) 3246 code = -1; 3247 return code; 3248 } 3249 3250 IV 3251 PerlIOBuf_fill(pTHX_ PerlIO *f) 3252 { 3253 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3254 PerlIO *n = PerlIONext(f); 3255 SSize_t avail; 3256 /* 3257 * Down-stream flush is defined not to loose read data so is harmless. 3258 * we would not normally be fill'ing if there was data left in anycase. 3259 */ 3260 if (PerlIO_flush(f) != 0) 3261 return -1; 3262 if (PerlIOBase(f)->flags & PERLIO_F_TTY) 3263 PerlIOBase_flush_linebuf(aTHX); 3264 3265 if (!b->buf) 3266 PerlIO_get_base(f); /* allocate via vtable */ 3267 3268 b->ptr = b->end = b->buf; 3269 3270 if (!PerlIOValid(n)) { 3271 PerlIOBase(f)->flags |= PERLIO_F_EOF; 3272 return -1; 3273 } 3274 3275 if (PerlIO_fast_gets(n)) { 3276 /* 3277 * Layer below is also buffered. We do _NOT_ want to call its 3278 * ->Read() because that will loop till it gets what we asked for 3279 * which may hang on a pipe etc. Instead take anything it has to 3280 * hand, or ask it to fill _once_. 3281 */ 3282 avail = PerlIO_get_cnt(n); 3283 if (avail <= 0) { 3284 avail = PerlIO_fill(n); 3285 if (avail == 0) 3286 avail = PerlIO_get_cnt(n); 3287 else { 3288 if (!PerlIO_error(n) && PerlIO_eof(n)) 3289 avail = 0; 3290 } 3291 } 3292 if (avail > 0) { 3293 STDCHAR *ptr = PerlIO_get_ptr(n); 3294 SSize_t cnt = avail; 3295 if (avail > (SSize_t)b->bufsiz) 3296 avail = b->bufsiz; 3297 Copy(ptr, b->buf, avail, STDCHAR); 3298 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); 3299 } 3300 } 3301 else { 3302 avail = PerlIO_read(n, b->ptr, b->bufsiz); 3303 } 3304 if (avail <= 0) { 3305 if (avail == 0) 3306 PerlIOBase(f)->flags |= PERLIO_F_EOF; 3307 else 3308 PerlIOBase(f)->flags |= PERLIO_F_ERROR; 3309 return -1; 3310 } 3311 b->end = b->buf + avail; 3312 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 3313 return 0; 3314 } 3315 3316 SSize_t 3317 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 3318 { 3319 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3320 if (PerlIOValid(f)) { 3321 if (!b->ptr) 3322 PerlIO_get_base(f); 3323 return PerlIOBase_read(aTHX_ f, vbuf, count); 3324 } 3325 return 0; 3326 } 3327 3328 SSize_t 3329 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3330 { 3331 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 3332 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3333 SSize_t unread = 0; 3334 SSize_t avail; 3335 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 3336 PerlIO_flush(f); 3337 if (!b->buf) 3338 PerlIO_get_base(f); 3339 if (b->buf) { 3340 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3341 /* 3342 * Buffer is already a read buffer, we can overwrite any chars 3343 * which have been read back to buffer start 3344 */ 3345 avail = (b->ptr - b->buf); 3346 } 3347 else { 3348 /* 3349 * Buffer is idle, set it up so whole buffer is available for 3350 * unread 3351 */ 3352 avail = b->bufsiz; 3353 b->end = b->buf + avail; 3354 b->ptr = b->end; 3355 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 3356 /* 3357 * Buffer extends _back_ from where we are now 3358 */ 3359 b->posn -= b->bufsiz; 3360 } 3361 if (avail > (SSize_t) count) { 3362 /* 3363 * If we have space for more than count, just move count 3364 */ 3365 avail = count; 3366 } 3367 if (avail > 0) { 3368 b->ptr -= avail; 3369 buf -= avail; 3370 /* 3371 * In simple stdio-like ungetc() case chars will be already 3372 * there 3373 */ 3374 if (buf != b->ptr) { 3375 Copy(buf, b->ptr, avail, STDCHAR); 3376 } 3377 count -= avail; 3378 unread += avail; 3379 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 3380 } 3381 } 3382 if (count > 0) { 3383 unread += PerlIOBase_unread(aTHX_ f, vbuf, count); 3384 } 3385 return unread; 3386 } 3387 3388 SSize_t 3389 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3390 { 3391 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3392 const STDCHAR *buf = (const STDCHAR *) vbuf; 3393 Size_t written = 0; 3394 if (!b->buf) 3395 PerlIO_get_base(f); 3396 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 3397 return 0; 3398 while (count > 0) { 3399 SSize_t avail = b->bufsiz - (b->ptr - b->buf); 3400 if ((SSize_t) count < avail) 3401 avail = count; 3402 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 3403 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 3404 while (avail > 0) { 3405 int ch = *buf++; 3406 *(b->ptr)++ = ch; 3407 count--; 3408 avail--; 3409 written++; 3410 if (ch == '\n') { 3411 PerlIO_flush(f); 3412 break; 3413 } 3414 } 3415 } 3416 else { 3417 if (avail) { 3418 Copy(buf, b->ptr, avail, STDCHAR); 3419 count -= avail; 3420 buf += avail; 3421 written += avail; 3422 b->ptr += avail; 3423 } 3424 } 3425 if (b->ptr >= (b->buf + b->bufsiz)) 3426 PerlIO_flush(f); 3427 } 3428 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 3429 PerlIO_flush(f); 3430 return written; 3431 } 3432 3433 IV 3434 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 3435 { 3436 IV code; 3437 if ((code = PerlIO_flush(f)) == 0) { 3438 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3439 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 3440 code = PerlIO_seek(PerlIONext(f), offset, whence); 3441 if (code == 0) { 3442 b->posn = PerlIO_tell(PerlIONext(f)); 3443 } 3444 } 3445 return code; 3446 } 3447 3448 Off_t 3449 PerlIOBuf_tell(pTHX_ PerlIO *f) 3450 { 3451 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3452 /* 3453 * b->posn is file position where b->buf was read, or will be written 3454 */ 3455 Off_t posn = b->posn; 3456 if (b->buf) { 3457 /* 3458 * If buffer is valid adjust position by amount in buffer 3459 */ 3460 posn += (b->ptr - b->buf); 3461 } 3462 return posn; 3463 } 3464 3465 IV 3466 PerlIOBuf_popped(pTHX_ PerlIO *f) 3467 { 3468 IV code = PerlIOBase_popped(aTHX_ f); 3469 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3470 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 3471 Safefree(b->buf); 3472 } 3473 b->buf = NULL; 3474 b->ptr = b->end = b->buf; 3475 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 3476 return code; 3477 } 3478 3479 IV 3480 PerlIOBuf_close(pTHX_ PerlIO *f) 3481 { 3482 IV code = PerlIOBase_close(aTHX_ f); 3483 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3484 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 3485 Safefree(b->buf); 3486 } 3487 b->buf = NULL; 3488 b->ptr = b->end = b->buf; 3489 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 3490 return code; 3491 } 3492 3493 STDCHAR * 3494 PerlIOBuf_get_ptr(pTHX_ PerlIO *f) 3495 { 3496 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3497 if (!b->buf) 3498 PerlIO_get_base(f); 3499 return b->ptr; 3500 } 3501 3502 SSize_t 3503 PerlIOBuf_get_cnt(pTHX_ PerlIO *f) 3504 { 3505 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3506 if (!b->buf) 3507 PerlIO_get_base(f); 3508 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) 3509 return (b->end - b->ptr); 3510 return 0; 3511 } 3512 3513 STDCHAR * 3514 PerlIOBuf_get_base(pTHX_ PerlIO *f) 3515 { 3516 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3517 if (!b->buf) { 3518 if (!b->bufsiz) 3519 b->bufsiz = 4096; 3520 b->buf = 3521 Newz('B',b->buf,b->bufsiz, STDCHAR); 3522 if (!b->buf) { 3523 b->buf = (STDCHAR *) & b->oneword; 3524 b->bufsiz = sizeof(b->oneword); 3525 } 3526 b->ptr = b->buf; 3527 b->end = b->ptr; 3528 } 3529 return b->buf; 3530 } 3531 3532 Size_t 3533 PerlIOBuf_bufsiz(pTHX_ PerlIO *f) 3534 { 3535 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3536 if (!b->buf) 3537 PerlIO_get_base(f); 3538 return (b->end - b->buf); 3539 } 3540 3541 void 3542 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3543 { 3544 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3545 if (!b->buf) 3546 PerlIO_get_base(f); 3547 b->ptr = ptr; 3548 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) { 3549 assert(PerlIO_get_cnt(f) == cnt); 3550 assert(b->ptr >= b->buf); 3551 } 3552 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 3553 } 3554 3555 PerlIO * 3556 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 3557 { 3558 return PerlIOBase_dup(aTHX_ f, o, param, flags); 3559 } 3560 3561 3562 3563 PerlIO_funcs PerlIO_perlio = { 3564 sizeof(PerlIO_funcs), 3565 "perlio", 3566 sizeof(PerlIOBuf), 3567 PERLIO_K_BUFFERED|PERLIO_K_RAW, 3568 PerlIOBuf_pushed, 3569 PerlIOBuf_popped, 3570 PerlIOBuf_open, 3571 PerlIOBase_binmode, /* binmode */ 3572 NULL, 3573 PerlIOBase_fileno, 3574 PerlIOBuf_dup, 3575 PerlIOBuf_read, 3576 PerlIOBuf_unread, 3577 PerlIOBuf_write, 3578 PerlIOBuf_seek, 3579 PerlIOBuf_tell, 3580 PerlIOBuf_close, 3581 PerlIOBuf_flush, 3582 PerlIOBuf_fill, 3583 PerlIOBase_eof, 3584 PerlIOBase_error, 3585 PerlIOBase_clearerr, 3586 PerlIOBase_setlinebuf, 3587 PerlIOBuf_get_base, 3588 PerlIOBuf_bufsiz, 3589 PerlIOBuf_get_ptr, 3590 PerlIOBuf_get_cnt, 3591 PerlIOBuf_set_ptrcnt, 3592 }; 3593 3594 /*--------------------------------------------------------------------------------------*/ 3595 /* 3596 * Temp layer to hold unread chars when cannot do it any other way 3597 */ 3598 3599 IV 3600 PerlIOPending_fill(pTHX_ PerlIO *f) 3601 { 3602 /* 3603 * Should never happen 3604 */ 3605 PerlIO_flush(f); 3606 return 0; 3607 } 3608 3609 IV 3610 PerlIOPending_close(pTHX_ PerlIO *f) 3611 { 3612 /* 3613 * A tad tricky - flush pops us, then we close new top 3614 */ 3615 PerlIO_flush(f); 3616 return PerlIO_close(f); 3617 } 3618 3619 IV 3620 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence) 3621 { 3622 /* 3623 * A tad tricky - flush pops us, then we seek new top 3624 */ 3625 PerlIO_flush(f); 3626 return PerlIO_seek(f, offset, whence); 3627 } 3628 3629 3630 IV 3631 PerlIOPending_flush(pTHX_ PerlIO *f) 3632 { 3633 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3634 if (b->buf && b->buf != (STDCHAR *) & b->oneword) { 3635 Safefree(b->buf); 3636 b->buf = NULL; 3637 } 3638 PerlIO_pop(aTHX_ f); 3639 return 0; 3640 } 3641 3642 void 3643 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3644 { 3645 if (cnt <= 0) { 3646 PerlIO_flush(f); 3647 } 3648 else { 3649 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); 3650 } 3651 } 3652 3653 IV 3654 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3655 { 3656 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); 3657 PerlIOl *l = PerlIOBase(f); 3658 /* 3659 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() 3660 * etc. get muddled when it changes mid-string when we auto-pop. 3661 */ 3662 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | 3663 (PerlIOBase(PerlIONext(f))-> 3664 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); 3665 return code; 3666 } 3667 3668 SSize_t 3669 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) 3670 { 3671 SSize_t avail = PerlIO_get_cnt(f); 3672 SSize_t got = 0; 3673 if ((SSize_t)count < avail) 3674 avail = count; 3675 if (avail > 0) 3676 got = PerlIOBuf_read(aTHX_ f, vbuf, avail); 3677 if (got >= 0 && got < (SSize_t)count) { 3678 SSize_t more = 3679 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); 3680 if (more >= 0 || got == 0) 3681 got += more; 3682 } 3683 return got; 3684 } 3685 3686 PerlIO_funcs PerlIO_pending = { 3687 sizeof(PerlIO_funcs), 3688 "pending", 3689 sizeof(PerlIOBuf), 3690 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */ 3691 PerlIOPending_pushed, 3692 PerlIOBuf_popped, 3693 NULL, 3694 PerlIOBase_binmode, /* binmode */ 3695 NULL, 3696 PerlIOBase_fileno, 3697 PerlIOBuf_dup, 3698 PerlIOPending_read, 3699 PerlIOBuf_unread, 3700 PerlIOBuf_write, 3701 PerlIOPending_seek, 3702 PerlIOBuf_tell, 3703 PerlIOPending_close, 3704 PerlIOPending_flush, 3705 PerlIOPending_fill, 3706 PerlIOBase_eof, 3707 PerlIOBase_error, 3708 PerlIOBase_clearerr, 3709 PerlIOBase_setlinebuf, 3710 PerlIOBuf_get_base, 3711 PerlIOBuf_bufsiz, 3712 PerlIOBuf_get_ptr, 3713 PerlIOBuf_get_cnt, 3714 PerlIOPending_set_ptrcnt, 3715 }; 3716 3717 3718 3719 /*--------------------------------------------------------------------------------------*/ 3720 /* 3721 * crlf - translation On read translate CR,LF to "\n" we do this by 3722 * overriding ptr/cnt entries to hand back a line at a time and keeping a 3723 * record of which nl we "lied" about. On write translate "\n" to CR,LF 3724 */ 3725 3726 typedef struct { 3727 PerlIOBuf base; /* PerlIOBuf stuff */ 3728 STDCHAR *nl; /* Position of crlf we "lied" about in the 3729 * buffer */ 3730 } PerlIOCrlf; 3731 3732 IV 3733 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) 3734 { 3735 IV code; 3736 PerlIOBase(f)->flags |= PERLIO_F_CRLF; 3737 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); 3738 #if 0 3739 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", 3740 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", 3741 PerlIOBase(f)->flags); 3742 #endif 3743 return code; 3744 } 3745 3746 3747 SSize_t 3748 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3749 { 3750 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 3751 if (c->nl) { 3752 *(c->nl) = 0xd; 3753 c->nl = NULL; 3754 } 3755 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 3756 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 3757 else { 3758 const STDCHAR *buf = (const STDCHAR *) vbuf + count; 3759 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3760 SSize_t unread = 0; 3761 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 3762 PerlIO_flush(f); 3763 if (!b->buf) 3764 PerlIO_get_base(f); 3765 if (b->buf) { 3766 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { 3767 b->end = b->ptr = b->buf + b->bufsiz; 3768 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 3769 b->posn -= b->bufsiz; 3770 } 3771 while (count > 0 && b->ptr > b->buf) { 3772 int ch = *--buf; 3773 if (ch == '\n') { 3774 if (b->ptr - 2 >= b->buf) { 3775 *--(b->ptr) = 0xa; 3776 *--(b->ptr) = 0xd; 3777 unread++; 3778 count--; 3779 } 3780 else { 3781 buf++; 3782 break; 3783 } 3784 } 3785 else { 3786 *--(b->ptr) = ch; 3787 unread++; 3788 count--; 3789 } 3790 } 3791 } 3792 return unread; 3793 } 3794 } 3795 3796 SSize_t 3797 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) 3798 { 3799 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3800 if (!b->buf) 3801 PerlIO_get_base(f); 3802 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { 3803 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 3804 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) { 3805 STDCHAR *nl = (c->nl) ? c->nl : b->ptr; 3806 scan: 3807 while (nl < b->end && *nl != 0xd) 3808 nl++; 3809 if (nl < b->end && *nl == 0xd) { 3810 test: 3811 if (nl + 1 < b->end) { 3812 if (nl[1] == 0xa) { 3813 *nl = '\n'; 3814 c->nl = nl; 3815 } 3816 else { 3817 /* 3818 * Not CR,LF but just CR 3819 */ 3820 nl++; 3821 goto scan; 3822 } 3823 } 3824 else { 3825 /* 3826 * Blast - found CR as last char in buffer 3827 */ 3828 3829 if (b->ptr < nl) { 3830 /* 3831 * They may not care, defer work as long as 3832 * possible 3833 */ 3834 c->nl = nl; 3835 return (nl - b->ptr); 3836 } 3837 else { 3838 int code; 3839 b->ptr++; /* say we have read it as far as 3840 * flush() is concerned */ 3841 b->buf++; /* Leave space in front of buffer */ 3842 b->bufsiz--; /* Buffer is thus smaller */ 3843 code = PerlIO_fill(f); /* Fetch some more */ 3844 b->bufsiz++; /* Restore size for next time */ 3845 b->buf--; /* Point at space */ 3846 b->ptr = nl = b->buf; /* Which is what we hand 3847 * off */ 3848 b->posn--; /* Buffer starts here */ 3849 *nl = 0xd; /* Fill in the CR */ 3850 if (code == 0) 3851 goto test; /* fill() call worked */ 3852 /* 3853 * CR at EOF - just fall through 3854 */ 3855 /* Should we clear EOF though ??? */ 3856 } 3857 } 3858 } 3859 } 3860 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); 3861 } 3862 return 0; 3863 } 3864 3865 void 3866 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) 3867 { 3868 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3869 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 3870 if (!b->buf) 3871 PerlIO_get_base(f); 3872 if (!ptr) { 3873 if (c->nl) { 3874 ptr = c->nl + 1; 3875 if (ptr == b->end && *c->nl == 0xd) { 3876 /* Defered CR at end of buffer case - we lied about count */ 3877 ptr--; 3878 } 3879 } 3880 else { 3881 ptr = b->end; 3882 } 3883 ptr -= cnt; 3884 } 3885 else { 3886 #if 0 3887 /* 3888 * Test code - delete when it works ... 3889 */ 3890 IV flags = PerlIOBase(f)->flags; 3891 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; 3892 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) { 3893 /* Defered CR at end of buffer case - we lied about count */ 3894 chk--; 3895 } 3896 chk -= cnt; 3897 3898 if (ptr != chk ) { 3899 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf 3900 " nl=%p e=%p for %d", ptr, chk, flags, c->nl, 3901 b->end, cnt); 3902 } 3903 #endif 3904 } 3905 if (c->nl) { 3906 if (ptr > c->nl) { 3907 /* 3908 * They have taken what we lied about 3909 */ 3910 *(c->nl) = 0xd; 3911 c->nl = NULL; 3912 ptr++; 3913 } 3914 } 3915 b->ptr = ptr; 3916 PerlIOBase(f)->flags |= PERLIO_F_RDBUF; 3917 } 3918 3919 SSize_t 3920 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 3921 { 3922 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) 3923 return PerlIOBuf_write(aTHX_ f, vbuf, count); 3924 else { 3925 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 3926 const STDCHAR *buf = (const STDCHAR *) vbuf; 3927 const STDCHAR *ebuf = buf + count; 3928 if (!b->buf) 3929 PerlIO_get_base(f); 3930 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) 3931 return 0; 3932 while (buf < ebuf) { 3933 STDCHAR *eptr = b->buf + b->bufsiz; 3934 PerlIOBase(f)->flags |= PERLIO_F_WRBUF; 3935 while (buf < ebuf && b->ptr < eptr) { 3936 if (*buf == '\n') { 3937 if ((b->ptr + 2) > eptr) { 3938 /* 3939 * Not room for both 3940 */ 3941 PerlIO_flush(f); 3942 break; 3943 } 3944 else { 3945 *(b->ptr)++ = 0xd; /* CR */ 3946 *(b->ptr)++ = 0xa; /* LF */ 3947 buf++; 3948 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { 3949 PerlIO_flush(f); 3950 break; 3951 } 3952 } 3953 } 3954 else { 3955 int ch = *buf++; 3956 *(b->ptr)++ = ch; 3957 } 3958 if (b->ptr >= eptr) { 3959 PerlIO_flush(f); 3960 break; 3961 } 3962 } 3963 } 3964 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) 3965 PerlIO_flush(f); 3966 return (buf - (STDCHAR *) vbuf); 3967 } 3968 } 3969 3970 IV 3971 PerlIOCrlf_flush(pTHX_ PerlIO *f) 3972 { 3973 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf); 3974 if (c->nl) { 3975 *(c->nl) = 0xd; 3976 c->nl = NULL; 3977 } 3978 return PerlIOBuf_flush(aTHX_ f); 3979 } 3980 3981 IV 3982 PerlIOCrlf_binmode(pTHX_ PerlIO *f) 3983 { 3984 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { 3985 /* In text mode - flush any pending stuff and flip it */ 3986 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; 3987 #ifndef PERLIO_USING_CRLF 3988 /* CRLF is unusual case - if this is just the :crlf layer pop it */ 3989 if (PerlIOBase(f)->tab == &PerlIO_crlf) { 3990 PerlIO_pop(aTHX_ f); 3991 } 3992 #endif 3993 } 3994 return 0; 3995 } 3996 3997 PerlIO_funcs PerlIO_crlf = { 3998 sizeof(PerlIO_funcs), 3999 "crlf", 4000 sizeof(PerlIOCrlf), 4001 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW, 4002 PerlIOCrlf_pushed, 4003 PerlIOBuf_popped, /* popped */ 4004 PerlIOBuf_open, 4005 PerlIOCrlf_binmode, /* binmode */ 4006 NULL, 4007 PerlIOBase_fileno, 4008 PerlIOBuf_dup, 4009 PerlIOBuf_read, /* generic read works with ptr/cnt lies 4010 * ... */ 4011 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ 4012 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ 4013 PerlIOBuf_seek, 4014 PerlIOBuf_tell, 4015 PerlIOBuf_close, 4016 PerlIOCrlf_flush, 4017 PerlIOBuf_fill, 4018 PerlIOBase_eof, 4019 PerlIOBase_error, 4020 PerlIOBase_clearerr, 4021 PerlIOBase_setlinebuf, 4022 PerlIOBuf_get_base, 4023 PerlIOBuf_bufsiz, 4024 PerlIOBuf_get_ptr, 4025 PerlIOCrlf_get_cnt, 4026 PerlIOCrlf_set_ptrcnt, 4027 }; 4028 4029 #ifdef HAS_MMAP 4030 /*--------------------------------------------------------------------------------------*/ 4031 /* 4032 * mmap as "buffer" layer 4033 */ 4034 4035 typedef struct { 4036 PerlIOBuf base; /* PerlIOBuf stuff */ 4037 Mmap_t mptr; /* Mapped address */ 4038 Size_t len; /* mapped length */ 4039 STDCHAR *bbuf; /* malloced buffer if map fails */ 4040 } PerlIOMmap; 4041 4042 static size_t page_size = 0; 4043 4044 IV 4045 PerlIOMmap_map(pTHX_ PerlIO *f) 4046 { 4047 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4048 IV flags = PerlIOBase(f)->flags; 4049 IV code = 0; 4050 if (m->len) 4051 abort(); 4052 if (flags & PERLIO_F_CANREAD) { 4053 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4054 int fd = PerlIO_fileno(f); 4055 Stat_t st; 4056 code = Fstat(fd, &st); 4057 if (code == 0 && S_ISREG(st.st_mode)) { 4058 SSize_t len = st.st_size - b->posn; 4059 if (len > 0) { 4060 Off_t posn; 4061 if (!page_size) { 4062 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE)) 4063 { 4064 SETERRNO(0, SS$_NORMAL); 4065 # ifdef _SC_PAGESIZE 4066 page_size = sysconf(_SC_PAGESIZE); 4067 # else 4068 page_size = sysconf(_SC_PAGE_SIZE); 4069 # endif 4070 if ((long) page_size < 0) { 4071 if (errno) { 4072 SV *error = ERRSV; 4073 char *msg; 4074 STRLEN n_a; 4075 (void) SvUPGRADE(error, SVt_PV); 4076 msg = SvPVx(error, n_a); 4077 Perl_croak(aTHX_ "panic: sysconf: %s", 4078 msg); 4079 } 4080 else 4081 Perl_croak(aTHX_ 4082 "panic: sysconf: pagesize unknown"); 4083 } 4084 } 4085 #else 4086 # ifdef HAS_GETPAGESIZE 4087 page_size = getpagesize(); 4088 # else 4089 # if defined(I_SYS_PARAM) && defined(PAGESIZE) 4090 page_size = PAGESIZE; /* compiletime, bad */ 4091 # endif 4092 # endif 4093 #endif 4094 if ((IV) page_size <= 0) 4095 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, 4096 (IV) page_size); 4097 } 4098 if (b->posn < 0) { 4099 /* 4100 * This is a hack - should never happen - open should 4101 * have set it ! 4102 */ 4103 b->posn = PerlIO_tell(PerlIONext(f)); 4104 } 4105 posn = (b->posn / page_size) * page_size; 4106 len = st.st_size - posn; 4107 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); 4108 if (m->mptr && m->mptr != (Mmap_t) - 1) { 4109 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) 4110 madvise(m->mptr, len, MADV_SEQUENTIAL); 4111 #endif 4112 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) 4113 madvise(m->mptr, len, MADV_WILLNEED); 4114 #endif 4115 PerlIOBase(f)->flags = 4116 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; 4117 b->end = ((STDCHAR *) m->mptr) + len; 4118 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn); 4119 b->ptr = b->buf; 4120 m->len = len; 4121 } 4122 else { 4123 b->buf = NULL; 4124 } 4125 } 4126 else { 4127 PerlIOBase(f)->flags = 4128 flags | PERLIO_F_EOF | PERLIO_F_RDBUF; 4129 b->buf = NULL; 4130 b->ptr = b->end = b->ptr; 4131 code = -1; 4132 } 4133 } 4134 } 4135 return code; 4136 } 4137 4138 IV 4139 PerlIOMmap_unmap(pTHX_ PerlIO *f) 4140 { 4141 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4142 PerlIOBuf *b = &m->base; 4143 IV code = 0; 4144 if (m->len) { 4145 if (b->buf) { 4146 code = munmap(m->mptr, m->len); 4147 b->buf = NULL; 4148 m->len = 0; 4149 m->mptr = NULL; 4150 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0) 4151 code = -1; 4152 } 4153 b->ptr = b->end = b->buf; 4154 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); 4155 } 4156 return code; 4157 } 4158 4159 STDCHAR * 4160 PerlIOMmap_get_base(pTHX_ PerlIO *f) 4161 { 4162 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4163 PerlIOBuf *b = &m->base; 4164 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { 4165 /* 4166 * Already have a readbuffer in progress 4167 */ 4168 return b->buf; 4169 } 4170 if (b->buf) { 4171 /* 4172 * We have a write buffer or flushed PerlIOBuf read buffer 4173 */ 4174 m->bbuf = b->buf; /* save it in case we need it again */ 4175 b->buf = NULL; /* Clear to trigger below */ 4176 } 4177 if (!b->buf) { 4178 PerlIOMmap_map(aTHX_ f); /* Try and map it */ 4179 if (!b->buf) { 4180 /* 4181 * Map did not work - recover PerlIOBuf buffer if we have one 4182 */ 4183 b->buf = m->bbuf; 4184 } 4185 } 4186 b->ptr = b->end = b->buf; 4187 if (b->buf) 4188 return b->buf; 4189 return PerlIOBuf_get_base(aTHX_ f); 4190 } 4191 4192 SSize_t 4193 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4194 { 4195 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4196 PerlIOBuf *b = &m->base; 4197 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) 4198 PerlIO_flush(f); 4199 if (b->ptr && (b->ptr - count) >= b->buf 4200 && memEQ(b->ptr - count, vbuf, count)) { 4201 b->ptr -= count; 4202 PerlIOBase(f)->flags &= ~PERLIO_F_EOF; 4203 return count; 4204 } 4205 if (m->len) { 4206 /* 4207 * Loose the unwritable mapped buffer 4208 */ 4209 PerlIO_flush(f); 4210 /* 4211 * If flush took the "buffer" see if we have one from before 4212 */ 4213 if (!b->buf && m->bbuf) 4214 b->buf = m->bbuf; 4215 if (!b->buf) { 4216 PerlIOBuf_get_base(aTHX_ f); 4217 m->bbuf = b->buf; 4218 } 4219 } 4220 return PerlIOBuf_unread(aTHX_ f, vbuf, count); 4221 } 4222 4223 SSize_t 4224 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) 4225 { 4226 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4227 PerlIOBuf *b = &m->base; 4228 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { 4229 /* 4230 * No, or wrong sort of, buffer 4231 */ 4232 if (m->len) { 4233 if (PerlIOMmap_unmap(aTHX_ f) != 0) 4234 return 0; 4235 } 4236 /* 4237 * If unmap took the "buffer" see if we have one from before 4238 */ 4239 if (!b->buf && m->bbuf) 4240 b->buf = m->bbuf; 4241 if (!b->buf) { 4242 PerlIOBuf_get_base(aTHX_ f); 4243 m->bbuf = b->buf; 4244 } 4245 } 4246 return PerlIOBuf_write(aTHX_ f, vbuf, count); 4247 } 4248 4249 IV 4250 PerlIOMmap_flush(pTHX_ PerlIO *f) 4251 { 4252 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4253 PerlIOBuf *b = &m->base; 4254 IV code = PerlIOBuf_flush(aTHX_ f); 4255 /* 4256 * Now we are "synced" at PerlIOBuf level 4257 */ 4258 if (b->buf) { 4259 if (m->len) { 4260 /* 4261 * Unmap the buffer 4262 */ 4263 if (PerlIOMmap_unmap(aTHX_ f) != 0) 4264 code = -1; 4265 } 4266 else { 4267 /* 4268 * We seem to have a PerlIOBuf buffer which was not mapped 4269 * remember it in case we need one later 4270 */ 4271 m->bbuf = b->buf; 4272 } 4273 } 4274 return code; 4275 } 4276 4277 IV 4278 PerlIOMmap_fill(pTHX_ PerlIO *f) 4279 { 4280 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); 4281 IV code = PerlIO_flush(f); 4282 if (code == 0 && !b->buf) { 4283 code = PerlIOMmap_map(aTHX_ f); 4284 } 4285 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { 4286 code = PerlIOBuf_fill(aTHX_ f); 4287 } 4288 return code; 4289 } 4290 4291 IV 4292 PerlIOMmap_close(pTHX_ PerlIO *f) 4293 { 4294 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); 4295 PerlIOBuf *b = &m->base; 4296 IV code = PerlIO_flush(f); 4297 if (m->bbuf) { 4298 b->buf = m->bbuf; 4299 m->bbuf = NULL; 4300 b->ptr = b->end = b->buf; 4301 } 4302 if (PerlIOBuf_close(aTHX_ f) != 0) 4303 code = -1; 4304 return code; 4305 } 4306 4307 PerlIO * 4308 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 4309 { 4310 return PerlIOBase_dup(aTHX_ f, o, param, flags); 4311 } 4312 4313 4314 PerlIO_funcs PerlIO_mmap = { 4315 sizeof(PerlIO_funcs), 4316 "mmap", 4317 sizeof(PerlIOMmap), 4318 PERLIO_K_BUFFERED|PERLIO_K_RAW, 4319 PerlIOBuf_pushed, 4320 PerlIOBuf_popped, 4321 PerlIOBuf_open, 4322 PerlIOBase_binmode, /* binmode */ 4323 NULL, 4324 PerlIOBase_fileno, 4325 PerlIOMmap_dup, 4326 PerlIOBuf_read, 4327 PerlIOMmap_unread, 4328 PerlIOMmap_write, 4329 PerlIOBuf_seek, 4330 PerlIOBuf_tell, 4331 PerlIOBuf_close, 4332 PerlIOMmap_flush, 4333 PerlIOMmap_fill, 4334 PerlIOBase_eof, 4335 PerlIOBase_error, 4336 PerlIOBase_clearerr, 4337 PerlIOBase_setlinebuf, 4338 PerlIOMmap_get_base, 4339 PerlIOBuf_bufsiz, 4340 PerlIOBuf_get_ptr, 4341 PerlIOBuf_get_cnt, 4342 PerlIOBuf_set_ptrcnt, 4343 }; 4344 4345 #endif /* HAS_MMAP */ 4346 4347 PerlIO * 4348 Perl_PerlIO_stdin(pTHX) 4349 { 4350 if (!PL_perlio) { 4351 PerlIO_stdstreams(aTHX); 4352 } 4353 return &PL_perlio[1]; 4354 } 4355 4356 PerlIO * 4357 Perl_PerlIO_stdout(pTHX) 4358 { 4359 if (!PL_perlio) { 4360 PerlIO_stdstreams(aTHX); 4361 } 4362 return &PL_perlio[2]; 4363 } 4364 4365 PerlIO * 4366 Perl_PerlIO_stderr(pTHX) 4367 { 4368 if (!PL_perlio) { 4369 PerlIO_stdstreams(aTHX); 4370 } 4371 return &PL_perlio[3]; 4372 } 4373 4374 /*--------------------------------------------------------------------------------------*/ 4375 4376 char * 4377 PerlIO_getname(PerlIO *f, char *buf) 4378 { 4379 dTHX; 4380 char *name = NULL; 4381 #ifdef VMS 4382 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; 4383 if (stdio) 4384 name = fgetname(stdio, buf); 4385 #else 4386 Perl_croak(aTHX_ "Don't know how to get file name"); 4387 #endif 4388 return name; 4389 } 4390 4391 4392 /*--------------------------------------------------------------------------------------*/ 4393 /* 4394 * Functions which can be called on any kind of PerlIO implemented in 4395 * terms of above 4396 */ 4397 4398 #undef PerlIO_fdopen 4399 PerlIO * 4400 PerlIO_fdopen(int fd, const char *mode) 4401 { 4402 dTHX; 4403 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL); 4404 } 4405 4406 #undef PerlIO_open 4407 PerlIO * 4408 PerlIO_open(const char *path, const char *mode) 4409 { 4410 dTHX; 4411 SV *name = sv_2mortal(newSVpvn(path, strlen(path))); 4412 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name); 4413 } 4414 4415 #undef Perlio_reopen 4416 PerlIO * 4417 PerlIO_reopen(const char *path, const char *mode, PerlIO *f) 4418 { 4419 dTHX; 4420 SV *name = sv_2mortal(newSVpvn(path, strlen(path))); 4421 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name); 4422 } 4423 4424 #undef PerlIO_getc 4425 int 4426 PerlIO_getc(PerlIO *f) 4427 { 4428 dTHX; 4429 STDCHAR buf[1]; 4430 SSize_t count = PerlIO_read(f, buf, 1); 4431 if (count == 1) { 4432 return (unsigned char) buf[0]; 4433 } 4434 return EOF; 4435 } 4436 4437 #undef PerlIO_ungetc 4438 int 4439 PerlIO_ungetc(PerlIO *f, int ch) 4440 { 4441 dTHX; 4442 if (ch != EOF) { 4443 STDCHAR buf = ch; 4444 if (PerlIO_unread(f, &buf, 1) == 1) 4445 return ch; 4446 } 4447 return EOF; 4448 } 4449 4450 #undef PerlIO_putc 4451 int 4452 PerlIO_putc(PerlIO *f, int ch) 4453 { 4454 dTHX; 4455 STDCHAR buf = ch; 4456 return PerlIO_write(f, &buf, 1); 4457 } 4458 4459 #undef PerlIO_puts 4460 int 4461 PerlIO_puts(PerlIO *f, const char *s) 4462 { 4463 dTHX; 4464 STRLEN len = strlen(s); 4465 return PerlIO_write(f, s, len); 4466 } 4467 4468 #undef PerlIO_rewind 4469 void 4470 PerlIO_rewind(PerlIO *f) 4471 { 4472 dTHX; 4473 PerlIO_seek(f, (Off_t) 0, SEEK_SET); 4474 PerlIO_clearerr(f); 4475 } 4476 4477 #undef PerlIO_vprintf 4478 int 4479 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) 4480 { 4481 dTHX; 4482 SV *sv = newSVpvn("", 0); 4483 char *s; 4484 STRLEN len; 4485 SSize_t wrote; 4486 #ifdef NEED_VA_COPY 4487 va_list apc; 4488 Perl_va_copy(ap, apc); 4489 sv_vcatpvf(sv, fmt, &apc); 4490 #else 4491 sv_vcatpvf(sv, fmt, &ap); 4492 #endif 4493 s = SvPV(sv, len); 4494 wrote = PerlIO_write(f, s, len); 4495 SvREFCNT_dec(sv); 4496 return wrote; 4497 } 4498 4499 #undef PerlIO_printf 4500 int 4501 PerlIO_printf(PerlIO *f, const char *fmt, ...) 4502 { 4503 va_list ap; 4504 int result; 4505 va_start(ap, fmt); 4506 result = PerlIO_vprintf(f, fmt, ap); 4507 va_end(ap); 4508 return result; 4509 } 4510 4511 #undef PerlIO_stdoutf 4512 int 4513 PerlIO_stdoutf(const char *fmt, ...) 4514 { 4515 dTHX; 4516 va_list ap; 4517 int result; 4518 va_start(ap, fmt); 4519 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap); 4520 va_end(ap); 4521 return result; 4522 } 4523 4524 #undef PerlIO_tmpfile 4525 PerlIO * 4526 PerlIO_tmpfile(void) 4527 { 4528 /* 4529 * I have no idea how portable mkstemp() is ... 4530 */ 4531 #if defined(WIN32) || !defined(HAVE_MKSTEMP) 4532 dTHX; 4533 PerlIO *f = NULL; 4534 FILE *stdio = PerlSIO_tmpfile(); 4535 if (stdio) { 4536 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), &PerlIO_stdio, "w+", Nullsv))) { 4537 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); 4538 s->stdio = stdio; 4539 } 4540 } 4541 return f; 4542 #else 4543 dTHX; 4544 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0); 4545 int fd = mkstemp(SvPVX(sv)); 4546 PerlIO *f = NULL; 4547 if (fd >= 0) { 4548 f = PerlIO_fdopen(fd, "w+"); 4549 if (f) { 4550 PerlIOBase(f)->flags |= PERLIO_F_TEMP; 4551 } 4552 PerlLIO_unlink(SvPVX(sv)); 4553 SvREFCNT_dec(sv); 4554 } 4555 return f; 4556 #endif 4557 } 4558 4559 #undef HAS_FSETPOS 4560 #undef HAS_FGETPOS 4561 4562 #endif /* USE_SFIO */ 4563 #endif /* PERLIO_IS_STDIO */ 4564 4565 /*======================================================================================*/ 4566 /* 4567 * Now some functions in terms of above which may be needed even if we are 4568 * not in true PerlIO mode 4569 */ 4570 4571 #ifndef HAS_FSETPOS 4572 #undef PerlIO_setpos 4573 int 4574 PerlIO_setpos(PerlIO *f, SV *pos) 4575 { 4576 dTHX; 4577 if (SvOK(pos)) { 4578 STRLEN len; 4579 Off_t *posn = (Off_t *) SvPV(pos, len); 4580 if (f && len == sizeof(Off_t)) 4581 return PerlIO_seek(f, *posn, SEEK_SET); 4582 } 4583 SETERRNO(EINVAL, SS$_IVCHAN); 4584 return -1; 4585 } 4586 #else 4587 #undef PerlIO_setpos 4588 int 4589 PerlIO_setpos(PerlIO *f, SV *pos) 4590 { 4591 dTHX; 4592 if (SvOK(pos)) { 4593 STRLEN len; 4594 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len); 4595 if (f && len == sizeof(Fpos_t)) { 4596 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 4597 return fsetpos64(f, fpos); 4598 #else 4599 return fsetpos(f, fpos); 4600 #endif 4601 } 4602 } 4603 SETERRNO(EINVAL, SS$_IVCHAN); 4604 return -1; 4605 } 4606 #endif 4607 4608 #ifndef HAS_FGETPOS 4609 #undef PerlIO_getpos 4610 int 4611 PerlIO_getpos(PerlIO *f, SV *pos) 4612 { 4613 dTHX; 4614 Off_t posn = PerlIO_tell(f); 4615 sv_setpvn(pos, (char *) &posn, sizeof(posn)); 4616 return (posn == (Off_t) - 1) ? -1 : 0; 4617 } 4618 #else 4619 #undef PerlIO_getpos 4620 int 4621 PerlIO_getpos(PerlIO *f, SV *pos) 4622 { 4623 dTHX; 4624 Fpos_t fpos; 4625 int code; 4626 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) 4627 code = fgetpos64(f, &fpos); 4628 #else 4629 code = fgetpos(f, &fpos); 4630 #endif 4631 sv_setpvn(pos, (char *) &fpos, sizeof(fpos)); 4632 return code; 4633 } 4634 #endif 4635 4636 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) 4637 4638 int 4639 vprintf(char *pat, char *args) 4640 { 4641 _doprnt(pat, args, stdout); 4642 return 0; /* wrong, but perl doesn't use the return 4643 * value */ 4644 } 4645 4646 int 4647 vfprintf(FILE *fd, char *pat, char *args) 4648 { 4649 _doprnt(pat, args, fd); 4650 return 0; /* wrong, but perl doesn't use the return 4651 * value */ 4652 } 4653 4654 #endif 4655 4656 #ifndef PerlIO_vsprintf 4657 int 4658 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) 4659 { 4660 int val = vsprintf(s, fmt, ap); 4661 if (n >= 0) { 4662 if (strlen(s) >= (STRLEN) n) { 4663 dTHX; 4664 (void) PerlIO_puts(Perl_error_log, 4665 "panic: sprintf overflow - memory corrupted!\n"); 4666 my_exit(1); 4667 } 4668 } 4669 return val; 4670 } 4671 #endif 4672 4673 #ifndef PerlIO_sprintf 4674 int 4675 PerlIO_sprintf(char *s, int n, const char *fmt, ...) 4676 { 4677 va_list ap; 4678 int result; 4679 va_start(ap, fmt); 4680 result = PerlIO_vsprintf(s, n, fmt, ap); 4681 va_end(ap); 4682 return result; 4683 } 4684 #endif 4685 4686 4687 4688 4689 4690 4691 4692 4693