1 /* doio.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * Far below them they saw the white waters pour into a foaming bowl, and 13 * then swirl darkly about a deep oval basin in the rocks, until they found 14 * their way out again through a narrow gate, and flowed away, fuming and 15 * chattering, into calmer and more level reaches. 16 * 17 * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"] 18 */ 19 20 /* This file contains functions that do the actual I/O on behalf of ops. 21 * For example, pp_print() calls the do_print() function in this file for 22 * each argument needing printing. 23 */ 24 25 #include "EXTERN.h" 26 #define PERL_IN_DOIO_C 27 #include "perl.h" 28 29 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 30 #ifndef HAS_SEM 31 #include <sys/ipc.h> 32 #endif 33 #ifdef HAS_MSG 34 #include <sys/msg.h> 35 #endif 36 #ifdef HAS_SHM 37 #include <sys/shm.h> 38 # ifndef HAS_SHMAT_PROTOTYPE 39 extern Shmat_t shmat (int, char *, int); 40 # endif 41 #endif 42 #endif 43 44 #ifdef I_UTIME 45 # if defined(_MSC_VER) || defined(__MINGW32__) 46 # include <sys/utime.h> 47 # else 48 # include <utime.h> 49 # endif 50 #endif 51 52 #ifdef O_EXCL 53 # define OPEN_EXCL O_EXCL 54 #else 55 # define OPEN_EXCL 0 56 #endif 57 58 #define PERL_MODE_MAX 8 59 #define PERL_FLAGS_MAX 10 60 61 #include <signal.h> 62 63 static IO * 64 S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, 65 int *savefd, char *savetype) 66 { 67 IO * const io = GvIOn(gv); 68 69 PERL_ARGS_ASSERT_OPENN_SETUP; 70 71 *saveifp = NULL; 72 *saveofp = NULL; 73 *savefd = -1; 74 *savetype = IoTYPE_CLOSED; 75 76 Zero(mode,sizeof(mode),char); 77 PL_forkprocess = 1; /* assume true if no fork */ 78 79 /* If currently open - close before we re-open */ 80 if (IoIFP(io)) { 81 if (IoTYPE(io) == IoTYPE_STD) { 82 /* This is a clone of one of STD* handles */ 83 } 84 else { 85 const int old_fd = PerlIO_fileno(IoIFP(io)); 86 87 if (old_fd >= 0 && old_fd <= PL_maxsysfd) { 88 /* This is one of the original STD* handles */ 89 *saveifp = IoIFP(io); 90 *saveofp = IoOFP(io); 91 *savetype = IoTYPE(io); 92 *savefd = old_fd; 93 } 94 else { 95 int result; 96 97 if (IoTYPE(io) == IoTYPE_PIPE) 98 result = PerlProc_pclose(IoIFP(io)); 99 else if (IoIFP(io) != IoOFP(io)) { 100 if (IoOFP(io)) { 101 result = PerlIO_close(IoOFP(io)); 102 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 103 } 104 else 105 result = PerlIO_close(IoIFP(io)); 106 } 107 else 108 result = PerlIO_close(IoIFP(io)); 109 110 if (result == EOF && old_fd > PL_maxsysfd) { 111 /* Why is this not Perl_warn*() call ? */ 112 PerlIO_printf(Perl_error_log, 113 "Warning: unable to close filehandle %"HEKf" properly.\n", 114 HEKfARG(GvENAME_HEK(gv)) 115 ); 116 } 117 } 118 } 119 IoOFP(io) = IoIFP(io) = NULL; 120 } 121 return io; 122 } 123 124 bool 125 Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, 126 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, 127 I32 num_svs) 128 { 129 PERL_ARGS_ASSERT_DO_OPENN; 130 131 if (as_raw) { 132 /* sysopen style args, i.e. integer mode and permissions */ 133 134 if (num_svs != 0) { 135 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", 136 (long) num_svs); 137 } 138 return do_open_raw(gv, oname, len, rawmode, rawperm); 139 } 140 return do_open6(gv, oname, len, supplied_fp, svp, num_svs); 141 } 142 143 bool 144 Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, 145 int rawmode, int rawperm) 146 { 147 PerlIO *saveifp; 148 PerlIO *saveofp; 149 int savefd; 150 char savetype; 151 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ 152 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); 153 int writing = 0; 154 PerlIO *fp; 155 156 PERL_ARGS_ASSERT_DO_OPEN_RAW; 157 158 /* For ease of blame back to 5.000, keep the existing indenting. */ 159 { 160 /* sysopen style args, i.e. integer mode and permissions */ 161 STRLEN ix = 0; 162 const int appendtrunc = 163 0 164 #ifdef O_APPEND /* Not fully portable. */ 165 |O_APPEND 166 #endif 167 #ifdef O_TRUNC /* Not fully portable. */ 168 |O_TRUNC 169 #endif 170 ; 171 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; 172 int ismodifying; 173 SV *namesv; 174 175 /* It's not always 176 177 O_RDONLY 0 178 O_WRONLY 1 179 O_RDWR 2 180 181 It might be (in OS/390 and Mac OS Classic it is) 182 183 O_WRONLY 1 184 O_RDONLY 2 185 O_RDWR 3 186 187 This means that simple & with O_RDWR would look 188 like O_RDONLY is present. Therefore we have to 189 be more careful. 190 */ 191 if ((ismodifying = (rawmode & modifyingmode))) { 192 if ((ismodifying & O_WRONLY) == O_WRONLY || 193 (ismodifying & O_RDWR) == O_RDWR || 194 (ismodifying & (O_CREAT|appendtrunc))) 195 TAINT_PROPER("sysopen"); 196 } 197 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ 198 199 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) 200 rawmode |= O_LARGEFILE; /* Transparently largefiley. */ 201 #endif 202 203 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); 204 205 namesv = newSVpvn_flags(oname, len, SVs_TEMP); 206 fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); 207 } 208 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, 209 savetype, writing, 0, NULL); 210 } 211 212 bool 213 Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, 214 PerlIO *supplied_fp, SV **svp, U32 num_svs) 215 { 216 PerlIO *saveifp; 217 PerlIO *saveofp; 218 int savefd; 219 char savetype; 220 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ 221 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); 222 int writing = 0; 223 PerlIO *fp; 224 bool was_fdopen = FALSE; 225 char *type = NULL; 226 227 PERL_ARGS_ASSERT_DO_OPEN6; 228 229 /* For ease of blame back to 5.000, keep the existing indenting. */ 230 { 231 /* Regular (non-sys) open */ 232 char *name; 233 STRLEN olen = len; 234 char *tend; 235 int dodup = 0; 236 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; 237 238 /* Collect default raw/crlf info from the op */ 239 if (PL_op && PL_op->op_type == OP_OPEN) { 240 /* set up IO layers */ 241 const U8 flags = PL_op->op_private; 242 in_raw = (flags & OPpOPEN_IN_RAW); 243 in_crlf = (flags & OPpOPEN_IN_CRLF); 244 out_raw = (flags & OPpOPEN_OUT_RAW); 245 out_crlf = (flags & OPpOPEN_OUT_CRLF); 246 } 247 248 type = savepvn(oname, len); 249 tend = type+len; 250 SAVEFREEPV(type); 251 252 /* Lose leading and trailing white space */ 253 while (isSPACE(*type)) 254 type++; 255 while (tend > type && isSPACE(tend[-1])) 256 *--tend = '\0'; 257 258 if (num_svs) { 259 const char *p; 260 STRLEN nlen = 0; 261 /* New style explicit name, type is just mode and layer info */ 262 #ifdef USE_STDIO 263 if (SvROK(*svp) && !strchr(oname,'&')) { 264 if (ckWARN(WARN_IO)) 265 Perl_warner(aTHX_ packWARN(WARN_IO), 266 "Can't open a reference"); 267 SETERRNO(EINVAL, LIB_INVARG); 268 fp = NULL; 269 goto say_false; 270 } 271 #endif /* USE_STDIO */ 272 p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; 273 274 if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) { 275 fp = NULL; 276 goto say_false; 277 } 278 279 name = p ? savepvn(p, nlen) : savepvs(""); 280 281 SAVEFREEPV(name); 282 } 283 else { 284 name = type; 285 len = tend-type; 286 } 287 IoTYPE(io) = *type; 288 if ((*type == IoTYPE_RDWR) && /* scary */ 289 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && 290 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { 291 TAINT_PROPER("open"); 292 mode[1] = *type++; 293 writing = 1; 294 } 295 296 if (*type == IoTYPE_PIPE) { 297 if (num_svs) { 298 if (type[1] != IoTYPE_STD) { 299 unknown_open_mode: 300 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); 301 } 302 type++; 303 } 304 do { 305 type++; 306 } while (isSPACE(*type)); 307 if (!num_svs) { 308 name = type; 309 len = tend-type; 310 } 311 if (*name == '\0') { 312 /* command is missing 19990114 */ 313 if (ckWARN(WARN_PIPE)) 314 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 315 errno = EPIPE; 316 fp = NULL; 317 goto say_false; 318 } 319 if (!(*name == '-' && name[1] == '\0') || num_svs) 320 TAINT_ENV(); 321 TAINT_PROPER("piped open"); 322 if (!num_svs && name[len-1] == '|') { 323 name[--len] = '\0' ; 324 if (ckWARN(WARN_PIPE)) 325 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); 326 } 327 mode[0] = 'w'; 328 writing = 1; 329 if (out_raw) 330 mode[1] = 'b'; 331 else if (out_crlf) 332 mode[1] = 't'; 333 if (num_svs > 1) { 334 fp = PerlProc_popen_list(mode, num_svs, svp); 335 } 336 else { 337 fp = PerlProc_popen(name,mode); 338 } 339 if (num_svs) { 340 if (*type) { 341 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 342 fp = NULL; 343 goto say_false; 344 } 345 } 346 } 347 } /* IoTYPE_PIPE */ 348 else if (*type == IoTYPE_WRONLY) { 349 TAINT_PROPER("open"); 350 type++; 351 if (*type == IoTYPE_WRONLY) { 352 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ 353 mode[0] = IoTYPE(io) = IoTYPE_APPEND; 354 type++; 355 } 356 else { 357 mode[0] = 'w'; 358 } 359 writing = 1; 360 361 if (out_raw) 362 mode[1] = 'b'; 363 else if (out_crlf) 364 mode[1] = 't'; 365 if (*type == '&') { 366 duplicity: 367 dodup = PERLIO_DUP_FD; 368 type++; 369 if (*type == '=') { 370 dodup = 0; 371 type++; 372 } 373 if (!num_svs && !*type && supplied_fp) { 374 /* "<+&" etc. is used by typemaps */ 375 fp = supplied_fp; 376 } 377 else { 378 PerlIO *that_fp = NULL; 379 int wanted_fd; 380 UV uv; 381 if (num_svs > 1) { 382 /* diag_listed_as: More than one argument to '%s' open */ 383 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); 384 } 385 while (isSPACE(*type)) 386 type++; 387 if (num_svs && ( 388 SvIOK(*svp) 389 || (SvPOKp(*svp) && looks_like_number(*svp)) 390 )) { 391 wanted_fd = SvUV(*svp); 392 num_svs = 0; 393 } 394 else if (isDIGIT(*type) 395 && grok_atoUV(type, &uv, NULL) 396 && uv <= INT_MAX 397 ) { 398 wanted_fd = (int)uv; 399 } 400 else { 401 const IO* thatio; 402 if (num_svs) { 403 thatio = sv_2io(*svp); 404 } 405 else { 406 GV * const thatgv = gv_fetchpvn_flags(type, tend - type, 407 0, SVt_PVIO); 408 thatio = GvIO(thatgv); 409 } 410 if (!thatio) { 411 #ifdef EINVAL 412 SETERRNO(EINVAL,SS_IVCHAN); 413 #endif 414 fp = NULL; 415 goto say_false; 416 } 417 if ((that_fp = IoIFP(thatio))) { 418 /* Flush stdio buffer before dup. --mjd 419 * Unfortunately SEEK_CURing 0 seems to 420 * be optimized away on most platforms; 421 * only Solaris and Linux seem to flush 422 * on that. --jhi */ 423 /* On the other hand, do all platforms 424 * take gracefully to flushing a read-only 425 * filehandle? Perhaps we should do 426 * fsetpos(src)+fgetpos(dst)? --nik */ 427 PerlIO_flush(that_fp); 428 wanted_fd = PerlIO_fileno(that_fp); 429 /* When dup()ing STDIN, STDOUT or STDERR 430 * explicitly set appropriate access mode */ 431 if (that_fp == PerlIO_stdout() 432 || that_fp == PerlIO_stderr()) 433 IoTYPE(io) = IoTYPE_WRONLY; 434 else if (that_fp == PerlIO_stdin()) 435 IoTYPE(io) = IoTYPE_RDONLY; 436 /* When dup()ing a socket, say result is 437 * one as well */ 438 else if (IoTYPE(thatio) == IoTYPE_SOCKET) 439 IoTYPE(io) = IoTYPE_SOCKET; 440 } 441 else { 442 SETERRNO(EBADF, RMS_IFI); 443 fp = NULL; 444 goto say_false; 445 } 446 } 447 if (!num_svs) 448 type = NULL; 449 if (that_fp) { 450 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); 451 } 452 else { 453 if (dodup) 454 wanted_fd = PerlLIO_dup(wanted_fd); 455 else 456 was_fdopen = TRUE; 457 if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) { 458 if (dodup && wanted_fd >= 0) 459 PerlLIO_close(wanted_fd); 460 } 461 } 462 } 463 } /* & */ 464 else { 465 while (isSPACE(*type)) 466 type++; 467 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 468 type++; 469 fp = PerlIO_stdout(); 470 IoTYPE(io) = IoTYPE_STD; 471 if (num_svs > 1) { 472 /* diag_listed_as: More than one argument to '%s' open */ 473 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); 474 } 475 } 476 else { 477 if (num_svs) { 478 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 479 } 480 else { 481 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 482 type = NULL; 483 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 484 } 485 } 486 } /* !& */ 487 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 488 goto unknown_open_mode; 489 } /* IoTYPE_WRONLY */ 490 else if (*type == IoTYPE_RDONLY) { 491 do { 492 type++; 493 } while (isSPACE(*type)); 494 mode[0] = 'r'; 495 if (in_raw) 496 mode[1] = 'b'; 497 else if (in_crlf) 498 mode[1] = 't'; 499 if (*type == '&') { 500 goto duplicity; 501 } 502 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 503 type++; 504 fp = PerlIO_stdin(); 505 IoTYPE(io) = IoTYPE_STD; 506 if (num_svs > 1) { 507 /* diag_listed_as: More than one argument to '%s' open */ 508 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); 509 } 510 } 511 else { 512 if (num_svs) { 513 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 514 } 515 else { 516 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 517 type = NULL; 518 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 519 } 520 } 521 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 522 goto unknown_open_mode; 523 } /* IoTYPE_RDONLY */ 524 else if ((num_svs && /* '-|...' or '...|' */ 525 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || 526 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { 527 if (num_svs) { 528 type += 2; /* skip over '-|' */ 529 } 530 else { 531 *--tend = '\0'; 532 while (tend > type && isSPACE(tend[-1])) 533 *--tend = '\0'; 534 for (; isSPACE(*type); type++) 535 ; 536 name = type; 537 len = tend-type; 538 } 539 if (*name == '\0') { 540 /* command is missing 19990114 */ 541 if (ckWARN(WARN_PIPE)) 542 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 543 errno = EPIPE; 544 fp = NULL; 545 goto say_false; 546 } 547 if (!(*name == '-' && name[1] == '\0') || num_svs) 548 TAINT_ENV(); 549 TAINT_PROPER("piped open"); 550 mode[0] = 'r'; 551 552 if (in_raw) 553 mode[1] = 'b'; 554 else if (in_crlf) 555 mode[1] = 't'; 556 557 if (num_svs > 1) { 558 fp = PerlProc_popen_list(mode,num_svs,svp); 559 } 560 else { 561 fp = PerlProc_popen(name,mode); 562 } 563 IoTYPE(io) = IoTYPE_PIPE; 564 if (num_svs) { 565 while (isSPACE(*type)) 566 type++; 567 if (*type) { 568 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 569 fp = NULL; 570 goto say_false; 571 } 572 } 573 } 574 } 575 else { /* layer(Args) */ 576 if (num_svs) 577 goto unknown_open_mode; 578 name = type; 579 IoTYPE(io) = IoTYPE_RDONLY; 580 for (; isSPACE(*name); name++) 581 ; 582 mode[0] = 'r'; 583 584 if (in_raw) 585 mode[1] = 'b'; 586 else if (in_crlf) 587 mode[1] = 't'; 588 589 if (*name == '-' && name[1] == '\0') { 590 fp = PerlIO_stdin(); 591 IoTYPE(io) = IoTYPE_STD; 592 } 593 else { 594 if (num_svs) { 595 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 596 } 597 else { 598 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 599 type = NULL; 600 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 601 } 602 } 603 } 604 } 605 606 say_false: 607 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, 608 savetype, writing, was_fdopen, type); 609 } 610 611 /* Yes, this is ugly, but it's private, and I don't see a cleaner way to 612 simplify the two-headed public interface of do_openn. */ 613 static bool 614 S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, 615 PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype, 616 int writing, bool was_fdopen, const char *type) 617 { 618 int fd; 619 620 PERL_ARGS_ASSERT_OPENN_CLEANUP; 621 622 if (!fp) { 623 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) 624 && should_warn_nl(oname) 625 626 ) 627 { 628 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ 629 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); 630 GCC_DIAG_RESTORE; 631 } 632 goto say_false; 633 } 634 635 if (ckWARN(WARN_IO)) { 636 if ((IoTYPE(io) == IoTYPE_RDONLY) && 637 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { 638 Perl_warner(aTHX_ packWARN(WARN_IO), 639 "Filehandle STD%s reopened as %"HEKf 640 " only for input", 641 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), 642 HEKfARG(GvENAME_HEK(gv))); 643 } 644 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { 645 Perl_warner(aTHX_ packWARN(WARN_IO), 646 "Filehandle STDIN reopened as %"HEKf" only for output", 647 HEKfARG(GvENAME_HEK(gv)) 648 ); 649 } 650 } 651 652 fd = PerlIO_fileno(fp); 653 /* Do NOT do: "if (fd < 0) goto say_false;" here. If there is no 654 * fd assume it isn't a socket - this covers PerlIO::scalar - 655 * otherwise unless we "know" the type probe for socket-ness. 656 */ 657 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { 658 if (PerlLIO_fstat(fd,&PL_statbuf) < 0) { 659 /* If PerlIO claims to have fd we had better be able to fstat() it. */ 660 (void) PerlIO_close(fp); 661 goto say_false; 662 } 663 #ifndef PERL_MICRO 664 if (S_ISSOCK(PL_statbuf.st_mode)) 665 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ 666 #ifdef HAS_SOCKET 667 else if ( 668 !(PL_statbuf.st_mode & S_IFMT) 669 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ 670 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ 671 ) { /* on OS's that return 0 on fstat()ed pipe */ 672 char tmpbuf[256]; 673 Sock_size_t buflen = sizeof tmpbuf; 674 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 675 || errno != ENOTSOCK) 676 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ 677 /* but some return 0 for streams too, sigh */ 678 } 679 #endif /* HAS_SOCKET */ 680 #endif /* !PERL_MICRO */ 681 } 682 683 /* Eeek - FIXME !!! 684 * If this is a standard handle we discard all the layer stuff 685 * and just dup the fd into whatever was on the handle before ! 686 */ 687 688 if (saveifp) { /* must use old fp? */ 689 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR 690 then dup the new fileno down 691 */ 692 if (saveofp) { 693 PerlIO_flush(saveofp); /* emulate PerlIO_close() */ 694 if (saveofp != saveifp) { /* was a socket? */ 695 PerlIO_close(saveofp); 696 } 697 } 698 if (savefd != fd) { 699 /* Still a small can-of-worms here if (say) PerlIO::scalar 700 is assigned to (say) STDOUT - for now let dup2() fail 701 and provide the error 702 */ 703 if (fd < 0) { 704 SETERRNO(EBADF,RMS_IFI); 705 goto say_false; 706 } else if (PerlLIO_dup2(fd, savefd) < 0) { 707 (void)PerlIO_close(fp); 708 goto say_false; 709 } 710 #ifdef VMS 711 if (savefd != PerlIO_fileno(PerlIO_stdin())) { 712 char newname[FILENAME_MAX+1]; 713 if (PerlIO_getname(fp, newname)) { 714 if (fd == PerlIO_fileno(PerlIO_stdout())) 715 vmssetuserlnm("SYS$OUTPUT", newname); 716 if (fd == PerlIO_fileno(PerlIO_stderr())) 717 vmssetuserlnm("SYS$ERROR", newname); 718 } 719 } 720 #endif 721 722 #if !defined(WIN32) 723 /* PL_fdpid isn't used on Windows, so avoid this useless work. 724 * XXX Probably the same for a lot of other places. */ 725 { 726 Pid_t pid; 727 SV *sv; 728 729 sv = *av_fetch(PL_fdpid,fd,TRUE); 730 SvUPGRADE(sv, SVt_IV); 731 pid = SvIVX(sv); 732 SvIV_set(sv, 0); 733 sv = *av_fetch(PL_fdpid,savefd,TRUE); 734 SvUPGRADE(sv, SVt_IV); 735 SvIV_set(sv, pid); 736 } 737 #endif 738 739 if (was_fdopen) { 740 /* need to close fp without closing underlying fd */ 741 int ofd = PerlIO_fileno(fp); 742 int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1; 743 #if defined(HAS_FCNTL) && defined(F_SETFD) 744 /* Assume if we have F_SETFD we have F_GETFD. */ 745 /* Get a copy of all the fd flags. */ 746 int fd_flags = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1; 747 if (fd_flags < 0) { 748 if (dupfd >= 0) 749 PerlLIO_close(dupfd); 750 goto say_false; 751 } 752 #endif 753 if (ofd < 0 || dupfd < 0) { 754 if (dupfd >= 0) 755 PerlLIO_close(dupfd); 756 goto say_false; 757 } 758 PerlIO_close(fp); 759 PerlLIO_dup2(dupfd, ofd); 760 #if defined(HAS_FCNTL) && defined(F_SETFD) 761 /* The dup trick has lost close-on-exec on ofd, 762 * and possibly any other flags, so restore them. */ 763 fcntl(ofd,F_SETFD, fd_flags); 764 #endif 765 PerlLIO_close(dupfd); 766 } 767 else 768 PerlIO_close(fp); 769 } 770 fp = saveifp; 771 PerlIO_clearerr(fp); 772 fd = PerlIO_fileno(fp); 773 } 774 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) 775 if (fd >= 0 && fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { 776 PerlLIO_close(fd); 777 goto say_false; 778 } 779 #endif 780 IoIFP(io) = fp; 781 782 IoFLAGS(io) &= ~IOf_NOLINE; 783 if (writing) { 784 if (IoTYPE(io) == IoTYPE_SOCKET 785 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) { 786 char *s = mode; 787 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) 788 s++; 789 *s = 'w'; 790 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { 791 PerlIO_close(fp); 792 goto say_false; 793 } 794 } 795 else 796 IoOFP(io) = fp; 797 } 798 return TRUE; 799 800 say_false: 801 IoIFP(io) = saveifp; 802 IoOFP(io) = saveofp; 803 IoTYPE(io) = savetype; 804 return FALSE; 805 } 806 807 PerlIO * 808 Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) 809 { 810 IO * const io = GvIOp(gv); 811 SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL; 812 813 PERL_ARGS_ASSERT_NEXTARGV; 814 815 if (old_out_name) 816 SAVEFREESV(old_out_name); 817 818 if (!PL_argvoutgv) 819 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 820 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) { 821 IoFLAGS(io) &= ~IOf_START; 822 if (PL_inplace) { 823 assert(PL_defoutgv); 824 Perl_av_create_and_push(aTHX_ &PL_argvout_stack, 825 SvREFCNT_inc_simple_NN(PL_defoutgv)); 826 } 827 } 828 if (PL_filemode & (S_ISUID|S_ISGID)) { 829 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ 830 #ifdef HAS_FCHMOD 831 if (PL_lastfd != -1) 832 (void)fchmod(PL_lastfd,PL_filemode); 833 #else 834 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 835 #endif 836 } 837 PL_lastfd = -1; 838 PL_filemode = 0; 839 if (!GvAV(gv)) 840 return NULL; 841 while (av_tindex(GvAV(gv)) >= 0) { 842 Stat_t statbuf; 843 STRLEN oldlen; 844 SV *const sv = av_shift(GvAV(gv)); 845 SAVEFREESV(sv); 846 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ 847 sv_setsv(GvSVn(gv),sv); 848 SvSETMAGIC(GvSV(gv)); 849 PL_oldname = SvPVx(GvSV(gv), oldlen); 850 if (LIKELY(!PL_inplace)) { 851 if (nomagicopen 852 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1) 853 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0) 854 ) { 855 return IoIFP(GvIOp(gv)); 856 } 857 } 858 else { 859 { 860 IO * const io = GvIOp(PL_argvoutgv); 861 if (io && IoIFP(io) && old_out_name && !io_close(io, PL_argvoutgv, FALSE, FALSE)) { 862 Perl_croak(aTHX_ "Failed to close in-place edit file %"SVf": %s\n", 863 old_out_name, Strerror(errno)); 864 } 865 } 866 /* This very long block ends with return IoIFP(GvIOp(gv)); 867 Both this block and the block above fall through on open 868 failure to the warning code, and then the while loop above tries 869 the next entry. */ 870 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) { 871 #ifndef FLEXFILENAMES 872 int filedev; 873 int fileino; 874 #endif 875 Uid_t fileuid; 876 Gid_t filegid; 877 878 TAINT_PROPER("inplace open"); 879 if (oldlen == 1 && *PL_oldname == '-') { 880 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, 881 SVt_PVIO)); 882 return IoIFP(GvIOp(gv)); 883 } 884 #ifndef FLEXFILENAMES 885 filedev = PL_statbuf.st_dev; 886 fileino = PL_statbuf.st_ino; 887 #endif 888 PL_filemode = PL_statbuf.st_mode; 889 fileuid = PL_statbuf.st_uid; 890 filegid = PL_statbuf.st_gid; 891 if (!S_ISREG(PL_filemode)) { 892 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 893 "Can't do inplace edit: %s is not a regular file", 894 PL_oldname ); 895 do_close(gv,FALSE); 896 continue; 897 } 898 if (*PL_inplace && strNE(PL_inplace, "*")) { 899 const char *star = strchr(PL_inplace, '*'); 900 if (star) { 901 const char *begin = PL_inplace; 902 sv_setpvs(sv, ""); 903 do { 904 sv_catpvn(sv, begin, star - begin); 905 sv_catpvn(sv, PL_oldname, oldlen); 906 begin = ++star; 907 } while ((star = strchr(begin, '*'))); 908 if (*begin) 909 sv_catpv(sv,begin); 910 } 911 else { 912 sv_catpv(sv,PL_inplace); 913 } 914 #ifndef FLEXFILENAMES 915 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0 916 && PL_statbuf.st_dev == filedev 917 && PL_statbuf.st_ino == fileino) 918 #ifdef DJGPP 919 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) 920 #endif 921 ) 922 { 923 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 924 "Can't do inplace edit: %"SVf" would not be unique", 925 SVfARG(sv)); 926 do_close(gv,FALSE); 927 continue; 928 } 929 #endif 930 #ifdef HAS_RENAME 931 #if !defined(DOSISH) && !defined(__CYGWIN__) 932 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) { 933 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 934 "Can't rename %s to %"SVf": %s, skipping file", 935 PL_oldname, SVfARG(sv), Strerror(errno)); 936 do_close(gv,FALSE); 937 continue; 938 } 939 #else 940 do_close(gv,FALSE); 941 (void)PerlLIO_unlink(SvPVX_const(sv)); 942 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv)); 943 do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0); 944 #endif /* DOSISH */ 945 #else 946 (void)UNLINK(SvPVX_const(sv)); 947 if (link(PL_oldname,SvPVX_const(sv)) < 0) { 948 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 949 "Can't rename %s to %"SVf": %s, skipping file", 950 PL_oldname, SVfARG(sv), Strerror(errno) ); 951 do_close(gv,FALSE); 952 continue; 953 } 954 (void)UNLINK(PL_oldname); 955 #endif 956 } 957 else { 958 #if !defined(DOSISH) && !defined(__amigaos4__) 959 # ifndef VMS /* Don't delete; use automatic file versioning */ 960 if (UNLINK(PL_oldname) < 0) { 961 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 962 "Can't remove %s: %s, skipping file", 963 PL_oldname, Strerror(errno) ); 964 do_close(gv,FALSE); 965 continue; 966 } 967 # endif 968 #else 969 Perl_croak(aTHX_ "Can't do inplace edit without backup"); 970 #endif 971 } 972 973 sv_setpvn(sv,PL_oldname,oldlen); 974 SETERRNO(0,0); /* in case sprintf set errno */ 975 if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv), 976 SvCUR(sv), 977 #ifdef VMS 978 O_WRONLY|O_CREAT|O_TRUNC, 0 979 #else 980 O_WRONLY|O_CREAT|OPEN_EXCL, 0600 981 #endif 982 )) { 983 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", 984 PL_oldname, Strerror(errno) ); 985 do_close(gv,FALSE); 986 continue; 987 } 988 setdefout(PL_argvoutgv); 989 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); 990 if (PL_lastfd >= 0) { 991 (void)PerlLIO_fstat(PL_lastfd,&statbuf); 992 #ifdef HAS_FCHMOD 993 (void)fchmod(PL_lastfd,PL_filemode); 994 #else 995 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 996 #endif 997 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { 998 /* XXX silently ignore failures */ 999 #ifdef HAS_FCHOWN 1000 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid)); 1001 #else 1002 #ifdef HAS_CHOWN 1003 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid)); 1004 #endif 1005 #endif 1006 } 1007 } 1008 return IoIFP(GvIOp(gv)); 1009 } 1010 } /* successful do_open_raw(), PL_inplace non-NULL */ 1011 1012 if (ckWARN_d(WARN_INPLACE)) { 1013 const int eno = errno; 1014 if (PerlLIO_stat(PL_oldname, &statbuf) >= 0 1015 && !S_ISREG(statbuf.st_mode)) { 1016 Perl_warner(aTHX_ packWARN(WARN_INPLACE), 1017 "Can't do inplace edit: %s is not a regular file", 1018 PL_oldname); 1019 } 1020 else { 1021 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", 1022 PL_oldname, Strerror(eno)); 1023 } 1024 } 1025 } 1026 if (io && (IoFLAGS(io) & IOf_ARGV)) 1027 IoFLAGS(io) |= IOf_START; 1028 if (PL_inplace) { 1029 if (old_out_name) { 1030 IO * const io = GvIOp(PL_argvoutgv); 1031 if (io && IoIFP(io) && !io_close(io, PL_argvoutgv, FALSE, FALSE)) { 1032 Perl_croak(aTHX_ "Failed to close in-place edit file %"SVf": %s\n", 1033 old_out_name, Strerror(errno)); 1034 } 1035 } 1036 else { 1037 /* maybe this is no longer wanted */ 1038 (void)do_close(PL_argvoutgv,FALSE); 1039 } 1040 if (io && (IoFLAGS(io) & IOf_ARGV) 1041 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) 1042 { 1043 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); 1044 setdefout(oldout); 1045 SvREFCNT_dec_NN(oldout); 1046 return NULL; 1047 } 1048 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); 1049 } 1050 return NULL; 1051 } 1052 1053 /* explicit renamed to avoid C++ conflict -- kja */ 1054 bool 1055 Perl_do_close(pTHX_ GV *gv, bool not_implicit) 1056 { 1057 bool retval; 1058 IO *io; 1059 1060 if (!gv) 1061 gv = PL_argvgv; 1062 if (!gv || !isGV_with_GP(gv)) { 1063 if (not_implicit) 1064 SETERRNO(EBADF,SS_IVCHAN); 1065 return FALSE; 1066 } 1067 io = GvIO(gv); 1068 if (!io) { /* never opened */ 1069 if (not_implicit) { 1070 report_evil_fh(gv); 1071 SETERRNO(EBADF,SS_IVCHAN); 1072 } 1073 return FALSE; 1074 } 1075 retval = io_close(io, NULL, not_implicit, FALSE); 1076 if (not_implicit) { 1077 IoLINES(io) = 0; 1078 IoPAGE(io) = 0; 1079 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1080 } 1081 IoTYPE(io) = IoTYPE_CLOSED; 1082 return retval; 1083 } 1084 1085 bool 1086 Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) 1087 { 1088 bool retval = FALSE; 1089 1090 PERL_ARGS_ASSERT_IO_CLOSE; 1091 1092 if (IoIFP(io)) { 1093 if (IoTYPE(io) == IoTYPE_PIPE) { 1094 const int status = PerlProc_pclose(IoIFP(io)); 1095 if (not_implicit) { 1096 STATUS_NATIVE_CHILD_SET(status); 1097 retval = (STATUS_UNIX == 0); 1098 } 1099 else { 1100 retval = (status != -1); 1101 } 1102 } 1103 else if (IoTYPE(io) == IoTYPE_STD) 1104 retval = TRUE; 1105 else { 1106 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ 1107 const bool prev_err = PerlIO_error(IoOFP(io)); 1108 #ifdef USE_PERLIO 1109 if (prev_err) 1110 PerlIO_restore_errno(IoOFP(io)); 1111 #endif 1112 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); 1113 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 1114 } 1115 else { 1116 const bool prev_err = PerlIO_error(IoIFP(io)); 1117 #ifdef USE_PERLIO 1118 if (prev_err) 1119 PerlIO_restore_errno(IoIFP(io)); 1120 #endif 1121 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); 1122 } 1123 } 1124 IoOFP(io) = IoIFP(io) = NULL; 1125 1126 if (warn_on_fail && !retval) { 1127 if (gv) 1128 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), 1129 "Warning: unable to close filehandle %" 1130 HEKf" properly: %"SVf, 1131 HEKfARG(GvNAME_HEK(gv)), 1132 SVfARG(get_sv("!",GV_ADD))); 1133 else 1134 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), 1135 "Warning: unable to close filehandle " 1136 "properly: %"SVf, 1137 SVfARG(get_sv("!",GV_ADD))); 1138 } 1139 } 1140 else if (not_implicit) { 1141 SETERRNO(EBADF,SS_IVCHAN); 1142 } 1143 1144 return retval; 1145 } 1146 1147 bool 1148 Perl_do_eof(pTHX_ GV *gv) 1149 { 1150 IO * const io = GvIO(gv); 1151 1152 PERL_ARGS_ASSERT_DO_EOF; 1153 1154 if (!io) 1155 return TRUE; 1156 else if (IoTYPE(io) == IoTYPE_WRONLY) 1157 report_wrongway_fh(gv, '>'); 1158 1159 while (IoIFP(io)) { 1160 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ 1161 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ 1162 return FALSE; /* this is the most usual case */ 1163 } 1164 1165 { 1166 /* getc and ungetc can stomp on errno */ 1167 dSAVE_ERRNO; 1168 const int ch = PerlIO_getc(IoIFP(io)); 1169 if (ch != EOF) { 1170 (void)PerlIO_ungetc(IoIFP(io),ch); 1171 RESTORE_ERRNO; 1172 return FALSE; 1173 } 1174 RESTORE_ERRNO; 1175 } 1176 1177 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { 1178 if (PerlIO_get_cnt(IoIFP(io)) < -1) 1179 PerlIO_set_cnt(IoIFP(io),-1); 1180 } 1181 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ 1182 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ 1183 return TRUE; 1184 } 1185 else 1186 return TRUE; /* normal fp, definitely end of file */ 1187 } 1188 return TRUE; 1189 } 1190 1191 Off_t 1192 Perl_do_tell(pTHX_ GV *gv) 1193 { 1194 IO *const io = GvIO(gv); 1195 PerlIO *fp; 1196 1197 PERL_ARGS_ASSERT_DO_TELL; 1198 1199 if (io && (fp = IoIFP(io))) { 1200 return PerlIO_tell(fp); 1201 } 1202 report_evil_fh(gv); 1203 SETERRNO(EBADF,RMS_IFI); 1204 return (Off_t)-1; 1205 } 1206 1207 bool 1208 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) 1209 { 1210 IO *const io = GvIO(gv); 1211 PerlIO *fp; 1212 1213 if (io && (fp = IoIFP(io))) { 1214 return PerlIO_seek(fp, pos, whence) >= 0; 1215 } 1216 report_evil_fh(gv); 1217 SETERRNO(EBADF,RMS_IFI); 1218 return FALSE; 1219 } 1220 1221 Off_t 1222 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) 1223 { 1224 IO *const io = GvIO(gv); 1225 PerlIO *fp; 1226 1227 PERL_ARGS_ASSERT_DO_SYSSEEK; 1228 1229 if (io && (fp = IoIFP(io))) { 1230 int fd = PerlIO_fileno(fp); 1231 if (fd < 0 || (whence == SEEK_SET && pos < 0)) { 1232 SETERRNO(EINVAL,LIB_INVARG); 1233 return -1; 1234 } else { 1235 return PerlLIO_lseek(fd, pos, whence); 1236 } 1237 } 1238 report_evil_fh(gv); 1239 SETERRNO(EBADF,RMS_IFI); 1240 return (Off_t)-1; 1241 } 1242 1243 int 1244 Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) 1245 { 1246 int mode = O_BINARY; 1247 PERL_UNUSED_CONTEXT; 1248 if (s) { 1249 while (*s) { 1250 if (*s == ':') { 1251 switch (s[1]) { 1252 case 'r': 1253 if (s[2] == 'a' && s[3] == 'w' 1254 && (!s[4] || s[4] == ':' || isSPACE(s[4]))) 1255 { 1256 mode = O_BINARY; 1257 s += 4; 1258 len -= 4; 1259 break; 1260 } 1261 /* FALLTHROUGH */ 1262 case 'c': 1263 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' 1264 && (!s[5] || s[5] == ':' || isSPACE(s[5]))) 1265 { 1266 mode = O_TEXT; 1267 s += 5; 1268 len -= 5; 1269 break; 1270 } 1271 /* FALLTHROUGH */ 1272 default: 1273 goto fail_discipline; 1274 } 1275 } 1276 else if (isSPACE(*s)) { 1277 ++s; 1278 --len; 1279 } 1280 else { 1281 const char *end; 1282 fail_discipline: 1283 end = strchr(s+1, ':'); 1284 if (!end) 1285 end = s+len; 1286 #ifndef PERLIO_LAYERS 1287 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); 1288 #else 1289 len -= end-s; 1290 s = end; 1291 #endif 1292 } 1293 } 1294 } 1295 return mode; 1296 } 1297 1298 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) 1299 I32 1300 my_chsize(int fd, Off_t length) 1301 { 1302 #ifdef F_FREESP 1303 /* code courtesy of William Kucharski */ 1304 #define HAS_CHSIZE 1305 1306 Stat_t filebuf; 1307 1308 if (PerlLIO_fstat(fd, &filebuf) < 0) 1309 return -1; 1310 1311 if (filebuf.st_size < length) { 1312 1313 /* extend file length */ 1314 1315 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) 1316 return -1; 1317 1318 /* write a "0" byte */ 1319 1320 if ((PerlLIO_write(fd, "", 1)) != 1) 1321 return -1; 1322 } 1323 else { 1324 /* truncate length */ 1325 struct flock fl; 1326 fl.l_whence = 0; 1327 fl.l_len = 0; 1328 fl.l_start = length; 1329 fl.l_type = F_WRLCK; /* write lock on file space */ 1330 1331 /* 1332 * This relies on the UNDOCUMENTED F_FREESP argument to 1333 * fcntl(2), which truncates the file so that it ends at the 1334 * position indicated by fl.l_start. 1335 * 1336 * Will minor miracles never cease? 1337 */ 1338 1339 if (fcntl(fd, F_FREESP, &fl) < 0) 1340 return -1; 1341 1342 } 1343 return 0; 1344 #else 1345 Perl_croak_nocontext("truncate not implemented"); 1346 #endif /* F_FREESP */ 1347 return -1; 1348 } 1349 #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ 1350 1351 bool 1352 Perl_do_print(pTHX_ SV *sv, PerlIO *fp) 1353 { 1354 PERL_ARGS_ASSERT_DO_PRINT; 1355 1356 /* assuming fp is checked earlier */ 1357 if (!sv) 1358 return TRUE; 1359 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { 1360 assert(!SvGMAGICAL(sv)); 1361 if (SvIsUV(sv)) 1362 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv)); 1363 else 1364 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv)); 1365 return !PerlIO_error(fp); 1366 } 1367 else { 1368 STRLEN len; 1369 /* Do this first to trigger any overloading. */ 1370 const char *tmps = SvPV_const(sv, len); 1371 U8 *tmpbuf = NULL; 1372 bool happy = TRUE; 1373 1374 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ 1375 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ 1376 /* We don't modify the original scalar. */ 1377 tmpbuf = bytes_to_utf8((const U8*) tmps, &len); 1378 tmps = (char *) tmpbuf; 1379 } 1380 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { 1381 (void) check_utf8_print((const U8*) tmps, len); 1382 } 1383 } /* else stream isn't utf8 */ 1384 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to 1385 convert to bytes */ 1386 STRLEN tmplen = len; 1387 bool utf8 = TRUE; 1388 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); 1389 if (!utf8) { 1390 1391 /* Here, succeeded in downgrading from utf8. Set up to below 1392 * output the converted value */ 1393 tmpbuf = result; 1394 tmps = (char *) tmpbuf; 1395 len = tmplen; 1396 } 1397 else { /* Non-utf8 output stream, but string only representable in 1398 utf8 */ 1399 assert((char *)result == tmps); 1400 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), 1401 "Wide character in %s", 1402 PL_op ? OP_DESC(PL_op) : "print" 1403 ); 1404 /* Could also check that isn't one of the things to avoid 1405 * in utf8 by using check_utf8_print(), but not doing so, 1406 * since the stream isn't a UTF8 stream */ 1407 } 1408 } 1409 /* To detect whether the process is about to overstep its 1410 * filesize limit we would need getrlimit(). We could then 1411 * also transparently raise the limit with setrlimit() -- 1412 * but only until the system hard limit/the filesystem limit, 1413 * at which we would get EPERM. Note that when using buffered 1414 * io the write failure can be delayed until the flush/close. --jhi */ 1415 if (len && (PerlIO_write(fp,tmps,len) == 0)) 1416 happy = FALSE; 1417 Safefree(tmpbuf); 1418 return happy ? !PerlIO_error(fp) : FALSE; 1419 } 1420 } 1421 1422 I32 1423 Perl_my_stat_flags(pTHX_ const U32 flags) 1424 { 1425 dSP; 1426 IO *io; 1427 GV* gv; 1428 1429 if (PL_op->op_flags & OPf_REF) { 1430 gv = cGVOP_gv; 1431 do_fstat: 1432 if (gv == PL_defgv) 1433 return PL_laststatval; 1434 io = GvIO(gv); 1435 do_fstat_have_io: 1436 PL_laststype = OP_STAT; 1437 PL_statgv = gv ? gv : (GV *)io; 1438 sv_setpvs(PL_statname, ""); 1439 if (io) { 1440 if (IoIFP(io)) { 1441 int fd = PerlIO_fileno(IoIFP(io)); 1442 if (fd < 0) { 1443 /* E.g. PerlIO::scalar has no real fd. */ 1444 return (PL_laststatval = -1); 1445 } else { 1446 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache)); 1447 } 1448 } else if (IoDIRP(io)) { 1449 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); 1450 } 1451 } 1452 PL_laststatval = -1; 1453 report_evil_fh(gv); 1454 return -1; 1455 } 1456 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 1457 == OPpFT_STACKED) 1458 return PL_laststatval; 1459 else { 1460 SV* const sv = TOPs; 1461 const char *s; 1462 STRLEN len; 1463 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { 1464 goto do_fstat; 1465 } 1466 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 1467 io = MUTABLE_IO(SvRV(sv)); 1468 gv = NULL; 1469 goto do_fstat_have_io; 1470 } 1471 1472 s = SvPV_flags_const(sv, len, flags); 1473 PL_statgv = NULL; 1474 sv_setpvn(PL_statname, s, len); 1475 s = SvPVX_const(PL_statname); /* s now NUL-terminated */ 1476 PL_laststype = OP_STAT; 1477 PL_laststatval = PerlLIO_stat(s, &PL_statcache); 1478 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { 1479 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ 1480 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 1481 GCC_DIAG_RESTORE; 1482 } 1483 return PL_laststatval; 1484 } 1485 } 1486 1487 1488 I32 1489 Perl_my_lstat_flags(pTHX_ const U32 flags) 1490 { 1491 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat"; 1492 dSP; 1493 const char *file; 1494 SV* const sv = TOPs; 1495 bool isio = FALSE; 1496 if (PL_op->op_flags & OPf_REF) { 1497 if (cGVOP_gv == PL_defgv) { 1498 if (PL_laststype != OP_LSTAT) 1499 Perl_croak(aTHX_ "%s", no_prev_lstat); 1500 return PL_laststatval; 1501 } 1502 PL_laststatval = -1; 1503 if (ckWARN(WARN_IO)) { 1504 /* diag_listed_as: Use of -l on filehandle%s */ 1505 Perl_warner(aTHX_ packWARN(WARN_IO), 1506 "Use of -l on filehandle %"HEKf, 1507 HEKfARG(GvENAME_HEK(cGVOP_gv))); 1508 } 1509 return -1; 1510 } 1511 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 1512 == OPpFT_STACKED) { 1513 if (PL_laststype != OP_LSTAT) 1514 Perl_croak(aTHX_ "%s", no_prev_lstat); 1515 return PL_laststatval; 1516 } 1517 1518 PL_laststype = OP_LSTAT; 1519 PL_statgv = NULL; 1520 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv)) 1521 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) ) 1522 ) 1523 || isGV_with_GP(sv) 1524 ) 1525 && ckWARN(WARN_IO)) { 1526 if (isio) 1527 /* diag_listed_as: Use of -l on filehandle%s */ 1528 Perl_warner(aTHX_ packWARN(WARN_IO), 1529 "Use of -l on filehandle"); 1530 else 1531 /* diag_listed_as: Use of -l on filehandle%s */ 1532 Perl_warner(aTHX_ packWARN(WARN_IO), 1533 "Use of -l on filehandle %"HEKf, 1534 HEKfARG(GvENAME_HEK((const GV *) 1535 (SvROK(sv) ? SvRV(sv) : sv)))); 1536 } 1537 file = SvPV_flags_const_nolen(sv, flags); 1538 sv_setpv(PL_statname,file); 1539 PL_laststatval = PerlLIO_lstat(file,&PL_statcache); 1540 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 1541 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ 1542 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); 1543 GCC_DIAG_RESTORE; 1544 } 1545 return PL_laststatval; 1546 } 1547 1548 static void 1549 S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) 1550 { 1551 const int e = errno; 1552 PERL_ARGS_ASSERT_EXEC_FAILED; 1553 1554 if (ckWARN(WARN_EXEC)) 1555 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", 1556 cmd, Strerror(e)); 1557 if (do_report) { 1558 /* XXX silently ignore failures */ 1559 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int))); 1560 PerlLIO_close(fd); 1561 } 1562 } 1563 1564 bool 1565 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, 1566 int fd, int do_report) 1567 { 1568 dVAR; 1569 PERL_ARGS_ASSERT_DO_AEXEC5; 1570 #if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) 1571 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); 1572 #else 1573 if (sp > mark) { 1574 const char **a; 1575 const char *tmps = NULL; 1576 Newx(PL_Argv, sp - mark + 1, const char*); 1577 a = PL_Argv; 1578 1579 while (++mark <= sp) { 1580 if (*mark) 1581 *a++ = SvPV_nolen_const(*mark); 1582 else 1583 *a++ = ""; 1584 } 1585 *a = NULL; 1586 if (really) 1587 tmps = SvPV_nolen_const(really); 1588 if ((!really && *PL_Argv[0] != '/') || 1589 (really && *tmps != '/')) /* will execvp use PATH? */ 1590 TAINT_ENV(); /* testing IFS here is overkill, probably */ 1591 PERL_FPU_PRE_EXEC 1592 if (really && *tmps) { 1593 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); 1594 } else { 1595 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); 1596 } 1597 PERL_FPU_POST_EXEC 1598 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report); 1599 } 1600 do_execfree(); 1601 #endif 1602 return FALSE; 1603 } 1604 1605 void 1606 Perl_do_execfree(pTHX) 1607 { 1608 Safefree(PL_Argv); 1609 PL_Argv = NULL; 1610 Safefree(PL_Cmd); 1611 PL_Cmd = NULL; 1612 } 1613 1614 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION 1615 1616 bool 1617 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) 1618 { 1619 dVAR; 1620 const char **a; 1621 char *s; 1622 char *buf; 1623 char *cmd; 1624 /* Make a copy so we can change it */ 1625 const Size_t cmdlen = strlen(incmd) + 1; 1626 1627 PERL_ARGS_ASSERT_DO_EXEC3; 1628 1629 Newx(buf, cmdlen, char); 1630 cmd = buf; 1631 memcpy(cmd, incmd, cmdlen); 1632 1633 while (*cmd && isSPACE(*cmd)) 1634 cmd++; 1635 1636 /* save an extra exec if possible */ 1637 1638 #ifdef CSH 1639 { 1640 char flags[PERL_FLAGS_MAX]; 1641 if (strnEQ(cmd,PL_cshname,PL_cshlen) && 1642 strnEQ(cmd+PL_cshlen," -c",3)) { 1643 my_strlcpy(flags, "-c", PERL_FLAGS_MAX); 1644 s = cmd+PL_cshlen+3; 1645 if (*s == 'f') { 1646 s++; 1647 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2); 1648 } 1649 if (*s == ' ') 1650 s++; 1651 if (*s++ == '\'') { 1652 char * const ncmd = s; 1653 1654 while (*s) 1655 s++; 1656 if (s[-1] == '\n') 1657 *--s = '\0'; 1658 if (s[-1] == '\'') { 1659 *--s = '\0'; 1660 PERL_FPU_PRE_EXEC 1661 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); 1662 PERL_FPU_POST_EXEC 1663 *s = '\''; 1664 S_exec_failed(aTHX_ PL_cshname, fd, do_report); 1665 Safefree(buf); 1666 return FALSE; 1667 } 1668 } 1669 } 1670 } 1671 #endif /* CSH */ 1672 1673 /* see if there are shell metacharacters in it */ 1674 1675 if (*cmd == '.' && isSPACE(cmd[1])) 1676 goto doshell; 1677 1678 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 1679 goto doshell; 1680 1681 s = cmd; 1682 while (isWORDCHAR(*s)) 1683 s++; /* catch VAR=val gizmo */ 1684 if (*s == '=') 1685 goto doshell; 1686 1687 for (s = cmd; *s; s++) { 1688 if (*s != ' ' && !isALPHA(*s) && 1689 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 1690 if (*s == '\n' && !s[1]) { 1691 *s = '\0'; 1692 break; 1693 } 1694 /* handle the 2>&1 construct at the end */ 1695 if (*s == '>' && s[1] == '&' && s[2] == '1' 1696 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) 1697 && (!s[3] || isSPACE(s[3]))) 1698 { 1699 const char *t = s + 3; 1700 1701 while (*t && isSPACE(*t)) 1702 ++t; 1703 if (!*t && (PerlLIO_dup2(1,2) != -1)) { 1704 s[-2] = '\0'; 1705 break; 1706 } 1707 } 1708 doshell: 1709 PERL_FPU_PRE_EXEC 1710 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); 1711 PERL_FPU_POST_EXEC 1712 S_exec_failed(aTHX_ PL_sh_path, fd, do_report); 1713 Safefree(buf); 1714 return FALSE; 1715 } 1716 } 1717 1718 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*); 1719 PL_Cmd = savepvn(cmd, s-cmd); 1720 a = PL_Argv; 1721 for (s = PL_Cmd; *s;) { 1722 while (isSPACE(*s)) 1723 s++; 1724 if (*s) 1725 *(a++) = s; 1726 while (*s && !isSPACE(*s)) 1727 s++; 1728 if (*s) 1729 *s++ = '\0'; 1730 } 1731 *a = NULL; 1732 if (PL_Argv[0]) { 1733 PERL_FPU_PRE_EXEC 1734 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); 1735 PERL_FPU_POST_EXEC 1736 if (errno == ENOEXEC) { /* for system V NIH syndrome */ 1737 do_execfree(); 1738 goto doshell; 1739 } 1740 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report); 1741 } 1742 do_execfree(); 1743 Safefree(buf); 1744 return FALSE; 1745 } 1746 1747 #endif /* OS2 || WIN32 */ 1748 1749 I32 1750 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) 1751 { 1752 I32 val; 1753 I32 tot = 0; 1754 const char *const what = PL_op_name[type]; 1755 const char *s; 1756 STRLEN len; 1757 SV ** const oldmark = mark; 1758 bool killgp = FALSE; 1759 1760 PERL_ARGS_ASSERT_APPLY; 1761 1762 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */ 1763 1764 /* Doing this ahead of the switch statement preserves the old behaviour, 1765 where attempting to use kill as a taint test test would fail on 1766 platforms where kill was not defined. */ 1767 #ifndef HAS_KILL 1768 if (type == OP_KILL) 1769 Perl_die(aTHX_ PL_no_func, what); 1770 #endif 1771 #ifndef HAS_CHOWN 1772 if (type == OP_CHOWN) 1773 Perl_die(aTHX_ PL_no_func, what); 1774 #endif 1775 1776 1777 #define APPLY_TAINT_PROPER() \ 1778 STMT_START { \ 1779 if (TAINT_get) { TAINT_PROPER(what); } \ 1780 } STMT_END 1781 1782 /* This is a first heuristic; it doesn't catch tainting magic. */ 1783 if (TAINTING_get) { 1784 while (++mark <= sp) { 1785 if (SvTAINTED(*mark)) { 1786 TAINT; 1787 break; 1788 } 1789 } 1790 mark = oldmark; 1791 } 1792 switch (type) { 1793 case OP_CHMOD: 1794 APPLY_TAINT_PROPER(); 1795 if (++mark <= sp) { 1796 val = SvIV(*mark); 1797 APPLY_TAINT_PROPER(); 1798 tot = sp - mark; 1799 while (++mark <= sp) { 1800 GV* gv; 1801 if ((gv = MAYBE_DEREF_GV(*mark))) { 1802 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 1803 #ifdef HAS_FCHMOD 1804 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 1805 APPLY_TAINT_PROPER(); 1806 if (fd < 0) { 1807 SETERRNO(EBADF,RMS_IFI); 1808 tot--; 1809 } else if (fchmod(fd, val)) 1810 tot--; 1811 #else 1812 Perl_die(aTHX_ PL_no_func, "fchmod"); 1813 #endif 1814 } 1815 else { 1816 SETERRNO(EBADF,RMS_IFI); 1817 tot--; 1818 } 1819 } 1820 else { 1821 const char *name = SvPV_nomg_const(*mark, len); 1822 APPLY_TAINT_PROPER(); 1823 if (!IS_SAFE_PATHNAME(name, len, "chmod") || 1824 PerlLIO_chmod(name, val)) { 1825 tot--; 1826 } 1827 } 1828 } 1829 } 1830 break; 1831 #ifdef HAS_CHOWN 1832 case OP_CHOWN: 1833 APPLY_TAINT_PROPER(); 1834 if (sp - mark > 2) { 1835 I32 val2; 1836 val = SvIVx(*++mark); 1837 val2 = SvIVx(*++mark); 1838 APPLY_TAINT_PROPER(); 1839 tot = sp - mark; 1840 while (++mark <= sp) { 1841 GV* gv; 1842 if ((gv = MAYBE_DEREF_GV(*mark))) { 1843 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 1844 #ifdef HAS_FCHOWN 1845 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 1846 APPLY_TAINT_PROPER(); 1847 if (fd < 0) { 1848 SETERRNO(EBADF,RMS_IFI); 1849 tot--; 1850 } else if (fchown(fd, val, val2)) 1851 tot--; 1852 #else 1853 Perl_die(aTHX_ PL_no_func, "fchown"); 1854 #endif 1855 } 1856 else { 1857 SETERRNO(EBADF,RMS_IFI); 1858 tot--; 1859 } 1860 } 1861 else { 1862 const char *name = SvPV_nomg_const(*mark, len); 1863 APPLY_TAINT_PROPER(); 1864 if (!IS_SAFE_PATHNAME(name, len, "chown") || 1865 PerlLIO_chown(name, val, val2)) { 1866 tot--; 1867 } 1868 } 1869 } 1870 } 1871 break; 1872 #endif 1873 /* 1874 XXX Should we make lchown() directly available from perl? 1875 For now, we'll let Configure test for HAS_LCHOWN, but do 1876 nothing in the core. 1877 --AD 5/1998 1878 */ 1879 #ifdef HAS_KILL 1880 case OP_KILL: 1881 APPLY_TAINT_PROPER(); 1882 if (mark == sp) 1883 break; 1884 s = SvPVx_const(*++mark, len); 1885 if (*s == '-' && isALPHA(s[1])) 1886 { 1887 s++; 1888 len--; 1889 killgp = TRUE; 1890 } 1891 if (isALPHA(*s)) { 1892 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { 1893 s += 3; 1894 len -= 3; 1895 } 1896 if ((val = whichsig_pvn(s, len)) < 0) 1897 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark)); 1898 } 1899 else 1900 { 1901 val = SvIV(*mark); 1902 if (val < 0) 1903 { 1904 killgp = TRUE; 1905 val = -val; 1906 } 1907 } 1908 APPLY_TAINT_PROPER(); 1909 tot = sp - mark; 1910 1911 while (++mark <= sp) { 1912 Pid_t proc; 1913 SvGETMAGIC(*mark); 1914 if (!(SvNIOK(*mark) || looks_like_number(*mark))) 1915 Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); 1916 proc = SvIV_nomg(*mark); 1917 APPLY_TAINT_PROPER(); 1918 #ifdef HAS_KILLPG 1919 /* use killpg in preference, as the killpg() wrapper for Win32 1920 * understands process groups, but the kill() wrapper doesn't */ 1921 if (killgp ? PerlProc_killpg(proc, val) 1922 : PerlProc_kill(proc, val)) 1923 #else 1924 if (PerlProc_kill(killgp ? -proc: proc, val)) 1925 #endif 1926 tot--; 1927 } 1928 PERL_ASYNC_CHECK(); 1929 break; 1930 #endif 1931 case OP_UNLINK: 1932 APPLY_TAINT_PROPER(); 1933 tot = sp - mark; 1934 while (++mark <= sp) { 1935 s = SvPV_const(*mark, len); 1936 APPLY_TAINT_PROPER(); 1937 if (!IS_SAFE_PATHNAME(s, len, "unlink")) { 1938 tot--; 1939 } 1940 else if (PL_unsafe) { 1941 if (UNLINK(s)) 1942 { 1943 tot--; 1944 } 1945 #if defined(__amigaos4__) && defined(NEWLIB) 1946 else 1947 { 1948 /* Under AmigaOS4 unlink only 'fails' if the 1949 * filename is invalid. It may not remove the file 1950 * if it's locked, so check if it's still around. */ 1951 if ((access(s,F_OK) != -1)) 1952 { 1953 tot--; 1954 } 1955 } 1956 #endif 1957 } 1958 else { /* don't let root wipe out directories without -U */ 1959 Stat_t statbuf; 1960 if (PerlLIO_lstat(s, &statbuf) < 0) 1961 tot--; 1962 else if (S_ISDIR(statbuf.st_mode)) { 1963 SETERRNO(EISDIR, SS_NOPRIV); 1964 tot--; 1965 } 1966 else { 1967 if (UNLINK(s)) 1968 { 1969 tot--; 1970 } 1971 #if defined(__amigaos4__) && defined(NEWLIB) 1972 else 1973 { 1974 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ 1975 /* It may not remove the file if it's Locked, so check if it's still */ 1976 /* arround */ 1977 if((access(s,F_OK) != -1)) 1978 { 1979 tot--; 1980 } 1981 } 1982 #endif 1983 } 1984 } 1985 } 1986 break; 1987 #if defined(HAS_UTIME) || defined(HAS_FUTIMES) 1988 case OP_UTIME: 1989 APPLY_TAINT_PROPER(); 1990 if (sp - mark > 2) { 1991 #if defined(HAS_FUTIMES) 1992 struct timeval utbuf[2]; 1993 void *utbufp = utbuf; 1994 #elif defined(I_UTIME) || defined(VMS) 1995 struct utimbuf utbuf; 1996 struct utimbuf *utbufp = &utbuf; 1997 #else 1998 struct { 1999 Time_t actime; 2000 Time_t modtime; 2001 } utbuf; 2002 void *utbufp = &utbuf; 2003 #endif 2004 2005 SV* const accessed = *++mark; 2006 SV* const modified = *++mark; 2007 2008 /* Be like C, and if both times are undefined, let the C 2009 * library figure out what to do. This usually means 2010 * "current time". */ 2011 2012 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) 2013 utbufp = NULL; 2014 else { 2015 Zero(&utbuf, sizeof utbuf, char); 2016 #ifdef HAS_FUTIMES 2017 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ 2018 utbuf[0].tv_usec = 0; 2019 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ 2020 utbuf[1].tv_usec = 0; 2021 #elif defined(BIG_TIME) 2022 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */ 2023 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */ 2024 #else 2025 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */ 2026 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */ 2027 #endif 2028 } 2029 APPLY_TAINT_PROPER(); 2030 tot = sp - mark; 2031 while (++mark <= sp) { 2032 GV* gv; 2033 if ((gv = MAYBE_DEREF_GV(*mark))) { 2034 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 2035 #ifdef HAS_FUTIMES 2036 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 2037 APPLY_TAINT_PROPER(); 2038 if (fd < 0) { 2039 SETERRNO(EBADF,RMS_IFI); 2040 tot--; 2041 } else if (futimes(fd, (struct timeval *) utbufp)) 2042 tot--; 2043 #else 2044 Perl_die(aTHX_ PL_no_func, "futimes"); 2045 #endif 2046 } 2047 else { 2048 tot--; 2049 } 2050 } 2051 else { 2052 const char * const name = SvPV_nomg_const(*mark, len); 2053 APPLY_TAINT_PROPER(); 2054 if (!IS_SAFE_PATHNAME(name, len, "utime")) { 2055 tot--; 2056 } 2057 else 2058 #ifdef HAS_FUTIMES 2059 if (utimes(name, (struct timeval *)utbufp)) 2060 #else 2061 if (PerlLIO_utime(name, utbufp)) 2062 #endif 2063 tot--; 2064 } 2065 2066 } 2067 } 2068 else 2069 tot = 0; 2070 break; 2071 #endif 2072 } 2073 return tot; 2074 2075 #undef APPLY_TAINT_PROPER 2076 } 2077 2078 /* Do the permissions allow some operation? Assumes statcache already set. */ 2079 #ifndef VMS /* VMS' cando is in vms.c */ 2080 bool 2081 Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) 2082 /* effective is a flag, true for EUID, or for checking if the effective gid 2083 * is in the list of groups returned from getgroups(). 2084 */ 2085 { 2086 PERL_ARGS_ASSERT_CANDO; 2087 PERL_UNUSED_CONTEXT; 2088 2089 #ifdef DOSISH 2090 /* [Comments and code from Len Reed] 2091 * MS-DOS "user" is similar to UNIX's "superuser," but can't write 2092 * to write-protected files. The execute permission bit is set 2093 * by the Microsoft C library stat() function for the following: 2094 * .exe files 2095 * .com files 2096 * .bat files 2097 * directories 2098 * All files and directories are readable. 2099 * Directories and special files, e.g. "CON", cannot be 2100 * write-protected. 2101 * [Comment by Tom Dinger -- a directory can have the write-protect 2102 * bit set in the file system, but DOS permits changes to 2103 * the directory anyway. In addition, all bets are off 2104 * here for networked software, such as Novell and 2105 * Sun's PC-NFS.] 2106 */ 2107 2108 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat 2109 * too so it will actually look into the files for magic numbers 2110 */ 2111 return (mode & statbufp->st_mode) ? TRUE : FALSE; 2112 2113 #else /* ! DOSISH */ 2114 # ifdef __CYGWIN__ 2115 if (ingroup(544,effective)) { /* member of Administrators */ 2116 # else 2117 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */ 2118 # endif 2119 if (mode == S_IXUSR) { 2120 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) 2121 return TRUE; 2122 } 2123 else 2124 return TRUE; /* root reads and writes anything */ 2125 return FALSE; 2126 } 2127 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) { 2128 if (statbufp->st_mode & mode) 2129 return TRUE; /* ok as "user" */ 2130 } 2131 else if (ingroup(statbufp->st_gid,effective)) { 2132 if (statbufp->st_mode & mode >> 3) 2133 return TRUE; /* ok as "group" */ 2134 } 2135 else if (statbufp->st_mode & mode >> 6) 2136 return TRUE; /* ok as "other" */ 2137 return FALSE; 2138 #endif /* ! DOSISH */ 2139 } 2140 #endif /* ! VMS */ 2141 2142 static bool 2143 S_ingroup(pTHX_ Gid_t testgid, bool effective) 2144 { 2145 #ifndef PERL_IMPLICIT_SYS 2146 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */ 2147 PERL_UNUSED_CONTEXT; 2148 #endif 2149 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid())) 2150 return TRUE; 2151 #ifdef HAS_GETGROUPS 2152 { 2153 Groups_t *gary = NULL; 2154 I32 anum; 2155 bool rc = FALSE; 2156 2157 anum = getgroups(0, gary); 2158 if (anum > 0) { 2159 Newx(gary, anum, Groups_t); 2160 anum = getgroups(anum, gary); 2161 while (--anum >= 0) 2162 if (gary[anum] == testgid) { 2163 rc = TRUE; 2164 break; 2165 } 2166 2167 Safefree(gary); 2168 } 2169 return rc; 2170 } 2171 #else 2172 return FALSE; 2173 #endif 2174 } 2175 2176 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 2177 2178 I32 2179 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) 2180 { 2181 const key_t key = (key_t)SvNVx(*++mark); 2182 SV *nsv = optype == OP_MSGGET ? NULL : *++mark; 2183 const I32 flags = SvIVx(*++mark); 2184 2185 PERL_ARGS_ASSERT_DO_IPCGET; 2186 PERL_UNUSED_ARG(sp); 2187 2188 SETERRNO(0,0); 2189 switch (optype) 2190 { 2191 #ifdef HAS_MSG 2192 case OP_MSGGET: 2193 return msgget(key, flags); 2194 #endif 2195 #ifdef HAS_SEM 2196 case OP_SEMGET: 2197 return semget(key, (int) SvIV(nsv), flags); 2198 #endif 2199 #ifdef HAS_SHM 2200 case OP_SHMGET: 2201 return shmget(key, (size_t) SvUV(nsv), flags); 2202 #endif 2203 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 2204 default: 2205 /* diag_listed_as: msg%s not implemented */ 2206 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2207 #endif 2208 } 2209 return -1; /* should never happen */ 2210 } 2211 2212 I32 2213 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) 2214 { 2215 char *a; 2216 I32 ret = -1; 2217 const I32 id = SvIVx(*++mark); 2218 #ifdef Semctl 2219 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; 2220 #endif 2221 const I32 cmd = SvIVx(*++mark); 2222 SV * const astr = *++mark; 2223 STRLEN infosize = 0; 2224 I32 getinfo = (cmd == IPC_STAT); 2225 2226 PERL_ARGS_ASSERT_DO_IPCCTL; 2227 PERL_UNUSED_ARG(sp); 2228 2229 switch (optype) 2230 { 2231 #ifdef HAS_MSG 2232 case OP_MSGCTL: 2233 if (cmd == IPC_STAT || cmd == IPC_SET) 2234 infosize = sizeof(struct msqid_ds); 2235 break; 2236 #endif 2237 #ifdef HAS_SHM 2238 case OP_SHMCTL: 2239 if (cmd == IPC_STAT || cmd == IPC_SET) 2240 infosize = sizeof(struct shmid_ds); 2241 break; 2242 #endif 2243 #ifdef HAS_SEM 2244 case OP_SEMCTL: 2245 #ifdef Semctl 2246 if (cmd == IPC_STAT || cmd == IPC_SET) 2247 infosize = sizeof(struct semid_ds); 2248 else if (cmd == GETALL || cmd == SETALL) 2249 { 2250 struct semid_ds semds; 2251 union semun semun; 2252 #ifdef EXTRA_F_IN_SEMUN_BUF 2253 semun.buff = &semds; 2254 #else 2255 semun.buf = &semds; 2256 #endif 2257 getinfo = (cmd == GETALL); 2258 if (Semctl(id, 0, IPC_STAT, semun) == -1) 2259 return -1; 2260 infosize = semds.sem_nsems * sizeof(short); 2261 /* "short" is technically wrong but much more portable 2262 than guessing about u_?short(_t)? */ 2263 } 2264 #else 2265 /* diag_listed_as: sem%s not implemented */ 2266 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2267 #endif 2268 break; 2269 #endif 2270 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 2271 default: 2272 /* diag_listed_as: shm%s not implemented */ 2273 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2274 #endif 2275 } 2276 2277 if (infosize) 2278 { 2279 if (getinfo) 2280 { 2281 SvPV_force_nolen(astr); 2282 a = SvGROW(astr, infosize+1); 2283 } 2284 else 2285 { 2286 STRLEN len; 2287 a = SvPV(astr, len); 2288 if (len != infosize) 2289 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", 2290 PL_op_desc[optype], 2291 (unsigned long)len, 2292 (long)infosize); 2293 } 2294 } 2295 else 2296 { 2297 const IV i = SvIV(astr); 2298 a = INT2PTR(char *,i); /* ouch */ 2299 } 2300 SETERRNO(0,0); 2301 switch (optype) 2302 { 2303 #ifdef HAS_MSG 2304 case OP_MSGCTL: 2305 ret = msgctl(id, cmd, (struct msqid_ds *)a); 2306 break; 2307 #endif 2308 #ifdef HAS_SEM 2309 case OP_SEMCTL: { 2310 #ifdef Semctl 2311 union semun unsemds; 2312 2313 if(cmd == SETVAL) { 2314 unsemds.val = PTR2nat(a); 2315 } 2316 else { 2317 #ifdef EXTRA_F_IN_SEMUN_BUF 2318 unsemds.buff = (struct semid_ds *)a; 2319 #else 2320 unsemds.buf = (struct semid_ds *)a; 2321 #endif 2322 } 2323 ret = Semctl(id, n, cmd, unsemds); 2324 #else 2325 /* diag_listed_as: sem%s not implemented */ 2326 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2327 #endif 2328 } 2329 break; 2330 #endif 2331 #ifdef HAS_SHM 2332 case OP_SHMCTL: 2333 ret = shmctl(id, cmd, (struct shmid_ds *)a); 2334 break; 2335 #endif 2336 } 2337 if (getinfo && ret >= 0) { 2338 SvCUR_set(astr, infosize); 2339 *SvEND(astr) = '\0'; 2340 SvSETMAGIC(astr); 2341 } 2342 return ret; 2343 } 2344 2345 I32 2346 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) 2347 { 2348 #ifdef HAS_MSG 2349 STRLEN len; 2350 const I32 id = SvIVx(*++mark); 2351 SV * const mstr = *++mark; 2352 const I32 flags = SvIVx(*++mark); 2353 const char * const mbuf = SvPV_const(mstr, len); 2354 const I32 msize = len - sizeof(long); 2355 2356 PERL_ARGS_ASSERT_DO_MSGSND; 2357 PERL_UNUSED_ARG(sp); 2358 2359 if (msize < 0) 2360 Perl_croak(aTHX_ "Arg too short for msgsnd"); 2361 SETERRNO(0,0); 2362 if (id >= 0 && flags >= 0) { 2363 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); 2364 } else { 2365 SETERRNO(EINVAL,LIB_INVARG); 2366 return -1; 2367 } 2368 #else 2369 PERL_UNUSED_ARG(sp); 2370 PERL_UNUSED_ARG(mark); 2371 /* diag_listed_as: msg%s not implemented */ 2372 Perl_croak(aTHX_ "msgsnd not implemented"); 2373 return -1; 2374 #endif 2375 } 2376 2377 I32 2378 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) 2379 { 2380 #ifdef HAS_MSG 2381 char *mbuf; 2382 long mtype; 2383 I32 msize, flags, ret; 2384 const I32 id = SvIVx(*++mark); 2385 SV * const mstr = *++mark; 2386 2387 PERL_ARGS_ASSERT_DO_MSGRCV; 2388 PERL_UNUSED_ARG(sp); 2389 2390 /* suppress warning when reading into undef var --jhi */ 2391 if (! SvOK(mstr)) 2392 sv_setpvs(mstr, ""); 2393 msize = SvIVx(*++mark); 2394 mtype = (long)SvIVx(*++mark); 2395 flags = SvIVx(*++mark); 2396 SvPV_force_nolen(mstr); 2397 mbuf = SvGROW(mstr, sizeof(long)+msize+1); 2398 2399 SETERRNO(0,0); 2400 if (id >= 0 && msize >= 0 && flags >= 0) { 2401 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); 2402 } else { 2403 SETERRNO(EINVAL,LIB_INVARG); 2404 ret = -1; 2405 } 2406 if (ret >= 0) { 2407 SvCUR_set(mstr, sizeof(long)+ret); 2408 *SvEND(mstr) = '\0'; 2409 /* who knows who has been playing with this message? */ 2410 SvTAINTED_on(mstr); 2411 } 2412 return ret; 2413 #else 2414 PERL_UNUSED_ARG(sp); 2415 PERL_UNUSED_ARG(mark); 2416 /* diag_listed_as: msg%s not implemented */ 2417 Perl_croak(aTHX_ "msgrcv not implemented"); 2418 return -1; 2419 #endif 2420 } 2421 2422 I32 2423 Perl_do_semop(pTHX_ SV **mark, SV **sp) 2424 { 2425 #ifdef HAS_SEM 2426 STRLEN opsize; 2427 const I32 id = SvIVx(*++mark); 2428 SV * const opstr = *++mark; 2429 const char * const opbuf = SvPV_const(opstr, opsize); 2430 2431 PERL_ARGS_ASSERT_DO_SEMOP; 2432 PERL_UNUSED_ARG(sp); 2433 2434 if (opsize < 3 * SHORTSIZE 2435 || (opsize % (3 * SHORTSIZE))) { 2436 SETERRNO(EINVAL,LIB_INVARG); 2437 return -1; 2438 } 2439 SETERRNO(0,0); 2440 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ 2441 { 2442 const int nsops = opsize / (3 * sizeof (short)); 2443 int i = nsops; 2444 short * const ops = (short *) opbuf; 2445 short *o = ops; 2446 struct sembuf *temps, *t; 2447 I32 result; 2448 2449 Newx (temps, nsops, struct sembuf); 2450 t = temps; 2451 while (i--) { 2452 t->sem_num = *o++; 2453 t->sem_op = *o++; 2454 t->sem_flg = *o++; 2455 t++; 2456 } 2457 result = semop(id, temps, nsops); 2458 Safefree(temps); 2459 return result; 2460 } 2461 #else 2462 /* diag_listed_as: sem%s not implemented */ 2463 Perl_croak(aTHX_ "semop not implemented"); 2464 #endif 2465 } 2466 2467 I32 2468 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 2469 { 2470 #ifdef HAS_SHM 2471 char *shm; 2472 struct shmid_ds shmds; 2473 const I32 id = SvIVx(*++mark); 2474 SV * const mstr = *++mark; 2475 const I32 mpos = SvIVx(*++mark); 2476 const I32 msize = SvIVx(*++mark); 2477 2478 PERL_ARGS_ASSERT_DO_SHMIO; 2479 PERL_UNUSED_ARG(sp); 2480 2481 SETERRNO(0,0); 2482 if (shmctl(id, IPC_STAT, &shmds) == -1) 2483 return -1; 2484 if (mpos < 0 || msize < 0 2485 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { 2486 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ 2487 return -1; 2488 } 2489 if (id >= 0) { 2490 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); 2491 } else { 2492 SETERRNO(EINVAL,LIB_INVARG); 2493 return -1; 2494 } 2495 if (shm == (char *)-1) /* I hate System V IPC, I really do */ 2496 return -1; 2497 if (optype == OP_SHMREAD) { 2498 char *mbuf; 2499 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ 2500 SvGETMAGIC(mstr); 2501 SvUPGRADE(mstr, SVt_PV); 2502 if (! SvOK(mstr)) 2503 sv_setpvs(mstr, ""); 2504 SvPOK_only(mstr); 2505 mbuf = SvGROW(mstr, (STRLEN)msize+1); 2506 2507 Copy(shm + mpos, mbuf, msize, char); 2508 SvCUR_set(mstr, msize); 2509 *SvEND(mstr) = '\0'; 2510 SvSETMAGIC(mstr); 2511 /* who knows who has been playing with this shared memory? */ 2512 SvTAINTED_on(mstr); 2513 } 2514 else { 2515 STRLEN len; 2516 2517 const char *mbuf = SvPV_const(mstr, len); 2518 const I32 n = ((I32)len > msize) ? msize : (I32)len; 2519 Copy(mbuf, shm + mpos, n, char); 2520 if (n < msize) 2521 memzero(shm + mpos + n, msize - n); 2522 } 2523 return shmdt(shm); 2524 #else 2525 /* diag_listed_as: shm%s not implemented */ 2526 Perl_croak(aTHX_ "shm I/O not implemented"); 2527 return -1; 2528 #endif 2529 } 2530 2531 #endif /* SYSV IPC */ 2532 2533 /* 2534 =head1 IO Functions 2535 2536 =for apidoc start_glob 2537 2538 Function called by C<do_readline> to spawn a glob (or do the glob inside 2539 perl on VMS). This code used to be inline, but now perl uses C<File::Glob> 2540 this glob starter is only used by miniperl during the build process, 2541 or when PERL_EXTERNAL_GLOB is defined. 2542 Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up. 2543 2544 =cut 2545 */ 2546 2547 PerlIO * 2548 Perl_start_glob (pTHX_ SV *tmpglob, IO *io) 2549 { 2550 SV * const tmpcmd = newSV(0); 2551 PerlIO *fp; 2552 STRLEN len; 2553 const char *s = SvPV(tmpglob, len); 2554 2555 PERL_ARGS_ASSERT_START_GLOB; 2556 2557 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob")) 2558 return NULL; 2559 2560 ENTER; 2561 SAVEFREESV(tmpcmd); 2562 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ 2563 /* since spawning off a process is a real performance hit */ 2564 2565 PerlIO * 2566 Perl_vms_start_glob 2567 (pTHX_ SV *tmpglob, 2568 IO *io); 2569 2570 fp = Perl_vms_start_glob(aTHX_ tmpglob, io); 2571 2572 #else /* !VMS */ 2573 #ifdef DOSISH 2574 #ifdef OS2 2575 sv_setpv(tmpcmd, "for a in "); 2576 sv_catsv(tmpcmd, tmpglob); 2577 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); 2578 #else 2579 #ifdef DJGPP 2580 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ 2581 sv_catsv(tmpcmd, tmpglob); 2582 #else 2583 sv_setpv(tmpcmd, "perlglob "); 2584 sv_catsv(tmpcmd, tmpglob); 2585 sv_catpv(tmpcmd, " |"); 2586 #endif /* !DJGPP */ 2587 #endif /* !OS2 */ 2588 #else /* !DOSISH */ 2589 #if defined(CSH) 2590 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); 2591 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); 2592 sv_catsv(tmpcmd, tmpglob); 2593 sv_catpv(tmpcmd, "' 2>/dev/null |"); 2594 #else 2595 sv_setpv(tmpcmd, "echo "); 2596 sv_catsv(tmpcmd, tmpglob); 2597 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); 2598 #endif /* !CSH */ 2599 #endif /* !DOSISH */ 2600 { 2601 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV); 2602 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0); 2603 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0); 2604 if (home && *home) SvGETMAGIC(*home); 2605 if (path && *path) SvGETMAGIC(*path); 2606 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV)); 2607 if (home && *home) SvSETMAGIC(*home); 2608 if (path && *path) SvSETMAGIC(*path); 2609 } 2610 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd), 2611 NULL, NULL, 0); 2612 fp = IoIFP(io); 2613 #endif /* !VMS */ 2614 LEAVE; 2615 2616 if (!fp && ckWARN(WARN_GLOB)) { 2617 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", 2618 Strerror(errno)); 2619 } 2620 2621 return fp; 2622 } 2623 2624 /* 2625 * ex: set ts=8 sts=4 sw=4 et: 2626 */ 2627