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 void 64 Perl_setfd_cloexec(int fd) 65 { 66 assert(fd >= 0); 67 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) 68 (void) fcntl(fd, F_SETFD, FD_CLOEXEC); 69 #endif 70 } 71 72 void 73 Perl_setfd_inhexec(int fd) 74 { 75 assert(fd >= 0); 76 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) 77 (void) fcntl(fd, F_SETFD, 0); 78 #endif 79 } 80 81 void 82 Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd) 83 { 84 assert(fd >= 0); 85 if(fd > PL_maxsysfd) 86 setfd_cloexec(fd); 87 } 88 89 void 90 Perl_setfd_inhexec_for_sysfd(pTHX_ int fd) 91 { 92 assert(fd >= 0); 93 if(fd <= PL_maxsysfd) 94 setfd_inhexec(fd); 95 } 96 void 97 Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd) 98 { 99 assert(fd >= 0); 100 if(fd <= PL_maxsysfd) 101 setfd_inhexec(fd); 102 else 103 setfd_cloexec(fd); 104 } 105 106 107 #define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ 108 do { \ 109 int res = (GENOPEN_NORMAL); \ 110 if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \ 111 return res; \ 112 } while(0) 113 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \ 114 defined(F_GETFD) 115 enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; 116 # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ 117 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ 118 do { \ 119 switch (strategy) { \ 120 case CLOEXEC_EXPERIMENT: default: { \ 121 int res = (GENOPEN_CLOEXEC), eno; \ 122 if (LIKELY(res != -1)) { \ 123 int fdflags = fcntl((TESTFD), F_GETFD); \ 124 if (LIKELY(fdflags != -1) && \ 125 LIKELY(fdflags & FD_CLOEXEC)) { \ 126 strategy = CLOEXEC_AT_OPEN; \ 127 } else { \ 128 strategy = CLOEXEC_AFTER_OPEN; \ 129 GENSETFD_CLOEXEC; \ 130 } \ 131 } else if (UNLIKELY((eno = errno) == EINVAL || \ 132 eno == ENOSYS)) { \ 133 res = (GENOPEN_NORMAL); \ 134 if (LIKELY(res != -1)) { \ 135 strategy = CLOEXEC_AFTER_OPEN; \ 136 GENSETFD_CLOEXEC; \ 137 } else if (!LIKELY((eno = errno) == EINVAL || \ 138 eno == ENOSYS)) { \ 139 strategy = CLOEXEC_AFTER_OPEN; \ 140 } \ 141 } \ 142 return res; \ 143 } \ 144 case CLOEXEC_AT_OPEN: \ 145 return (GENOPEN_CLOEXEC); \ 146 case CLOEXEC_AFTER_OPEN: \ 147 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \ 148 } \ 149 } while(0) 150 #else 151 # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ 152 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ 153 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) 154 #endif 155 156 #define DO_ONEOPEN_THEN_CLOEXEC(ONEOPEN_NORMAL) \ 157 do { \ 158 int fd; \ 159 DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ 160 setfd_cloexec(fd)); \ 161 } while(0) 162 #define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \ 163 ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \ 164 do { \ 165 int fd; \ 166 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ 167 fd, \ 168 fd = (ONEOPEN_CLOEXEC), \ 169 fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ 170 } while(0) 171 172 #define DO_PIPESETFD_CLOEXEC(PIPEFD) \ 173 do { \ 174 setfd_cloexec((PIPEFD)[0]); \ 175 setfd_cloexec((PIPEFD)[1]); \ 176 } while(0) 177 #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \ 178 DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) 179 #define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \ 180 PIPEOPEN_NORMAL) \ 181 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ 182 (PIPEFD)[0], PIPEOPEN_CLOEXEC, \ 183 PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) 184 185 int 186 Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) 187 { 188 #if !defined(PERL_IMPLICIT_SYS) && defined(F_DUPFD_CLOEXEC) 189 /* 190 * struct IPerlLIO doesn't cover fcntl(), and there's no clear way 191 * to extend it, so for the time being this just isn't available on 192 * PERL_IMPLICIT_SYS builds. 193 */ 194 dVAR; 195 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 196 PL_strategy_dup, 197 fcntl(oldfd, F_DUPFD_CLOEXEC, 0), 198 PerlLIO_dup(oldfd)); 199 #else 200 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup(oldfd)); 201 #endif 202 } 203 204 int 205 Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd) 206 { 207 #if !defined(PERL_IMPLICIT_SYS) && defined(HAS_DUP3) && defined(O_CLOEXEC) 208 /* 209 * struct IPerlLIO doesn't cover dup3(), and there's no clear way 210 * to extend it, so for the time being this just isn't available on 211 * PERL_IMPLICIT_SYS builds. 212 */ 213 dVAR; 214 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 215 PL_strategy_dup2, 216 dup3(oldfd, newfd, O_CLOEXEC), 217 PerlLIO_dup2(oldfd, newfd)); 218 #else 219 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup2(oldfd, newfd)); 220 #endif 221 } 222 223 int 224 Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag) 225 { 226 dVAR; 227 PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC; 228 #if defined(O_CLOEXEC) 229 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 230 PL_strategy_open, 231 PerlLIO_open(file, flag | O_CLOEXEC), 232 PerlLIO_open(file, flag)); 233 #else 234 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open(file, flag)); 235 #endif 236 } 237 238 int 239 Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm) 240 { 241 dVAR; 242 PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC; 243 #if defined(O_CLOEXEC) 244 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 245 PL_strategy_open3, 246 PerlLIO_open3(file, flag | O_CLOEXEC, perm), 247 PerlLIO_open3(file, flag, perm)); 248 #else 249 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open3(file, flag, perm)); 250 #endif 251 } 252 253 int 254 Perl_my_mkstemp_cloexec(char *templte) 255 { 256 dVAR; 257 PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC; 258 #if defined(O_CLOEXEC) 259 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 260 PL_strategy_mkstemp, 261 Perl_my_mkostemp(templte, O_CLOEXEC), 262 Perl_my_mkstemp(templte)); 263 #else 264 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte)); 265 #endif 266 } 267 268 int 269 Perl_my_mkostemp_cloexec(char *templte, int flags) 270 { 271 dVAR; 272 PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC; 273 #if defined(O_CLOEXEC) 274 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 275 PL_strategy_mkstemp, 276 Perl_my_mkostemp(templte, flags | O_CLOEXEC), 277 Perl_my_mkostemp(templte, flags)); 278 #else 279 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags)); 280 #endif 281 } 282 283 #ifdef HAS_PIPE 284 int 285 Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd) 286 { 287 dVAR; 288 PERL_ARGS_ASSERT_PERLPROC_PIPE_CLOEXEC; 289 /* 290 * struct IPerlProc doesn't cover pipe2(), and there's no clear way 291 * to extend it, so for the time being this just isn't available on 292 * PERL_IMPLICIT_SYS builds. 293 */ 294 # if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC) 295 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd, 296 pipe2(pipefd, O_CLOEXEC), 297 PerlProc_pipe(pipefd)); 298 # else 299 DO_PIPEOPEN_THEN_CLOEXEC(pipefd, PerlProc_pipe(pipefd)); 300 # endif 301 } 302 #endif 303 304 #ifdef HAS_SOCKET 305 306 int 307 Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol) 308 { 309 # if defined(SOCK_CLOEXEC) 310 dVAR; 311 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 312 PL_strategy_socket, 313 PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), 314 PerlSock_socket(domain, type, protocol)); 315 # else 316 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_socket(domain, type, protocol)); 317 # endif 318 } 319 320 int 321 Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, 322 Sock_size_t *addrlen) 323 { 324 # if !defined(PERL_IMPLICIT_SYS) && \ 325 defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC) 326 /* 327 * struct IPerlSock doesn't cover accept4(), and there's no clear 328 * way to extend it, so for the time being this just isn't available 329 * on PERL_IMPLICIT_SYS builds. 330 */ 331 dVAR; 332 DO_ONEOPEN_EXPERIMENTING_CLOEXEC( 333 PL_strategy_accept, 334 accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), 335 PerlSock_accept(listenfd, addr, addrlen)); 336 # else 337 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_accept(listenfd, addr, addrlen)); 338 # endif 339 } 340 341 #endif 342 343 #if defined (HAS_SOCKETPAIR) || \ 344 (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && \ 345 defined(AF_INET) && defined(PF_INET)) 346 int 347 Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, 348 int *pairfd) 349 { 350 dVAR; 351 PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC; 352 # ifdef SOCK_CLOEXEC 353 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd, 354 PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), 355 PerlSock_socketpair(domain, type, protocol, pairfd)); 356 # else 357 DO_PIPEOPEN_THEN_CLOEXEC(pairfd, 358 PerlSock_socketpair(domain, type, protocol, pairfd)); 359 # endif 360 } 361 #endif 362 363 static IO * 364 S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, 365 int *savefd, char *savetype) 366 { 367 IO * const io = GvIOn(gv); 368 369 PERL_ARGS_ASSERT_OPENN_SETUP; 370 371 *saveifp = NULL; 372 *saveofp = NULL; 373 *savefd = -1; 374 *savetype = IoTYPE_CLOSED; 375 376 Zero(mode,sizeof(mode),char); 377 PL_forkprocess = 1; /* assume true if no fork */ 378 379 /* If currently open - close before we re-open */ 380 if (IoIFP(io)) { 381 if (IoTYPE(io) == IoTYPE_STD) { 382 /* This is a clone of one of STD* handles */ 383 } 384 else { 385 const int old_fd = PerlIO_fileno(IoIFP(io)); 386 387 if (inRANGE(old_fd, 0, PL_maxsysfd)) { 388 /* This is one of the original STD* handles */ 389 *saveifp = IoIFP(io); 390 *saveofp = IoOFP(io); 391 *savetype = IoTYPE(io); 392 *savefd = old_fd; 393 } 394 else { 395 int result; 396 397 if (IoTYPE(io) == IoTYPE_PIPE) 398 result = PerlProc_pclose(IoIFP(io)); 399 else if (IoIFP(io) != IoOFP(io)) { 400 if (IoOFP(io)) { 401 result = PerlIO_close(IoOFP(io)); 402 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 403 } 404 else 405 result = PerlIO_close(IoIFP(io)); 406 } 407 else 408 result = PerlIO_close(IoIFP(io)); 409 410 if (result == EOF && old_fd > PL_maxsysfd) { 411 /* Why is this not Perl_warn*() call ? */ 412 PerlIO_printf(Perl_error_log, 413 "Warning: unable to close filehandle %" HEKf 414 " properly.\n", 415 HEKfARG(GvENAME_HEK(gv)) 416 ); 417 } 418 } 419 } 420 IoOFP(io) = IoIFP(io) = NULL; 421 } 422 return io; 423 } 424 425 bool 426 Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, 427 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, 428 I32 num_svs) 429 { 430 PERL_ARGS_ASSERT_DO_OPENN; 431 432 if (as_raw) { 433 /* sysopen style args, i.e. integer mode and permissions */ 434 435 if (num_svs != 0) { 436 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", 437 (long) num_svs); 438 } 439 return do_open_raw(gv, oname, len, rawmode, rawperm, NULL); 440 } 441 return do_open6(gv, oname, len, supplied_fp, svp, num_svs); 442 } 443 444 bool 445 Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, 446 int rawmode, int rawperm, Stat_t *statbufp) 447 { 448 PerlIO *saveifp; 449 PerlIO *saveofp; 450 int savefd; 451 char savetype; 452 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ 453 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); 454 int writing = 0; 455 PerlIO *fp; 456 457 PERL_ARGS_ASSERT_DO_OPEN_RAW; 458 459 /* For ease of blame back to 5.000, keep the existing indenting. */ 460 { 461 /* sysopen style args, i.e. integer mode and permissions */ 462 STRLEN ix = 0; 463 const int appendtrunc = 464 0 465 #ifdef O_APPEND /* Not fully portable. */ 466 |O_APPEND 467 #endif 468 #ifdef O_TRUNC /* Not fully portable. */ 469 |O_TRUNC 470 #endif 471 ; 472 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; 473 int ismodifying; 474 SV *namesv; 475 476 /* It's not always 477 478 O_RDONLY 0 479 O_WRONLY 1 480 O_RDWR 2 481 482 It might be (in OS/390 and Mac OS Classic it is) 483 484 O_WRONLY 1 485 O_RDONLY 2 486 O_RDWR 3 487 488 This means that simple & with O_RDWR would look 489 like O_RDONLY is present. Therefore we have to 490 be more careful. 491 */ 492 if ((ismodifying = (rawmode & modifyingmode))) { 493 if ((ismodifying & O_WRONLY) == O_WRONLY || 494 (ismodifying & O_RDWR) == O_RDWR || 495 (ismodifying & (O_CREAT|appendtrunc))) 496 TAINT_PROPER("sysopen"); 497 } 498 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ 499 500 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) 501 rawmode |= O_LARGEFILE; /* Transparently largefiley. */ 502 #endif 503 504 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); 505 506 namesv = newSVpvn_flags(oname, len, SVs_TEMP); 507 fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); 508 } 509 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, 510 savetype, writing, 0, NULL, statbufp); 511 } 512 513 bool 514 Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, 515 PerlIO *supplied_fp, SV **svp, U32 num_svs) 516 { 517 PerlIO *saveifp; 518 PerlIO *saveofp; 519 int savefd; 520 char savetype; 521 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ 522 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype); 523 int writing = 0; 524 PerlIO *fp; 525 bool was_fdopen = FALSE; 526 char *type = NULL; 527 528 PERL_ARGS_ASSERT_DO_OPEN6; 529 530 /* For ease of blame back to 5.000, keep the existing indenting. */ 531 { 532 /* Regular (non-sys) open */ 533 char *name; 534 STRLEN olen = len; 535 char *tend; 536 int dodup = 0; 537 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; 538 539 /* Collect default raw/crlf info from the op */ 540 if (PL_op && PL_op->op_type == OP_OPEN) { 541 /* set up IO layers */ 542 const U8 flags = PL_op->op_private; 543 in_raw = (flags & OPpOPEN_IN_RAW); 544 in_crlf = (flags & OPpOPEN_IN_CRLF); 545 out_raw = (flags & OPpOPEN_OUT_RAW); 546 out_crlf = (flags & OPpOPEN_OUT_CRLF); 547 } 548 549 type = savepvn(oname, len); 550 tend = type+len; 551 SAVEFREEPV(type); 552 553 /* Lose leading and trailing white space */ 554 while (isSPACE(*type)) 555 type++; 556 while (tend > type && isSPACE(tend[-1])) 557 *--tend = '\0'; 558 559 if (num_svs) { 560 const char *p; 561 STRLEN nlen = 0; 562 /* New style explicit name, type is just mode and layer info */ 563 #ifdef USE_STDIO 564 if (SvROK(*svp) && !memchr(oname, '&', len)) { 565 if (ckWARN(WARN_IO)) 566 Perl_warner(aTHX_ packWARN(WARN_IO), 567 "Can't open a reference"); 568 SETERRNO(EINVAL, LIB_INVARG); 569 fp = NULL; 570 goto say_false; 571 } 572 #endif /* USE_STDIO */ 573 p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; 574 575 if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) { 576 fp = NULL; 577 goto say_false; 578 } 579 580 name = p ? savepvn(p, nlen) : savepvs(""); 581 582 SAVEFREEPV(name); 583 } 584 else { 585 name = type; 586 len = tend-type; 587 } 588 IoTYPE(io) = *type; 589 if ((*type == IoTYPE_RDWR) && /* scary */ 590 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && 591 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { 592 TAINT_PROPER("open"); 593 mode[1] = *type++; 594 writing = 1; 595 } 596 597 if (*type == IoTYPE_PIPE) { 598 if (num_svs) { 599 if (type[1] != IoTYPE_STD) { 600 unknown_open_mode: 601 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); 602 } 603 type++; 604 } 605 do { 606 type++; 607 } while (isSPACE(*type)); 608 if (!num_svs) { 609 name = type; 610 len = tend-type; 611 } 612 if (*name == '\0') { 613 /* command is missing 19990114 */ 614 if (ckWARN(WARN_PIPE)) 615 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 616 errno = EPIPE; 617 fp = NULL; 618 goto say_false; 619 } 620 if (!(*name == '-' && name[1] == '\0') || num_svs) 621 TAINT_ENV(); 622 TAINT_PROPER("piped open"); 623 if (!num_svs && name[len-1] == '|') { 624 name[--len] = '\0' ; 625 if (ckWARN(WARN_PIPE)) 626 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); 627 } 628 mode[0] = 'w'; 629 writing = 1; 630 if (out_raw) 631 mode[1] = 'b'; 632 else if (out_crlf) 633 mode[1] = 't'; 634 if (num_svs > 1) { 635 fp = PerlProc_popen_list(mode, num_svs, svp); 636 } 637 else { 638 fp = PerlProc_popen(name,mode); 639 } 640 if (num_svs) { 641 if (*type) { 642 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 643 fp = NULL; 644 goto say_false; 645 } 646 } 647 } 648 } /* IoTYPE_PIPE */ 649 else if (*type == IoTYPE_WRONLY) { 650 TAINT_PROPER("open"); 651 type++; 652 if (*type == IoTYPE_WRONLY) { 653 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ 654 mode[0] = IoTYPE(io) = IoTYPE_APPEND; 655 type++; 656 } 657 else { 658 mode[0] = 'w'; 659 } 660 writing = 1; 661 662 if (out_raw) 663 mode[1] = 'b'; 664 else if (out_crlf) 665 mode[1] = 't'; 666 if (*type == '&') { 667 duplicity: 668 dodup = PERLIO_DUP_FD; 669 type++; 670 if (*type == '=') { 671 dodup = 0; 672 type++; 673 } 674 if (!num_svs && !*type && supplied_fp) { 675 /* "<+&" etc. is used by typemaps */ 676 fp = supplied_fp; 677 } 678 else { 679 PerlIO *that_fp = NULL; 680 int wanted_fd; 681 UV uv; 682 if (num_svs > 1) { 683 /* diag_listed_as: More than one argument to '%s' open */ 684 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); 685 } 686 while (isSPACE(*type)) 687 type++; 688 if (num_svs && ( 689 SvIOK(*svp) 690 || (SvPOKp(*svp) && looks_like_number(*svp)) 691 )) { 692 wanted_fd = SvUV(*svp); 693 num_svs = 0; 694 } 695 else if (isDIGIT(*type) 696 && grok_atoUV(type, &uv, NULL) 697 && uv <= INT_MAX 698 ) { 699 wanted_fd = (int)uv; 700 } 701 else { 702 const IO* thatio; 703 if (num_svs) { 704 thatio = sv_2io(*svp); 705 } 706 else { 707 GV * const thatgv = gv_fetchpvn_flags(type, tend - type, 708 0, SVt_PVIO); 709 thatio = GvIO(thatgv); 710 } 711 if (!thatio) { 712 #ifdef EINVAL 713 SETERRNO(EINVAL,SS_IVCHAN); 714 #endif 715 fp = NULL; 716 goto say_false; 717 } 718 if ((that_fp = IoIFP(thatio))) { 719 /* Flush stdio buffer before dup. --mjd 720 * Unfortunately SEEK_CURing 0 seems to 721 * be optimized away on most platforms; 722 * only Solaris and Linux seem to flush 723 * on that. --jhi */ 724 /* On the other hand, do all platforms 725 * take gracefully to flushing a read-only 726 * filehandle? Perhaps we should do 727 * fsetpos(src)+fgetpos(dst)? --nik */ 728 PerlIO_flush(that_fp); 729 wanted_fd = PerlIO_fileno(that_fp); 730 /* When dup()ing STDIN, STDOUT or STDERR 731 * explicitly set appropriate access mode */ 732 if (that_fp == PerlIO_stdout() 733 || that_fp == PerlIO_stderr()) 734 IoTYPE(io) = IoTYPE_WRONLY; 735 else if (that_fp == PerlIO_stdin()) 736 IoTYPE(io) = IoTYPE_RDONLY; 737 /* When dup()ing a socket, say result is 738 * one as well */ 739 else if (IoTYPE(thatio) == IoTYPE_SOCKET) 740 IoTYPE(io) = IoTYPE_SOCKET; 741 } 742 else { 743 SETERRNO(EBADF, RMS_IFI); 744 fp = NULL; 745 goto say_false; 746 } 747 } 748 if (!num_svs) 749 type = NULL; 750 if (that_fp) { 751 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); 752 } 753 else { 754 if (dodup) 755 wanted_fd = PerlLIO_dup_cloexec(wanted_fd); 756 else 757 was_fdopen = TRUE; 758 if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) { 759 if (dodup && wanted_fd >= 0) 760 PerlLIO_close(wanted_fd); 761 } 762 } 763 } 764 } /* & */ 765 else { 766 while (isSPACE(*type)) 767 type++; 768 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 769 type++; 770 fp = PerlIO_stdout(); 771 IoTYPE(io) = IoTYPE_STD; 772 if (num_svs > 1) { 773 /* diag_listed_as: More than one argument to '%s' open */ 774 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); 775 } 776 } 777 else { 778 if (num_svs) { 779 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 780 } 781 else { 782 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 783 type = NULL; 784 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 785 } 786 } 787 } /* !& */ 788 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 789 goto unknown_open_mode; 790 } /* IoTYPE_WRONLY */ 791 else if (*type == IoTYPE_RDONLY) { 792 do { 793 type++; 794 } while (isSPACE(*type)); 795 mode[0] = 'r'; 796 if (in_raw) 797 mode[1] = 'b'; 798 else if (in_crlf) 799 mode[1] = 't'; 800 if (*type == '&') { 801 goto duplicity; 802 } 803 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 804 type++; 805 fp = PerlIO_stdin(); 806 IoTYPE(io) = IoTYPE_STD; 807 if (num_svs > 1) { 808 /* diag_listed_as: More than one argument to '%s' open */ 809 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); 810 } 811 } 812 else { 813 if (num_svs) { 814 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 815 } 816 else { 817 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 818 type = NULL; 819 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 820 } 821 } 822 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 823 goto unknown_open_mode; 824 } /* IoTYPE_RDONLY */ 825 else if ((num_svs && /* '-|...' or '...|' */ 826 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || 827 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { 828 if (num_svs) { 829 type += 2; /* skip over '-|' */ 830 } 831 else { 832 *--tend = '\0'; 833 while (tend > type && isSPACE(tend[-1])) 834 *--tend = '\0'; 835 for (; isSPACE(*type); type++) 836 ; 837 name = type; 838 len = tend-type; 839 } 840 if (*name == '\0') { 841 /* command is missing 19990114 */ 842 if (ckWARN(WARN_PIPE)) 843 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 844 errno = EPIPE; 845 fp = NULL; 846 goto say_false; 847 } 848 if (!(*name == '-' && name[1] == '\0') || num_svs) 849 TAINT_ENV(); 850 TAINT_PROPER("piped open"); 851 mode[0] = 'r'; 852 853 if (in_raw) 854 mode[1] = 'b'; 855 else if (in_crlf) 856 mode[1] = 't'; 857 858 if (num_svs > 1) { 859 fp = PerlProc_popen_list(mode,num_svs,svp); 860 } 861 else { 862 fp = PerlProc_popen(name,mode); 863 } 864 IoTYPE(io) = IoTYPE_PIPE; 865 if (num_svs) { 866 while (isSPACE(*type)) 867 type++; 868 if (*type) { 869 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 870 fp = NULL; 871 goto say_false; 872 } 873 } 874 } 875 } 876 else { /* layer(Args) */ 877 if (num_svs) 878 goto unknown_open_mode; 879 name = type; 880 IoTYPE(io) = IoTYPE_RDONLY; 881 for (; isSPACE(*name); name++) 882 ; 883 mode[0] = 'r'; 884 885 if (in_raw) 886 mode[1] = 'b'; 887 else if (in_crlf) 888 mode[1] = 't'; 889 890 if (*name == '-' && name[1] == '\0') { 891 fp = PerlIO_stdin(); 892 IoTYPE(io) = IoTYPE_STD; 893 } 894 else { 895 if (num_svs) { 896 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 897 } 898 else { 899 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 900 type = NULL; 901 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); 902 } 903 } 904 } 905 } 906 907 say_false: 908 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, 909 savetype, writing, was_fdopen, type, NULL); 910 } 911 912 /* Yes, this is ugly, but it's private, and I don't see a cleaner way to 913 simplify the two-headed public interface of do_openn. */ 914 static bool 915 S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, 916 PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype, 917 int writing, bool was_fdopen, const char *type, Stat_t *statbufp) 918 { 919 int fd; 920 Stat_t statbuf; 921 922 PERL_ARGS_ASSERT_OPENN_CLEANUP; 923 924 Zero(&statbuf, 1, Stat_t); 925 926 if (!fp) { 927 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) 928 && should_warn_nl(oname) 929 930 ) 931 { 932 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ 933 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); 934 GCC_DIAG_RESTORE_STMT; 935 } 936 goto say_false; 937 } 938 939 if (ckWARN(WARN_IO)) { 940 if ((IoTYPE(io) == IoTYPE_RDONLY) && 941 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { 942 Perl_warner(aTHX_ packWARN(WARN_IO), 943 "Filehandle STD%s reopened as %" HEKf 944 " only for input", 945 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), 946 HEKfARG(GvENAME_HEK(gv))); 947 } 948 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { 949 Perl_warner(aTHX_ packWARN(WARN_IO), 950 "Filehandle STDIN reopened as %" HEKf " only for output", 951 HEKfARG(GvENAME_HEK(gv)) 952 ); 953 } 954 } 955 956 fd = PerlIO_fileno(fp); 957 /* Do NOT do: "if (fd < 0) goto say_false;" here. If there is no 958 * fd assume it isn't a socket - this covers PerlIO::scalar - 959 * otherwise unless we "know" the type probe for socket-ness. 960 */ 961 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { 962 if (PerlLIO_fstat(fd,&statbuf) < 0) { 963 /* If PerlIO claims to have fd we had better be able to fstat() it. */ 964 (void) PerlIO_close(fp); 965 goto say_false; 966 } 967 #ifndef PERL_MICRO 968 if (S_ISSOCK(statbuf.st_mode)) 969 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ 970 #ifdef HAS_SOCKET 971 else if ( 972 !(statbuf.st_mode & S_IFMT) 973 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ 974 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ 975 ) { /* on OS's that return 0 on fstat()ed pipe */ 976 char tmpbuf[256]; 977 Sock_size_t buflen = sizeof tmpbuf; 978 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 979 || errno != ENOTSOCK) 980 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ 981 /* but some return 0 for streams too, sigh */ 982 } 983 #endif /* HAS_SOCKET */ 984 #endif /* !PERL_MICRO */ 985 } 986 987 /* Eeek - FIXME !!! 988 * If this is a standard handle we discard all the layer stuff 989 * and just dup the fd into whatever was on the handle before ! 990 */ 991 992 if (saveifp) { /* must use old fp? */ 993 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR 994 then dup the new fileno down 995 */ 996 if (saveofp) { 997 PerlIO_flush(saveofp); /* emulate PerlIO_close() */ 998 if (saveofp != saveifp) { /* was a socket? */ 999 PerlIO_close(saveofp); 1000 } 1001 } 1002 if (savefd != fd) { 1003 /* Still a small can-of-worms here if (say) PerlIO::scalar 1004 is assigned to (say) STDOUT - for now let dup2() fail 1005 and provide the error 1006 */ 1007 if (fd < 0) { 1008 SETERRNO(EBADF,RMS_IFI); 1009 goto say_false; 1010 } else if (PerlLIO_dup2(fd, savefd) < 0) { 1011 (void)PerlIO_close(fp); 1012 goto say_false; 1013 } 1014 #ifdef VMS 1015 if (savefd != PerlIO_fileno(PerlIO_stdin())) { 1016 char newname[FILENAME_MAX+1]; 1017 if (PerlIO_getname(fp, newname)) { 1018 if (fd == PerlIO_fileno(PerlIO_stdout())) 1019 vmssetuserlnm("SYS$OUTPUT", newname); 1020 if (fd == PerlIO_fileno(PerlIO_stderr())) 1021 vmssetuserlnm("SYS$ERROR", newname); 1022 } 1023 } 1024 #endif 1025 1026 #if !defined(WIN32) 1027 /* PL_fdpid isn't used on Windows, so avoid this useless work. 1028 * XXX Probably the same for a lot of other places. */ 1029 { 1030 Pid_t pid; 1031 SV *sv; 1032 1033 sv = *av_fetch(PL_fdpid,fd,TRUE); 1034 SvUPGRADE(sv, SVt_IV); 1035 pid = SvIVX(sv); 1036 SvIV_set(sv, 0); 1037 sv = *av_fetch(PL_fdpid,savefd,TRUE); 1038 SvUPGRADE(sv, SVt_IV); 1039 SvIV_set(sv, pid); 1040 } 1041 #endif 1042 1043 if (was_fdopen) { 1044 /* need to close fp without closing underlying fd */ 1045 int ofd = PerlIO_fileno(fp); 1046 int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1; 1047 if (ofd < 0 || dupfd < 0) { 1048 if (dupfd >= 0) 1049 PerlLIO_close(dupfd); 1050 goto say_false; 1051 } 1052 PerlIO_close(fp); 1053 PerlLIO_dup2_cloexec(dupfd, ofd); 1054 setfd_inhexec_for_sysfd(ofd); 1055 PerlLIO_close(dupfd); 1056 } 1057 else 1058 PerlIO_close(fp); 1059 } 1060 fp = saveifp; 1061 PerlIO_clearerr(fp); 1062 fd = PerlIO_fileno(fp); 1063 } 1064 IoIFP(io) = fp; 1065 1066 IoFLAGS(io) &= ~IOf_NOLINE; 1067 if (writing) { 1068 if (IoTYPE(io) == IoTYPE_SOCKET 1069 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) { 1070 char *s = mode; 1071 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) 1072 s++; 1073 *s = 'w'; 1074 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { 1075 PerlIO_close(fp); 1076 goto say_false; 1077 } 1078 } 1079 else 1080 IoOFP(io) = fp; 1081 } 1082 if (statbufp) 1083 *statbufp = statbuf; 1084 1085 return TRUE; 1086 1087 say_false: 1088 IoIFP(io) = saveifp; 1089 IoOFP(io) = saveofp; 1090 IoTYPE(io) = savetype; 1091 return FALSE; 1092 } 1093 1094 /* Open a temp file in the same directory as an original name. 1095 */ 1096 1097 static bool 1098 S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) { 1099 int fd; 1100 PerlIO *fp; 1101 const char *p = SvPV_nolen(orig_name); 1102 const char *sep; 1103 1104 /* look for the last directory separator */ 1105 sep = strrchr(p, '/'); 1106 1107 #ifdef DOSISH 1108 { 1109 const char *sep2; 1110 if ((sep2 = strrchr(sep ? sep : p, '\\'))) 1111 sep = sep2; 1112 } 1113 #endif 1114 #ifdef VMS 1115 if (!sep) { 1116 const char *openp = strchr(p, '['); 1117 if (openp) 1118 sep = strchr(openp, ']'); 1119 else { 1120 sep = strchr(p, ':'); 1121 } 1122 } 1123 #endif 1124 if (sep) { 1125 sv_setpvn(temp_out_name, p, sep - p + 1); 1126 sv_catpvs(temp_out_name, "XXXXXXXX"); 1127 } 1128 else 1129 sv_setpvs(temp_out_name, "XXXXXXXX"); 1130 1131 { 1132 int old_umask = umask(0177); 1133 fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name)); 1134 umask(old_umask); 1135 } 1136 1137 if (fd < 0) 1138 return FALSE; 1139 1140 fp = PerlIO_fdopen(fd, "w+"); 1141 if (!fp) 1142 return FALSE; 1143 1144 return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0); 1145 } 1146 1147 #if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \ 1148 (defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \ 1149 defined(HAS_LINKAT) 1150 # define ARGV_USE_ATFUNCTIONS 1151 #endif 1152 1153 /* Win32 doesn't necessarily return useful information 1154 * in st_dev, st_ino. 1155 */ 1156 #ifndef DOSISH 1157 # define ARGV_USE_STAT_INO 1158 #endif 1159 1160 #define ARGVMG_BACKUP_NAME 0 1161 #define ARGVMG_TEMP_NAME 1 1162 #define ARGVMG_ORIG_NAME 2 1163 #define ARGVMG_ORIG_MODE 3 1164 #define ARGVMG_ORIG_PID 4 1165 1166 /* we store the entire stat_t since the ino_t and dev_t values might 1167 not fit in an IV. I could have created a new structure and 1168 transferred them across, but this seemed too much effort for very 1169 little win. 1170 1171 We store it even when the *at() functions are available, since 1172 while the C runtime might have definitions for these functions, the 1173 operating system or a specific filesystem might not implement them. 1174 eg. NetBSD 6 implements linkat() but only where the fds are AT_FDCWD. 1175 */ 1176 #ifdef ARGV_USE_STAT_INO 1177 # define ARGVMG_ORIG_CWD_STAT 5 1178 #endif 1179 1180 #ifdef ARGV_USE_ATFUNCTIONS 1181 # define ARGVMG_ORIG_DIRP 6 1182 #endif 1183 1184 #ifdef ENOTSUP 1185 #define NotSupported(e) ((e) == ENOSYS || (e) == ENOTSUP) 1186 #else 1187 #define NotSupported(e) ((e) == ENOSYS) 1188 #endif 1189 1190 static int 1191 S_argvout_free(pTHX_ SV *io, MAGIC *mg) { 1192 PERL_UNUSED_ARG(io); 1193 1194 /* note this can be entered once the file has been 1195 successfully deleted too */ 1196 assert(IoTYPE(io) != IoTYPE_PIPE); 1197 1198 /* mg_obj can be NULL if a thread is created with the handle open, in which 1199 case we leave any clean up to the parent thread */ 1200 if (mg->mg_obj) { 1201 #ifdef ARGV_USE_ATFUNCTIONS 1202 SV **dir_psv; 1203 DIR *dir; 1204 1205 dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE); 1206 assert(dir_psv && *dir_psv && SvIOK(*dir_psv)); 1207 dir = INT2PTR(DIR *, SvIV(*dir_psv)); 1208 #endif 1209 if (IoIFP(io)) { 1210 if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) { 1211 (void)argvout_final(mg, (IO*)io, FALSE); 1212 } 1213 else { 1214 SV **pid_psv; 1215 PerlIO *iop = IoIFP(io); 1216 1217 assert(SvTYPE(mg->mg_obj) == SVt_PVAV); 1218 1219 pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE); 1220 1221 assert(pid_psv && *pid_psv); 1222 1223 if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) { 1224 /* if we get here the file hasn't been closed explicitly by the 1225 user and hadn't been closed implicitly by nextargv(), so 1226 abandon the edit */ 1227 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE); 1228 const char *temp_pv = SvPVX(*temp_psv); 1229 1230 assert(temp_psv && *temp_psv && SvPOK(*temp_psv)); 1231 (void)PerlIO_close(iop); 1232 IoIFP(io) = IoOFP(io) = NULL; 1233 #ifdef ARGV_USE_ATFUNCTIONS 1234 if (dir) { 1235 if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 && 1236 NotSupported(errno)) 1237 (void)UNLINK(temp_pv); 1238 } 1239 #else 1240 (void)UNLINK(temp_pv); 1241 #endif 1242 } 1243 } 1244 } 1245 #ifdef ARGV_USE_ATFUNCTIONS 1246 if (dir) 1247 closedir(dir); 1248 #endif 1249 } 1250 1251 return 0; 1252 } 1253 1254 static int 1255 S_argvout_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { 1256 PERL_UNUSED_ARG(param); 1257 1258 /* ideally we could just remove the magic from the SV but we don't get the SV here */ 1259 SvREFCNT_dec(mg->mg_obj); 1260 mg->mg_obj = NULL; 1261 1262 return 0; 1263 } 1264 1265 /* Magic of this type has an AV containing the following: 1266 0: name of the backup file (if any) 1267 1: name of the temp output file 1268 2: name of the original file 1269 3: file mode of the original file 1270 4: pid of the process we opened at, to prevent doing the renaming 1271 etc in both the child and the parent after a fork 1272 1273 If we have useful inode/device ids in stat_t we also keep: 1274 5: a stat of the original current working directory 1275 1276 If we have unlinkat(), renameat(), fchmodat(), dirfd() we also keep: 1277 6: the DIR * for the current directory when we open the file, stored as an IV 1278 */ 1279 1280 static const MGVTBL argvout_vtbl = 1281 { 1282 NULL, /* svt_get */ 1283 NULL, /* svt_set */ 1284 NULL, /* svt_len */ 1285 NULL, /* svt_clear */ 1286 S_argvout_free, /* svt_free */ 1287 NULL, /* svt_copy */ 1288 S_argvout_dup, /* svt_dup */ 1289 NULL /* svt_local */ 1290 }; 1291 1292 PerlIO * 1293 Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) 1294 { 1295 IO * const io = GvIOp(gv); 1296 SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL; 1297 1298 PERL_ARGS_ASSERT_NEXTARGV; 1299 1300 if (old_out_name) 1301 SAVEFREESV(old_out_name); 1302 1303 if (!PL_argvoutgv) 1304 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 1305 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) { 1306 IoFLAGS(io) &= ~IOf_START; 1307 if (PL_inplace) { 1308 assert(PL_defoutgv); 1309 Perl_av_create_and_push(aTHX_ &PL_argvout_stack, 1310 SvREFCNT_inc_simple_NN(PL_defoutgv)); 1311 } 1312 } 1313 1314 { 1315 IO * const io = GvIOp(PL_argvoutgv); 1316 if (io && IoIFP(io) && old_out_name) { 1317 do_close(PL_argvoutgv, FALSE); 1318 } 1319 } 1320 1321 PL_lastfd = -1; 1322 PL_filemode = 0; 1323 if (!GvAV(gv)) 1324 return NULL; 1325 while (av_tindex(GvAV(gv)) >= 0) { 1326 STRLEN oldlen; 1327 SV *const sv = av_shift(GvAV(gv)); 1328 SAVEFREESV(sv); 1329 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ 1330 sv_setsv(GvSVn(gv),sv); 1331 SvSETMAGIC(GvSV(gv)); 1332 PL_oldname = SvPVx(GvSV(gv), oldlen); 1333 if (LIKELY(!PL_inplace)) { 1334 if (nomagicopen 1335 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1) 1336 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0) 1337 ) { 1338 return IoIFP(GvIOp(gv)); 1339 } 1340 } 1341 else { 1342 Stat_t statbuf; 1343 /* This very long block ends with return IoIFP(GvIOp(gv)); 1344 Both this block and the block above fall through on open 1345 failure to the warning code, and then the while loop above tries 1346 the next entry. */ 1347 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) { 1348 #ifndef FLEXFILENAMES 1349 int filedev; 1350 int fileino; 1351 #endif 1352 #ifdef ARGV_USE_ATFUNCTIONS 1353 DIR *curdir; 1354 #endif 1355 Uid_t fileuid; 1356 Gid_t filegid; 1357 AV *magic_av = NULL; 1358 SV *temp_name_sv = NULL; 1359 MAGIC *mg; 1360 1361 TAINT_PROPER("inplace open"); 1362 if (oldlen == 1 && *PL_oldname == '-') { 1363 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, 1364 SVt_PVIO)); 1365 return IoIFP(GvIOp(gv)); 1366 } 1367 #ifndef FLEXFILENAMES 1368 filedev = statbuf.st_dev; 1369 fileino = statbuf.st_ino; 1370 #endif 1371 PL_filemode = statbuf.st_mode; 1372 fileuid = statbuf.st_uid; 1373 filegid = statbuf.st_gid; 1374 if (!S_ISREG(PL_filemode)) { 1375 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 1376 "Can't do inplace edit: %s is not a regular file", 1377 PL_oldname ); 1378 do_close(gv,FALSE); 1379 continue; 1380 } 1381 magic_av = newAV(); 1382 if (*PL_inplace && strNE(PL_inplace, "*")) { 1383 const char *star = strchr(PL_inplace, '*'); 1384 if (star) { 1385 const char *begin = PL_inplace; 1386 SvPVCLEAR(sv); 1387 do { 1388 sv_catpvn(sv, begin, star - begin); 1389 sv_catpvn(sv, PL_oldname, oldlen); 1390 begin = ++star; 1391 } while ((star = strchr(begin, '*'))); 1392 if (*begin) 1393 sv_catpv(sv,begin); 1394 } 1395 else { 1396 sv_catpv(sv,PL_inplace); 1397 } 1398 #ifndef FLEXFILENAMES 1399 if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0 1400 && statbuf.st_dev == filedev 1401 && statbuf.st_ino == fileino) 1402 #ifdef DJGPP 1403 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) 1404 #endif 1405 ) 1406 { 1407 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 1408 "Can't do inplace edit: %" 1409 SVf " would not be unique", 1410 SVfARG(sv)); 1411 goto cleanup_argv; 1412 } 1413 #endif 1414 av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv)); 1415 } 1416 1417 sv_setpvn(sv,PL_oldname,oldlen); 1418 SETERRNO(0,0); /* in case sprintf set errno */ 1419 temp_name_sv = newSV(0); 1420 if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) { 1421 SvREFCNT_dec(temp_name_sv); 1422 /* diag_listed_as: Can't do inplace edit on %s: %s */ 1423 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s", 1424 PL_oldname, Strerror(errno) ); 1425 #ifndef FLEXFILENAMES 1426 cleanup_argv: 1427 #endif 1428 do_close(gv,FALSE); 1429 SvREFCNT_dec(magic_av); 1430 continue; 1431 } 1432 av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv); 1433 av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv)); 1434 av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode)); 1435 av_store(magic_av, ARGVMG_ORIG_PID, newSViv((IV)PerlProc_getpid())); 1436 #if defined(ARGV_USE_ATFUNCTIONS) 1437 curdir = opendir("."); 1438 av_store(magic_av, ARGVMG_ORIG_DIRP, newSViv(PTR2IV(curdir))); 1439 #elif defined(ARGV_USE_STAT_INO) 1440 if (PerlLIO_stat(".", &statbuf) >= 0) { 1441 av_store(magic_av, ARGVMG_ORIG_CWD_STAT, 1442 newSVpvn((char *)&statbuf, sizeof(statbuf))); 1443 } 1444 #endif 1445 setdefout(PL_argvoutgv); 1446 sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv); 1447 mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0); 1448 mg->mg_flags |= MGf_DUP; 1449 SvREFCNT_dec(magic_av); 1450 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); 1451 if (PL_lastfd >= 0) { 1452 (void)PerlLIO_fstat(PL_lastfd,&statbuf); 1453 #ifdef HAS_FCHMOD 1454 (void)fchmod(PL_lastfd,PL_filemode); 1455 #else 1456 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 1457 #endif 1458 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { 1459 /* XXX silently ignore failures */ 1460 #ifdef HAS_FCHOWN 1461 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid)); 1462 #elif defined(HAS_CHOWN) 1463 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid)); 1464 #endif 1465 } 1466 } 1467 return IoIFP(GvIOp(gv)); 1468 } 1469 } /* successful do_open_raw(), PL_inplace non-NULL */ 1470 1471 if (ckWARN_d(WARN_INPLACE)) { 1472 const int eno = errno; 1473 Stat_t statbuf; 1474 if (PerlLIO_stat(PL_oldname, &statbuf) >= 0 1475 && !S_ISREG(statbuf.st_mode)) { 1476 Perl_warner(aTHX_ packWARN(WARN_INPLACE), 1477 "Can't do inplace edit: %s is not a regular file", 1478 PL_oldname); 1479 } 1480 else { 1481 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", 1482 PL_oldname, Strerror(eno)); 1483 } 1484 } 1485 } 1486 if (io && (IoFLAGS(io) & IOf_ARGV)) 1487 IoFLAGS(io) |= IOf_START; 1488 if (PL_inplace) { 1489 if (io && (IoFLAGS(io) & IOf_ARGV) 1490 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) 1491 { 1492 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); 1493 setdefout(oldout); 1494 SvREFCNT_dec_NN(oldout); 1495 return NULL; 1496 } 1497 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); 1498 } 1499 return NULL; 1500 } 1501 1502 #ifdef ARGV_USE_ATFUNCTIONS 1503 # if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) 1504 1505 /* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the 1506 * equivalent rename() succeeds 1507 */ 1508 static int 1509 S_my_renameat(int olddfd, const char *oldpath, int newdfd, const char *newpath) { 1510 /* this is intended only for use in Perl_do_close() */ 1511 assert(olddfd == newdfd); 1512 assert(PERL_FILE_IS_ABSOLUTE(oldpath) == PERL_FILE_IS_ABSOLUTE(newpath)); 1513 if (PERL_FILE_IS_ABSOLUTE(oldpath)) { 1514 return PerlLIO_rename(oldpath, newpath); 1515 } 1516 else { 1517 return renameat(olddfd, oldpath, newdfd, newpath); 1518 } 1519 } 1520 1521 # else 1522 # define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2)) 1523 # endif /* if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) */ 1524 #endif 1525 1526 static bool 1527 S_dir_unchanged(pTHX_ const char *orig_pv, MAGIC *mg) { 1528 Stat_t statbuf; 1529 1530 #ifdef ARGV_USE_STAT_INO 1531 SV **stat_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_CWD_STAT, FALSE); 1532 Stat_t *orig_cwd_stat = stat_psv && *stat_psv ? (Stat_t *)SvPVX(*stat_psv) : NULL; 1533 1534 /* if the path is absolute the possible moving of cwd (which the file 1535 might be in) isn't our problem. 1536 This code tries to be reasonably balanced about detecting a changed 1537 CWD, if we have the information needed to check that curdir has changed, we 1538 check it 1539 */ 1540 if (!PERL_FILE_IS_ABSOLUTE(orig_pv) 1541 && orig_cwd_stat 1542 && PerlLIO_stat(".", &statbuf) >= 0 1543 && ( statbuf.st_dev != orig_cwd_stat->st_dev 1544 || statbuf.st_ino != orig_cwd_stat->st_ino)) { 1545 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s", 1546 orig_pv, "Current directory has changed"); 1547 } 1548 #else 1549 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE); 1550 1551 /* Some platforms don't have useful st_ino etc, so just 1552 check we can see the work file. 1553 */ 1554 if (!PERL_FILE_IS_ABSOLUTE(orig_pv) 1555 && PerlLIO_stat(SvPVX(*temp_psv), &statbuf) < 0) { 1556 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s", 1557 orig_pv, 1558 "Work file is missing - did you change directory?"); 1559 } 1560 #endif 1561 1562 return TRUE; 1563 } 1564 1565 #define dir_unchanged(orig_psv, mg) \ 1566 S_dir_unchanged(aTHX_ (orig_psv), (mg)) 1567 1568 STATIC bool 1569 S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) { 1570 bool retval; 1571 1572 /* ensure args are checked before we start using them */ 1573 PERL_ARGS_ASSERT_ARGVOUT_FINAL; 1574 1575 { 1576 /* handle to an in-place edit work file */ 1577 SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE); 1578 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE); 1579 /* PL_oldname may have been modified by a nested ARGV use at this point */ 1580 SV **orig_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_NAME, FALSE); 1581 SV **mode_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_MODE, FALSE); 1582 SV **pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE); 1583 #if defined(ARGV_USE_ATFUNCTIONS) 1584 SV **dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE); 1585 DIR *dir; 1586 int dfd; 1587 #endif 1588 UV mode; 1589 int fd; 1590 1591 const char *orig_pv; 1592 1593 assert(temp_psv && *temp_psv); 1594 assert(orig_psv && *orig_psv); 1595 assert(mode_psv && *mode_psv); 1596 assert(pid_psv && *pid_psv); 1597 #ifdef ARGV_USE_ATFUNCTIONS 1598 assert(dir_psv && *dir_psv); 1599 dir = INT2PTR(DIR *, SvIVX(*dir_psv)); 1600 dfd = my_dirfd(dir); 1601 #endif 1602 1603 orig_pv = SvPVX(*orig_psv); 1604 mode = SvUV(*mode_psv); 1605 1606 if ((mode & (S_ISUID|S_ISGID)) != 0 1607 && (fd = PerlIO_fileno(IoIFP(io))) >= 0) { 1608 (void)PerlIO_flush(IoIFP(io)); 1609 #ifdef HAS_FCHMOD 1610 (void)fchmod(fd, mode); 1611 #else 1612 (void)PerlLIO_chmod(orig_pv, mode); 1613 #endif 1614 } 1615 1616 retval = io_close(io, NULL, not_implicit, FALSE); 1617 1618 if (SvIV(*pid_psv) != (IV)PerlProc_getpid()) { 1619 /* this is a child process, don't duplicate our rename() etc 1620 processing below */ 1621 goto freext; 1622 } 1623 1624 if (retval) { 1625 #if defined(DOSISH) || defined(__CYGWIN__) 1626 if (PL_argvgv && GvIOp(PL_argvgv) 1627 && IoIFP(GvIOp(PL_argvgv)) 1628 && (IoFLAGS(GvIOp(PL_argvgv)) & (IOf_ARGV|IOf_START)) == IOf_ARGV) { 1629 do_close(PL_argvgv, FALSE); 1630 } 1631 #endif 1632 #ifndef ARGV_USE_ATFUNCTIONS 1633 if (!dir_unchanged(orig_pv, mg)) 1634 goto abort_inplace; 1635 #endif 1636 if (back_psv && *back_psv) { 1637 #if defined(HAS_LINK) && !defined(DOSISH) && !defined(__CYGWIN__) && defined(HAS_RENAME) 1638 if ( 1639 # ifdef ARGV_USE_ATFUNCTIONS 1640 linkat(dfd, orig_pv, dfd, SvPVX(*back_psv), 0) < 0 && 1641 !(UNLIKELY(NotSupported(errno)) && 1642 dir_unchanged(orig_pv, mg) && 1643 link(orig_pv, SvPVX(*back_psv)) == 0) 1644 # else 1645 link(orig_pv, SvPVX(*back_psv)) < 0 1646 # endif 1647 ) 1648 #endif 1649 { 1650 #ifdef HAS_RENAME 1651 if ( 1652 # ifdef ARGV_USE_ATFUNCTIONS 1653 S_my_renameat(dfd, orig_pv, dfd, SvPVX(*back_psv)) < 0 && 1654 !(UNLIKELY(NotSupported(errno)) && 1655 dir_unchanged(orig_pv, mg) && 1656 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) == 0) 1657 # else 1658 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) < 0 1659 # endif 1660 ) { 1661 if (!not_implicit) { 1662 # ifdef ARGV_USE_ATFUNCTIONS 1663 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 && 1664 UNLIKELY(NotSupported(errno)) && 1665 dir_unchanged(orig_pv, mg)) 1666 (void)UNLINK(SvPVX_const(*temp_psv)); 1667 # else 1668 UNLINK(SvPVX(*temp_psv)); 1669 # endif 1670 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file", 1671 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno)); 1672 } 1673 /* should we warn here? */ 1674 goto abort_inplace; 1675 } 1676 #else 1677 (void)UNLINK(SvPVX(*back_psv)); 1678 if (link(orig_pv, SvPVX(*back_psv))) { 1679 if (!not_implicit) { 1680 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file", 1681 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno)); 1682 } 1683 goto abort_inplace; 1684 } 1685 /* we need to use link() to get the temp into place too, and linK() 1686 fails if the new link name exists */ 1687 (void)UNLINK(orig_pv); 1688 #endif 1689 } 1690 } 1691 #if defined(DOSISH) || defined(__CYGWIN__) || !defined(HAS_RENAME) 1692 else { 1693 UNLINK(orig_pv); 1694 } 1695 #endif 1696 if ( 1697 #if !defined(HAS_RENAME) 1698 link(SvPVX(*temp_psv), orig_pv) < 0 1699 #elif defined(ARGV_USE_ATFUNCTIONS) 1700 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 && 1701 !(UNLIKELY(NotSupported(errno)) && 1702 dir_unchanged(orig_pv, mg) && 1703 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0) 1704 #else 1705 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) < 0 1706 #endif 1707 ) { 1708 if (!not_implicit) { 1709 #ifdef ARGV_USE_ATFUNCTIONS 1710 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 && 1711 NotSupported(errno)) 1712 UNLINK(SvPVX(*temp_psv)); 1713 #else 1714 UNLINK(SvPVX(*temp_psv)); 1715 #endif 1716 /* diag_listed_as: Cannot complete in-place edit of %s: %s */ 1717 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: failed to rename work file '%s' to '%s': %s", 1718 orig_pv, SvPVX(*temp_psv), orig_pv, Strerror(errno)); 1719 } 1720 abort_inplace: 1721 UNLINK(SvPVX_const(*temp_psv)); 1722 retval = FALSE; 1723 } 1724 #ifndef HAS_RENAME 1725 UNLINK(SvPVX(*temp_psv)); 1726 #endif 1727 } 1728 else { 1729 #ifdef ARGV_USE_ATFUNCTIONS 1730 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) && 1731 NotSupported(errno)) 1732 UNLINK(SvPVX_const(*temp_psv)); 1733 1734 #else 1735 UNLINK(SvPVX_const(*temp_psv)); 1736 #endif 1737 if (!not_implicit) { 1738 Perl_croak(aTHX_ "Failed to close in-place work file %s: %s", 1739 SvPVX(*temp_psv), Strerror(errno)); 1740 } 1741 } 1742 freext: 1743 ; 1744 } 1745 return retval; 1746 } 1747 1748 /* explicit renamed to avoid C++ conflict -- kja */ 1749 bool 1750 Perl_do_close(pTHX_ GV *gv, bool not_implicit) 1751 { 1752 bool retval; 1753 IO *io; 1754 MAGIC *mg; 1755 1756 if (!gv) 1757 gv = PL_argvgv; 1758 if (!gv || !isGV_with_GP(gv)) { 1759 if (not_implicit) 1760 SETERRNO(EBADF,SS_IVCHAN); 1761 return FALSE; 1762 } 1763 io = GvIO(gv); 1764 if (!io) { /* never opened */ 1765 if (not_implicit) { 1766 report_evil_fh(gv); 1767 SETERRNO(EBADF,SS_IVCHAN); 1768 } 1769 return FALSE; 1770 } 1771 if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl)) 1772 && mg->mg_obj) { 1773 retval = argvout_final(mg, io, not_implicit); 1774 mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl); 1775 } 1776 else { 1777 retval = io_close(io, NULL, not_implicit, FALSE); 1778 } 1779 if (not_implicit) { 1780 IoLINES(io) = 0; 1781 IoPAGE(io) = 0; 1782 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1783 } 1784 IoTYPE(io) = IoTYPE_CLOSED; 1785 return retval; 1786 } 1787 1788 bool 1789 Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) 1790 { 1791 bool retval = FALSE; 1792 1793 PERL_ARGS_ASSERT_IO_CLOSE; 1794 1795 if (IoIFP(io)) { 1796 if (IoTYPE(io) == IoTYPE_PIPE) { 1797 PerlIO *fh = IoIFP(io); 1798 int status; 1799 1800 /* my_pclose() can propagate signals which might bypass any code 1801 after the call here if the signal handler throws an exception. 1802 This would leave the handle in the IO object and try to close it again 1803 when the SV is destroyed on unwind or global destruction. 1804 So NULL it early. 1805 */ 1806 IoOFP(io) = IoIFP(io) = NULL; 1807 status = PerlProc_pclose(fh); 1808 if (not_implicit) { 1809 STATUS_NATIVE_CHILD_SET(status); 1810 retval = (STATUS_UNIX == 0); 1811 } 1812 else { 1813 retval = (status != -1); 1814 } 1815 } 1816 else if (IoTYPE(io) == IoTYPE_STD) 1817 retval = TRUE; 1818 else { 1819 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ 1820 const bool prev_err = PerlIO_error(IoOFP(io)); 1821 #ifdef USE_PERLIO 1822 if (prev_err) 1823 PerlIO_restore_errno(IoOFP(io)); 1824 #endif 1825 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); 1826 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 1827 } 1828 else { 1829 const bool prev_err = PerlIO_error(IoIFP(io)); 1830 #ifdef USE_PERLIO 1831 if (prev_err) 1832 PerlIO_restore_errno(IoIFP(io)); 1833 #endif 1834 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); 1835 } 1836 } 1837 IoOFP(io) = IoIFP(io) = NULL; 1838 1839 if (warn_on_fail && !retval) { 1840 if (gv) 1841 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), 1842 "Warning: unable to close filehandle %" 1843 HEKf " properly: %" SVf, 1844 HEKfARG(GvNAME_HEK(gv)), 1845 SVfARG(get_sv("!",GV_ADD))); 1846 else 1847 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), 1848 "Warning: unable to close filehandle " 1849 "properly: %" SVf, 1850 SVfARG(get_sv("!",GV_ADD))); 1851 } 1852 } 1853 else if (not_implicit) { 1854 SETERRNO(EBADF,SS_IVCHAN); 1855 } 1856 1857 return retval; 1858 } 1859 1860 bool 1861 Perl_do_eof(pTHX_ GV *gv) 1862 { 1863 IO * const io = GvIO(gv); 1864 1865 PERL_ARGS_ASSERT_DO_EOF; 1866 1867 if (!io) 1868 return TRUE; 1869 else if (IoTYPE(io) == IoTYPE_WRONLY) 1870 report_wrongway_fh(gv, '>'); 1871 1872 while (IoIFP(io)) { 1873 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ 1874 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ 1875 return FALSE; /* this is the most usual case */ 1876 } 1877 1878 { 1879 /* getc and ungetc can stomp on errno */ 1880 dSAVE_ERRNO; 1881 const int ch = PerlIO_getc(IoIFP(io)); 1882 if (ch != EOF) { 1883 (void)PerlIO_ungetc(IoIFP(io),ch); 1884 RESTORE_ERRNO; 1885 return FALSE; 1886 } 1887 RESTORE_ERRNO; 1888 } 1889 1890 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { 1891 if (PerlIO_get_cnt(IoIFP(io)) < -1) 1892 PerlIO_set_cnt(IoIFP(io),-1); 1893 } 1894 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ 1895 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ 1896 return TRUE; 1897 } 1898 else 1899 return TRUE; /* normal fp, definitely end of file */ 1900 } 1901 return TRUE; 1902 } 1903 1904 Off_t 1905 Perl_do_tell(pTHX_ GV *gv) 1906 { 1907 IO *const io = GvIO(gv); 1908 PerlIO *fp; 1909 1910 PERL_ARGS_ASSERT_DO_TELL; 1911 1912 if (io && (fp = IoIFP(io))) { 1913 return PerlIO_tell(fp); 1914 } 1915 report_evil_fh(gv); 1916 SETERRNO(EBADF,RMS_IFI); 1917 return (Off_t)-1; 1918 } 1919 1920 bool 1921 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) 1922 { 1923 IO *const io = GvIO(gv); 1924 PerlIO *fp; 1925 1926 if (io && (fp = IoIFP(io))) { 1927 return PerlIO_seek(fp, pos, whence) >= 0; 1928 } 1929 report_evil_fh(gv); 1930 SETERRNO(EBADF,RMS_IFI); 1931 return FALSE; 1932 } 1933 1934 Off_t 1935 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) 1936 { 1937 IO *const io = GvIO(gv); 1938 PerlIO *fp; 1939 1940 PERL_ARGS_ASSERT_DO_SYSSEEK; 1941 1942 if (io && (fp = IoIFP(io))) { 1943 int fd = PerlIO_fileno(fp); 1944 if (fd < 0 || (whence == SEEK_SET && pos < 0)) { 1945 SETERRNO(EINVAL,LIB_INVARG); 1946 return -1; 1947 } else { 1948 return PerlLIO_lseek(fd, pos, whence); 1949 } 1950 } 1951 report_evil_fh(gv); 1952 SETERRNO(EBADF,RMS_IFI); 1953 return (Off_t)-1; 1954 } 1955 1956 int 1957 Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) 1958 { 1959 int mode = O_BINARY; 1960 PERL_UNUSED_CONTEXT; 1961 if (s) { 1962 while (*s) { 1963 if (*s == ':') { 1964 switch (s[1]) { 1965 case 'r': 1966 if (s[2] == 'a' && s[3] == 'w' 1967 && (!s[4] || s[4] == ':' || isSPACE(s[4]))) 1968 { 1969 mode = O_BINARY; 1970 s += 4; 1971 len -= 4; 1972 break; 1973 } 1974 /* FALLTHROUGH */ 1975 case 'c': 1976 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' 1977 && (!s[5] || s[5] == ':' || isSPACE(s[5]))) 1978 { 1979 mode = O_TEXT; 1980 s += 5; 1981 len -= 5; 1982 break; 1983 } 1984 /* FALLTHROUGH */ 1985 default: 1986 goto fail_discipline; 1987 } 1988 } 1989 else if (isSPACE(*s)) { 1990 ++s; 1991 --len; 1992 } 1993 else { 1994 const char *end; 1995 fail_discipline: 1996 end = (char *) memchr(s+1, ':', len); 1997 if (!end) 1998 end = s+len; 1999 #ifndef PERLIO_LAYERS 2000 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); 2001 #else 2002 len -= end-s; 2003 s = end; 2004 #endif 2005 } 2006 } 2007 } 2008 return mode; 2009 } 2010 2011 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) 2012 I32 2013 my_chsize(int fd, Off_t length) 2014 { 2015 #ifdef F_FREESP 2016 /* code courtesy of William Kucharski */ 2017 #define HAS_CHSIZE 2018 2019 Stat_t filebuf; 2020 2021 if (PerlLIO_fstat(fd, &filebuf) < 0) 2022 return -1; 2023 2024 if (filebuf.st_size < length) { 2025 2026 /* extend file length */ 2027 2028 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) 2029 return -1; 2030 2031 /* write a "0" byte */ 2032 2033 if ((PerlLIO_write(fd, "", 1)) != 1) 2034 return -1; 2035 } 2036 else { 2037 /* truncate length */ 2038 struct flock fl; 2039 fl.l_whence = 0; 2040 fl.l_len = 0; 2041 fl.l_start = length; 2042 fl.l_type = F_WRLCK; /* write lock on file space */ 2043 2044 /* 2045 * This relies on the UNDOCUMENTED F_FREESP argument to 2046 * fcntl(2), which truncates the file so that it ends at the 2047 * position indicated by fl.l_start. 2048 * 2049 * Will minor miracles never cease? 2050 */ 2051 2052 if (fcntl(fd, F_FREESP, &fl) < 0) 2053 return -1; 2054 2055 } 2056 return 0; 2057 #else 2058 Perl_croak_nocontext("truncate not implemented"); 2059 #endif /* F_FREESP */ 2060 return -1; 2061 } 2062 #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ 2063 2064 bool 2065 Perl_do_print(pTHX_ SV *sv, PerlIO *fp) 2066 { 2067 PERL_ARGS_ASSERT_DO_PRINT; 2068 2069 /* assuming fp is checked earlier */ 2070 if (!sv) 2071 return TRUE; 2072 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { 2073 assert(!SvGMAGICAL(sv)); 2074 if (SvIsUV(sv)) 2075 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); 2076 else 2077 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); 2078 return !PerlIO_error(fp); 2079 } 2080 else { 2081 STRLEN len; 2082 /* Do this first to trigger any overloading. */ 2083 const char *tmps = SvPV_const(sv, len); 2084 U8 *tmpbuf = NULL; 2085 bool happy = TRUE; 2086 2087 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ 2088 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ 2089 /* We don't modify the original scalar. */ 2090 tmpbuf = bytes_to_utf8((const U8*) tmps, &len); 2091 tmps = (char *) tmpbuf; 2092 } 2093 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { 2094 (void) check_utf8_print((const U8*) tmps, len); 2095 } 2096 } /* else stream isn't utf8 */ 2097 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to 2098 convert to bytes */ 2099 STRLEN tmplen = len; 2100 bool utf8 = TRUE; 2101 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); 2102 if (!utf8) { 2103 2104 /* Here, succeeded in downgrading from utf8. Set up to below 2105 * output the converted value */ 2106 tmpbuf = result; 2107 tmps = (char *) tmpbuf; 2108 len = tmplen; 2109 } 2110 else { /* Non-utf8 output stream, but string only representable in 2111 utf8 */ 2112 assert((char *)result == tmps); 2113 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), 2114 "Wide character in %s", 2115 PL_op ? OP_DESC(PL_op) : "print" 2116 ); 2117 /* Could also check that isn't one of the things to avoid 2118 * in utf8 by using check_utf8_print(), but not doing so, 2119 * since the stream isn't a UTF8 stream */ 2120 } 2121 } 2122 /* To detect whether the process is about to overstep its 2123 * filesize limit we would need getrlimit(). We could then 2124 * also transparently raise the limit with setrlimit() -- 2125 * but only until the system hard limit/the filesystem limit, 2126 * at which we would get EPERM. Note that when using buffered 2127 * io the write failure can be delayed until the flush/close. --jhi */ 2128 if (len && (PerlIO_write(fp,tmps,len) == 0)) 2129 happy = FALSE; 2130 Safefree(tmpbuf); 2131 return happy ? !PerlIO_error(fp) : FALSE; 2132 } 2133 } 2134 2135 I32 2136 Perl_my_stat_flags(pTHX_ const U32 flags) 2137 { 2138 dSP; 2139 IO *io; 2140 GV* gv; 2141 2142 if (PL_op->op_flags & OPf_REF) { 2143 gv = cGVOP_gv; 2144 do_fstat: 2145 if (gv == PL_defgv) { 2146 if (PL_laststatval < 0) 2147 SETERRNO(EBADF,RMS_IFI); 2148 return PL_laststatval; 2149 } 2150 io = GvIO(gv); 2151 do_fstat_have_io: 2152 PL_laststype = OP_STAT; 2153 PL_statgv = gv ? gv : (GV *)io; 2154 SvPVCLEAR(PL_statname); 2155 if (io) { 2156 if (IoIFP(io)) { 2157 int fd = PerlIO_fileno(IoIFP(io)); 2158 if (fd < 0) { 2159 /* E.g. PerlIO::scalar has no real fd. */ 2160 SETERRNO(EBADF,RMS_IFI); 2161 return (PL_laststatval = -1); 2162 } else { 2163 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache)); 2164 } 2165 } else if (IoDIRP(io)) { 2166 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); 2167 } 2168 } 2169 PL_laststatval = -1; 2170 report_evil_fh(gv); 2171 SETERRNO(EBADF,RMS_IFI); 2172 return -1; 2173 } 2174 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 2175 == OPpFT_STACKED) 2176 return PL_laststatval; 2177 else { 2178 SV* const sv = TOPs; 2179 const char *s, *d; 2180 STRLEN len; 2181 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { 2182 goto do_fstat; 2183 } 2184 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 2185 io = MUTABLE_IO(SvRV(sv)); 2186 gv = NULL; 2187 goto do_fstat_have_io; 2188 } 2189 2190 s = SvPV_flags_const(sv, len, flags); 2191 PL_statgv = NULL; 2192 sv_setpvn(PL_statname, s, len); 2193 d = SvPVX_const(PL_statname); /* s now NUL-terminated */ 2194 PL_laststype = OP_STAT; 2195 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) { 2196 PL_laststatval = -1; 2197 } 2198 else { 2199 PL_laststatval = PerlLIO_stat(d, &PL_statcache); 2200 } 2201 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { 2202 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ 2203 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 2204 GCC_DIAG_RESTORE_STMT; 2205 } 2206 return PL_laststatval; 2207 } 2208 } 2209 2210 2211 I32 2212 Perl_my_lstat_flags(pTHX_ const U32 flags) 2213 { 2214 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat"; 2215 dSP; 2216 const char *file; 2217 STRLEN len; 2218 SV* const sv = TOPs; 2219 bool isio = FALSE; 2220 if (PL_op->op_flags & OPf_REF) { 2221 if (cGVOP_gv == PL_defgv) { 2222 if (PL_laststype != OP_LSTAT) 2223 Perl_croak(aTHX_ "%s", no_prev_lstat); 2224 if (PL_laststatval < 0) 2225 SETERRNO(EBADF,RMS_IFI); 2226 return PL_laststatval; 2227 } 2228 PL_laststatval = -1; 2229 if (ckWARN(WARN_IO)) { 2230 /* diag_listed_as: Use of -l on filehandle%s */ 2231 Perl_warner(aTHX_ packWARN(WARN_IO), 2232 "Use of -l on filehandle %" HEKf, 2233 HEKfARG(GvENAME_HEK(cGVOP_gv))); 2234 } 2235 SETERRNO(EBADF,RMS_IFI); 2236 return -1; 2237 } 2238 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 2239 == OPpFT_STACKED) { 2240 if (PL_laststype != OP_LSTAT) 2241 Perl_croak(aTHX_ "%s", no_prev_lstat); 2242 return PL_laststatval; 2243 } 2244 2245 PL_laststype = OP_LSTAT; 2246 PL_statgv = NULL; 2247 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv)) 2248 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) ) 2249 ) 2250 || isGV_with_GP(sv) 2251 ) 2252 && ckWARN(WARN_IO)) { 2253 if (isio) 2254 /* diag_listed_as: Use of -l on filehandle%s */ 2255 Perl_warner(aTHX_ packWARN(WARN_IO), 2256 "Use of -l on filehandle"); 2257 else 2258 /* diag_listed_as: Use of -l on filehandle%s */ 2259 Perl_warner(aTHX_ packWARN(WARN_IO), 2260 "Use of -l on filehandle %" HEKf, 2261 HEKfARG(GvENAME_HEK((const GV *) 2262 (SvROK(sv) ? SvRV(sv) : sv)))); 2263 } 2264 file = SvPV_flags_const(sv, len, flags); 2265 sv_setpv(PL_statname,file); 2266 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) { 2267 PL_laststatval = -1; 2268 } 2269 else { 2270 PL_laststatval = PerlLIO_lstat(file,&PL_statcache); 2271 } 2272 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 2273 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ 2274 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); 2275 GCC_DIAG_RESTORE_STMT; 2276 } 2277 return PL_laststatval; 2278 } 2279 2280 static void 2281 S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) 2282 { 2283 const int e = errno; 2284 PERL_ARGS_ASSERT_EXEC_FAILED; 2285 2286 if (ckWARN(WARN_EXEC)) 2287 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", 2288 cmd, Strerror(e)); 2289 if (do_report) { 2290 /* XXX silently ignore failures */ 2291 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int))); 2292 PerlLIO_close(fd); 2293 } 2294 } 2295 2296 bool 2297 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, 2298 int fd, int do_report) 2299 { 2300 dVAR; 2301 PERL_ARGS_ASSERT_DO_AEXEC5; 2302 #if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) 2303 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); 2304 #else 2305 assert(sp >= mark); 2306 ENTER; 2307 { 2308 const char **argv, **a; 2309 const char *tmps = NULL; 2310 Newx(argv, sp - mark + 1, const char*); 2311 SAVEFREEPV(argv); 2312 a = argv; 2313 2314 while (++mark <= sp) { 2315 if (*mark) { 2316 char *arg = savepv(SvPV_nolen_const(*mark)); 2317 SAVEFREEPV(arg); 2318 *a++ = arg; 2319 } else 2320 *a++ = ""; 2321 } 2322 *a = NULL; 2323 if (really) { 2324 tmps = savepv(SvPV_nolen_const(really)); 2325 SAVEFREEPV(tmps); 2326 } 2327 if ((!really && argv[0] && *argv[0] != '/') || 2328 (really && *tmps != '/')) /* will execvp use PATH? */ 2329 TAINT_ENV(); /* testing IFS here is overkill, probably */ 2330 PERL_FPU_PRE_EXEC 2331 if (really && *tmps) { 2332 PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv)); 2333 } else if (argv[0]) { 2334 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); 2335 } else { 2336 SETERRNO(ENOENT,RMS_FNF); 2337 } 2338 PERL_FPU_POST_EXEC 2339 S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report); 2340 } 2341 LEAVE; 2342 #endif 2343 return FALSE; 2344 } 2345 2346 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION 2347 2348 bool 2349 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) 2350 { 2351 dVAR; 2352 const char **argv, **a; 2353 char *s; 2354 char *buf; 2355 char *cmd; 2356 /* Make a copy so we can change it */ 2357 const Size_t cmdlen = strlen(incmd) + 1; 2358 2359 PERL_ARGS_ASSERT_DO_EXEC3; 2360 2361 ENTER; 2362 Newx(buf, cmdlen, char); 2363 SAVEFREEPV(buf); 2364 cmd = buf; 2365 memcpy(cmd, incmd, cmdlen); 2366 2367 while (*cmd && isSPACE(*cmd)) 2368 cmd++; 2369 2370 /* save an extra exec if possible */ 2371 2372 #ifdef CSH 2373 { 2374 char flags[PERL_FLAGS_MAX]; 2375 if (strnEQ(cmd,PL_cshname,PL_cshlen) && 2376 strBEGINs(cmd+PL_cshlen," -c")) { 2377 my_strlcpy(flags, "-c", PERL_FLAGS_MAX); 2378 s = cmd+PL_cshlen+3; 2379 if (*s == 'f') { 2380 s++; 2381 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2); 2382 } 2383 if (*s == ' ') 2384 s++; 2385 if (*s++ == '\'') { 2386 char * const ncmd = s; 2387 2388 while (*s) 2389 s++; 2390 if (s[-1] == '\n') 2391 *--s = '\0'; 2392 if (s[-1] == '\'') { 2393 *--s = '\0'; 2394 PERL_FPU_PRE_EXEC 2395 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); 2396 PERL_FPU_POST_EXEC 2397 *s = '\''; 2398 S_exec_failed(aTHX_ PL_cshname, fd, do_report); 2399 goto leave; 2400 } 2401 } 2402 } 2403 } 2404 #endif /* CSH */ 2405 2406 /* see if there are shell metacharacters in it */ 2407 2408 if (*cmd == '.' && isSPACE(cmd[1])) 2409 goto doshell; 2410 2411 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4])) 2412 goto doshell; 2413 2414 s = cmd; 2415 while (isWORDCHAR(*s)) 2416 s++; /* catch VAR=val gizmo */ 2417 if (*s == '=') 2418 goto doshell; 2419 2420 for (s = cmd; *s; s++) { 2421 if (*s != ' ' && !isALPHA(*s) && 2422 memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { 2423 if (*s == '\n' && !s[1]) { 2424 *s = '\0'; 2425 break; 2426 } 2427 /* handle the 2>&1 construct at the end */ 2428 if (*s == '>' && s[1] == '&' && s[2] == '1' 2429 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) 2430 && (!s[3] || isSPACE(s[3]))) 2431 { 2432 const char *t = s + 3; 2433 2434 while (*t && isSPACE(*t)) 2435 ++t; 2436 if (!*t && (PerlLIO_dup2(1,2) != -1)) { 2437 s[-2] = '\0'; 2438 break; 2439 } 2440 } 2441 doshell: 2442 PERL_FPU_PRE_EXEC 2443 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); 2444 PERL_FPU_POST_EXEC 2445 S_exec_failed(aTHX_ PL_sh_path, fd, do_report); 2446 goto leave; 2447 } 2448 } 2449 2450 Newx(argv, (s - cmd) / 2 + 2, const char*); 2451 SAVEFREEPV(argv); 2452 cmd = savepvn(cmd, s-cmd); 2453 SAVEFREEPV(cmd); 2454 a = argv; 2455 for (s = cmd; *s;) { 2456 while (isSPACE(*s)) 2457 s++; 2458 if (*s) 2459 *(a++) = s; 2460 while (*s && !isSPACE(*s)) 2461 s++; 2462 if (*s) 2463 *s++ = '\0'; 2464 } 2465 *a = NULL; 2466 if (argv[0]) { 2467 PERL_FPU_PRE_EXEC 2468 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); 2469 PERL_FPU_POST_EXEC 2470 if (errno == ENOEXEC) /* for system V NIH syndrome */ 2471 goto doshell; 2472 S_exec_failed(aTHX_ argv[0], fd, do_report); 2473 } 2474 leave: 2475 LEAVE; 2476 return FALSE; 2477 } 2478 2479 #endif /* OS2 || WIN32 */ 2480 2481 I32 2482 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) 2483 { 2484 I32 val; 2485 I32 tot = 0; 2486 const char *const what = PL_op_name[type]; 2487 const char *s; 2488 STRLEN len; 2489 SV ** const oldmark = mark; 2490 bool killgp = FALSE; 2491 2492 PERL_ARGS_ASSERT_APPLY; 2493 2494 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */ 2495 2496 /* Doing this ahead of the switch statement preserves the old behaviour, 2497 where attempting to use kill as a taint test would fail on 2498 platforms where kill was not defined. */ 2499 #ifndef HAS_KILL 2500 if (type == OP_KILL) 2501 Perl_die(aTHX_ PL_no_func, what); 2502 #endif 2503 #ifndef HAS_CHOWN 2504 if (type == OP_CHOWN) 2505 Perl_die(aTHX_ PL_no_func, what); 2506 #endif 2507 2508 2509 #define APPLY_TAINT_PROPER() \ 2510 STMT_START { \ 2511 if (TAINT_get) { TAINT_PROPER(what); } \ 2512 } STMT_END 2513 2514 /* This is a first heuristic; it doesn't catch tainting magic. */ 2515 if (TAINTING_get) { 2516 while (++mark <= sp) { 2517 if (SvTAINTED(*mark)) { 2518 TAINT; 2519 break; 2520 } 2521 } 2522 mark = oldmark; 2523 } 2524 switch (type) { 2525 case OP_CHMOD: 2526 APPLY_TAINT_PROPER(); 2527 if (++mark <= sp) { 2528 val = SvIV(*mark); 2529 APPLY_TAINT_PROPER(); 2530 tot = sp - mark; 2531 while (++mark <= sp) { 2532 GV* gv; 2533 if ((gv = MAYBE_DEREF_GV(*mark))) { 2534 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 2535 #ifdef HAS_FCHMOD 2536 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 2537 APPLY_TAINT_PROPER(); 2538 if (fd < 0) { 2539 SETERRNO(EBADF,RMS_IFI); 2540 tot--; 2541 } else if (fchmod(fd, val)) 2542 tot--; 2543 #else 2544 Perl_die(aTHX_ PL_no_func, "fchmod"); 2545 #endif 2546 } 2547 else { 2548 SETERRNO(EBADF,RMS_IFI); 2549 tot--; 2550 } 2551 } 2552 else { 2553 const char *name = SvPV_nomg_const(*mark, len); 2554 APPLY_TAINT_PROPER(); 2555 if (!IS_SAFE_PATHNAME(name, len, "chmod") || 2556 PerlLIO_chmod(name, val)) { 2557 tot--; 2558 } 2559 } 2560 } 2561 } 2562 break; 2563 #ifdef HAS_CHOWN 2564 case OP_CHOWN: 2565 APPLY_TAINT_PROPER(); 2566 if (sp - mark > 2) { 2567 I32 val2; 2568 val = SvIVx(*++mark); 2569 val2 = SvIVx(*++mark); 2570 APPLY_TAINT_PROPER(); 2571 tot = sp - mark; 2572 while (++mark <= sp) { 2573 GV* gv; 2574 if ((gv = MAYBE_DEREF_GV(*mark))) { 2575 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 2576 #ifdef HAS_FCHOWN 2577 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 2578 APPLY_TAINT_PROPER(); 2579 if (fd < 0) { 2580 SETERRNO(EBADF,RMS_IFI); 2581 tot--; 2582 } else if (fchown(fd, val, val2)) 2583 tot--; 2584 #else 2585 Perl_die(aTHX_ PL_no_func, "fchown"); 2586 #endif 2587 } 2588 else { 2589 SETERRNO(EBADF,RMS_IFI); 2590 tot--; 2591 } 2592 } 2593 else { 2594 const char *name = SvPV_nomg_const(*mark, len); 2595 APPLY_TAINT_PROPER(); 2596 if (!IS_SAFE_PATHNAME(name, len, "chown") || 2597 PerlLIO_chown(name, val, val2)) { 2598 tot--; 2599 } 2600 } 2601 } 2602 } 2603 break; 2604 #endif 2605 /* 2606 XXX Should we make lchown() directly available from perl? 2607 For now, we'll let Configure test for HAS_LCHOWN, but do 2608 nothing in the core. 2609 --AD 5/1998 2610 */ 2611 #ifdef HAS_KILL 2612 case OP_KILL: 2613 APPLY_TAINT_PROPER(); 2614 if (mark == sp) 2615 break; 2616 s = SvPVx_const(*++mark, len); 2617 if (*s == '-' && isALPHA(s[1])) 2618 { 2619 s++; 2620 len--; 2621 killgp = TRUE; 2622 } 2623 if (isALPHA(*s)) { 2624 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { 2625 s += 3; 2626 len -= 3; 2627 } 2628 if ((val = whichsig_pvn(s, len)) < 0) 2629 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"", 2630 SVfARG(*mark)); 2631 } 2632 else 2633 { 2634 val = SvIV(*mark); 2635 if (val < 0) 2636 { 2637 killgp = TRUE; 2638 val = -val; 2639 } 2640 } 2641 APPLY_TAINT_PROPER(); 2642 tot = sp - mark; 2643 2644 while (++mark <= sp) { 2645 Pid_t proc; 2646 SvGETMAGIC(*mark); 2647 if (!(SvNIOK(*mark) || looks_like_number(*mark))) 2648 Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); 2649 proc = SvIV_nomg(*mark); 2650 APPLY_TAINT_PROPER(); 2651 #ifdef HAS_KILLPG 2652 /* use killpg in preference, as the killpg() wrapper for Win32 2653 * understands process groups, but the kill() wrapper doesn't */ 2654 if (killgp ? PerlProc_killpg(proc, val) 2655 : PerlProc_kill(proc, val)) 2656 #else 2657 if (PerlProc_kill(killgp ? -proc: proc, val)) 2658 #endif 2659 tot--; 2660 } 2661 PERL_ASYNC_CHECK(); 2662 break; 2663 #endif 2664 case OP_UNLINK: 2665 APPLY_TAINT_PROPER(); 2666 tot = sp - mark; 2667 while (++mark <= sp) { 2668 s = SvPV_const(*mark, len); 2669 APPLY_TAINT_PROPER(); 2670 if (!IS_SAFE_PATHNAME(s, len, "unlink")) { 2671 tot--; 2672 } 2673 else if (PL_unsafe) { 2674 if (UNLINK(s)) 2675 { 2676 tot--; 2677 } 2678 #if defined(__amigaos4__) && defined(NEWLIB) 2679 else 2680 { 2681 /* Under AmigaOS4 unlink only 'fails' if the 2682 * filename is invalid. It may not remove the file 2683 * if it's locked, so check if it's still around. */ 2684 if ((access(s,F_OK) != -1)) 2685 { 2686 tot--; 2687 } 2688 } 2689 #endif 2690 } 2691 else { /* don't let root wipe out directories without -U */ 2692 Stat_t statbuf; 2693 if (PerlLIO_lstat(s, &statbuf) < 0) 2694 tot--; 2695 else if (S_ISDIR(statbuf.st_mode)) { 2696 SETERRNO(EISDIR, SS_NOPRIV); 2697 tot--; 2698 } 2699 else { 2700 if (UNLINK(s)) 2701 { 2702 tot--; 2703 } 2704 #if defined(__amigaos4__) && defined(NEWLIB) 2705 else 2706 { 2707 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ 2708 /* It may not remove the file if it's Locked, so check if it's still */ 2709 /* arround */ 2710 if((access(s,F_OK) != -1)) 2711 { 2712 tot--; 2713 } 2714 } 2715 #endif 2716 } 2717 } 2718 } 2719 break; 2720 #if defined(HAS_UTIME) || defined(HAS_FUTIMES) 2721 case OP_UTIME: 2722 APPLY_TAINT_PROPER(); 2723 if (sp - mark > 2) { 2724 #if defined(HAS_FUTIMES) 2725 struct timeval utbuf[2]; 2726 void *utbufp = utbuf; 2727 #elif defined(I_UTIME) || defined(VMS) 2728 struct utimbuf utbuf; 2729 struct utimbuf *utbufp = &utbuf; 2730 #else 2731 struct { 2732 Time_t actime; 2733 Time_t modtime; 2734 } utbuf; 2735 void *utbufp = &utbuf; 2736 #endif 2737 2738 SV* const accessed = *++mark; 2739 SV* const modified = *++mark; 2740 2741 /* Be like C, and if both times are undefined, let the C 2742 * library figure out what to do. This usually means 2743 * "current time". */ 2744 2745 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) 2746 utbufp = NULL; 2747 else { 2748 Zero(&utbuf, sizeof utbuf, char); 2749 #ifdef HAS_FUTIMES 2750 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ 2751 utbuf[0].tv_usec = 0; 2752 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ 2753 utbuf[1].tv_usec = 0; 2754 #elif defined(BIG_TIME) 2755 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */ 2756 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */ 2757 #else 2758 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */ 2759 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */ 2760 #endif 2761 } 2762 APPLY_TAINT_PROPER(); 2763 tot = sp - mark; 2764 while (++mark <= sp) { 2765 GV* gv; 2766 if ((gv = MAYBE_DEREF_GV(*mark))) { 2767 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 2768 #ifdef HAS_FUTIMES 2769 int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); 2770 APPLY_TAINT_PROPER(); 2771 if (fd < 0) { 2772 SETERRNO(EBADF,RMS_IFI); 2773 tot--; 2774 } else if (futimes(fd, (struct timeval *) utbufp)) 2775 tot--; 2776 #else 2777 Perl_die(aTHX_ PL_no_func, "futimes"); 2778 #endif 2779 } 2780 else { 2781 tot--; 2782 } 2783 } 2784 else { 2785 const char * const name = SvPV_nomg_const(*mark, len); 2786 APPLY_TAINT_PROPER(); 2787 if (!IS_SAFE_PATHNAME(name, len, "utime")) { 2788 tot--; 2789 } 2790 else 2791 #ifdef HAS_FUTIMES 2792 if (utimes(name, (struct timeval *)utbufp)) 2793 #else 2794 if (PerlLIO_utime(name, utbufp)) 2795 #endif 2796 tot--; 2797 } 2798 2799 } 2800 } 2801 else 2802 tot = 0; 2803 break; 2804 #endif 2805 } 2806 return tot; 2807 2808 #undef APPLY_TAINT_PROPER 2809 } 2810 2811 /* Do the permissions in *statbufp allow some operation? */ 2812 #ifndef VMS /* VMS' cando is in vms.c */ 2813 bool 2814 Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) 2815 /* effective is a flag, true for EUID, or for checking if the effective gid 2816 * is in the list of groups returned from getgroups(). 2817 */ 2818 { 2819 PERL_ARGS_ASSERT_CANDO; 2820 PERL_UNUSED_CONTEXT; 2821 2822 #ifdef DOSISH 2823 /* [Comments and code from Len Reed] 2824 * MS-DOS "user" is similar to UNIX's "superuser," but can't write 2825 * to write-protected files. The execute permission bit is set 2826 * by the Microsoft C library stat() function for the following: 2827 * .exe files 2828 * .com files 2829 * .bat files 2830 * directories 2831 * All files and directories are readable. 2832 * Directories and special files, e.g. "CON", cannot be 2833 * write-protected. 2834 * [Comment by Tom Dinger -- a directory can have the write-protect 2835 * bit set in the file system, but DOS permits changes to 2836 * the directory anyway. In addition, all bets are off 2837 * here for networked software, such as Novell and 2838 * Sun's PC-NFS.] 2839 */ 2840 2841 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat 2842 * too so it will actually look into the files for magic numbers 2843 */ 2844 return cBOOL(mode & statbufp->st_mode); 2845 2846 #else /* ! DOSISH */ 2847 # ifdef __CYGWIN__ 2848 if (ingroup(544,effective)) { /* member of Administrators */ 2849 # else 2850 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */ 2851 # endif 2852 if (mode == S_IXUSR) { 2853 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) 2854 return TRUE; 2855 } 2856 else 2857 return TRUE; /* root reads and writes anything */ 2858 return FALSE; 2859 } 2860 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) { 2861 if (statbufp->st_mode & mode) 2862 return TRUE; /* ok as "user" */ 2863 } 2864 else if (ingroup(statbufp->st_gid,effective)) { 2865 if (statbufp->st_mode & mode >> 3) 2866 return TRUE; /* ok as "group" */ 2867 } 2868 else if (statbufp->st_mode & mode >> 6) 2869 return TRUE; /* ok as "other" */ 2870 return FALSE; 2871 #endif /* ! DOSISH */ 2872 } 2873 #endif /* ! VMS */ 2874 2875 static bool 2876 S_ingroup(pTHX_ Gid_t testgid, bool effective) 2877 { 2878 #ifndef PERL_IMPLICIT_SYS 2879 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */ 2880 PERL_UNUSED_CONTEXT; 2881 #endif 2882 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid())) 2883 return TRUE; 2884 #ifdef HAS_GETGROUPS 2885 { 2886 Groups_t *gary = NULL; 2887 I32 anum; 2888 bool rc = FALSE; 2889 2890 anum = getgroups(0, gary); 2891 if (anum > 0) { 2892 Newx(gary, anum, Groups_t); 2893 anum = getgroups(anum, gary); 2894 while (--anum >= 0) 2895 if (gary[anum] == testgid) { 2896 rc = TRUE; 2897 break; 2898 } 2899 2900 Safefree(gary); 2901 } 2902 return rc; 2903 } 2904 #else 2905 return FALSE; 2906 #endif 2907 } 2908 2909 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 2910 2911 I32 2912 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) 2913 { 2914 const key_t key = (key_t)SvNVx(*++mark); 2915 SV *nsv = optype == OP_MSGGET ? NULL : *++mark; 2916 const I32 flags = SvIVx(*++mark); 2917 2918 PERL_ARGS_ASSERT_DO_IPCGET; 2919 PERL_UNUSED_ARG(sp); 2920 2921 SETERRNO(0,0); 2922 switch (optype) 2923 { 2924 #ifdef HAS_MSG 2925 case OP_MSGGET: 2926 return msgget(key, flags); 2927 #endif 2928 #ifdef HAS_SEM 2929 case OP_SEMGET: 2930 return semget(key, (int) SvIV(nsv), flags); 2931 #endif 2932 #ifdef HAS_SHM 2933 case OP_SHMGET: 2934 return shmget(key, (size_t) SvUV(nsv), flags); 2935 #endif 2936 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 2937 default: 2938 /* diag_listed_as: msg%s not implemented */ 2939 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2940 #endif 2941 } 2942 return -1; /* should never happen */ 2943 } 2944 2945 I32 2946 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) 2947 { 2948 char *a; 2949 I32 ret = -1; 2950 const I32 id = SvIVx(*++mark); 2951 #ifdef Semctl 2952 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; 2953 #endif 2954 const I32 cmd = SvIVx(*++mark); 2955 SV * const astr = *++mark; 2956 STRLEN infosize = 0; 2957 I32 getinfo = (cmd == IPC_STAT); 2958 2959 PERL_ARGS_ASSERT_DO_IPCCTL; 2960 PERL_UNUSED_ARG(sp); 2961 2962 switch (optype) 2963 { 2964 #ifdef HAS_MSG 2965 case OP_MSGCTL: 2966 if (cmd == IPC_STAT || cmd == IPC_SET) 2967 infosize = sizeof(struct msqid_ds); 2968 break; 2969 #endif 2970 #ifdef HAS_SHM 2971 case OP_SHMCTL: 2972 if (cmd == IPC_STAT || cmd == IPC_SET) 2973 infosize = sizeof(struct shmid_ds); 2974 break; 2975 #endif 2976 #ifdef HAS_SEM 2977 case OP_SEMCTL: 2978 #ifdef Semctl 2979 if (cmd == IPC_STAT || cmd == IPC_SET) 2980 infosize = sizeof(struct semid_ds); 2981 else if (cmd == GETALL || cmd == SETALL) 2982 { 2983 struct semid_ds semds; 2984 union semun semun; 2985 #ifdef EXTRA_F_IN_SEMUN_BUF 2986 semun.buff = &semds; 2987 #else 2988 semun.buf = &semds; 2989 #endif 2990 getinfo = (cmd == GETALL); 2991 if (Semctl(id, 0, IPC_STAT, semun) == -1) 2992 return -1; 2993 infosize = semds.sem_nsems * sizeof(short); 2994 /* "short" is technically wrong but much more portable 2995 than guessing about u_?short(_t)? */ 2996 } 2997 #else 2998 /* diag_listed_as: sem%s not implemented */ 2999 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 3000 #endif 3001 break; 3002 #endif 3003 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 3004 default: 3005 /* diag_listed_as: shm%s not implemented */ 3006 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 3007 #endif 3008 } 3009 3010 if (infosize) 3011 { 3012 if (getinfo) 3013 { 3014 SvPV_force_nolen(astr); 3015 a = SvGROW(astr, infosize+1); 3016 } 3017 else 3018 { 3019 STRLEN len; 3020 a = SvPV(astr, len); 3021 if (len != infosize) 3022 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", 3023 PL_op_desc[optype], 3024 (unsigned long)len, 3025 (long)infosize); 3026 } 3027 } 3028 else 3029 { 3030 const IV i = SvIV(astr); 3031 a = INT2PTR(char *,i); /* ouch */ 3032 } 3033 SETERRNO(0,0); 3034 switch (optype) 3035 { 3036 #ifdef HAS_MSG 3037 case OP_MSGCTL: 3038 ret = msgctl(id, cmd, (struct msqid_ds *)a); 3039 break; 3040 #endif 3041 #ifdef HAS_SEM 3042 case OP_SEMCTL: { 3043 #ifdef Semctl 3044 union semun unsemds; 3045 3046 if(cmd == SETVAL) { 3047 unsemds.val = PTR2nat(a); 3048 } 3049 else { 3050 #ifdef EXTRA_F_IN_SEMUN_BUF 3051 unsemds.buff = (struct semid_ds *)a; 3052 #else 3053 unsemds.buf = (struct semid_ds *)a; 3054 #endif 3055 } 3056 ret = Semctl(id, n, cmd, unsemds); 3057 #else 3058 /* diag_listed_as: sem%s not implemented */ 3059 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 3060 #endif 3061 } 3062 break; 3063 #endif 3064 #ifdef HAS_SHM 3065 case OP_SHMCTL: 3066 ret = shmctl(id, cmd, (struct shmid_ds *)a); 3067 break; 3068 #endif 3069 } 3070 if (getinfo && ret >= 0) { 3071 SvCUR_set(astr, infosize); 3072 *SvEND(astr) = '\0'; 3073 SvSETMAGIC(astr); 3074 } 3075 return ret; 3076 } 3077 3078 I32 3079 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) 3080 { 3081 #ifdef HAS_MSG 3082 STRLEN len; 3083 const I32 id = SvIVx(*++mark); 3084 SV * const mstr = *++mark; 3085 const I32 flags = SvIVx(*++mark); 3086 const char * const mbuf = SvPV_const(mstr, len); 3087 const I32 msize = len - sizeof(long); 3088 3089 PERL_ARGS_ASSERT_DO_MSGSND; 3090 PERL_UNUSED_ARG(sp); 3091 3092 if (msize < 0) 3093 Perl_croak(aTHX_ "Arg too short for msgsnd"); 3094 SETERRNO(0,0); 3095 if (id >= 0 && flags >= 0) { 3096 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); 3097 } else { 3098 SETERRNO(EINVAL,LIB_INVARG); 3099 return -1; 3100 } 3101 #else 3102 PERL_UNUSED_ARG(sp); 3103 PERL_UNUSED_ARG(mark); 3104 /* diag_listed_as: msg%s not implemented */ 3105 Perl_croak(aTHX_ "msgsnd not implemented"); 3106 return -1; 3107 #endif 3108 } 3109 3110 I32 3111 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) 3112 { 3113 #ifdef HAS_MSG 3114 char *mbuf; 3115 long mtype; 3116 I32 msize, flags, ret; 3117 const I32 id = SvIVx(*++mark); 3118 SV * const mstr = *++mark; 3119 3120 PERL_ARGS_ASSERT_DO_MSGRCV; 3121 PERL_UNUSED_ARG(sp); 3122 3123 /* suppress warning when reading into undef var --jhi */ 3124 if (! SvOK(mstr)) 3125 SvPVCLEAR(mstr); 3126 msize = SvIVx(*++mark); 3127 mtype = (long)SvIVx(*++mark); 3128 flags = SvIVx(*++mark); 3129 SvPV_force_nolen(mstr); 3130 mbuf = SvGROW(mstr, sizeof(long)+msize+1); 3131 3132 SETERRNO(0,0); 3133 if (id >= 0 && msize >= 0 && flags >= 0) { 3134 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); 3135 } else { 3136 SETERRNO(EINVAL,LIB_INVARG); 3137 ret = -1; 3138 } 3139 if (ret >= 0) { 3140 SvCUR_set(mstr, sizeof(long)+ret); 3141 *SvEND(mstr) = '\0'; 3142 /* who knows who has been playing with this message? */ 3143 SvTAINTED_on(mstr); 3144 } 3145 return ret; 3146 #else 3147 PERL_UNUSED_ARG(sp); 3148 PERL_UNUSED_ARG(mark); 3149 /* diag_listed_as: msg%s not implemented */ 3150 Perl_croak(aTHX_ "msgrcv not implemented"); 3151 return -1; 3152 #endif 3153 } 3154 3155 I32 3156 Perl_do_semop(pTHX_ SV **mark, SV **sp) 3157 { 3158 #ifdef HAS_SEM 3159 STRLEN opsize; 3160 const I32 id = SvIVx(*++mark); 3161 SV * const opstr = *++mark; 3162 const char * const opbuf = SvPV_const(opstr, opsize); 3163 3164 PERL_ARGS_ASSERT_DO_SEMOP; 3165 PERL_UNUSED_ARG(sp); 3166 3167 if (opsize < 3 * SHORTSIZE 3168 || (opsize % (3 * SHORTSIZE))) { 3169 SETERRNO(EINVAL,LIB_INVARG); 3170 return -1; 3171 } 3172 SETERRNO(0,0); 3173 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ 3174 { 3175 const int nsops = opsize / (3 * sizeof (short)); 3176 int i = nsops; 3177 short * const ops = (short *) opbuf; 3178 short *o = ops; 3179 struct sembuf *temps, *t; 3180 I32 result; 3181 3182 Newx (temps, nsops, struct sembuf); 3183 t = temps; 3184 while (i--) { 3185 t->sem_num = *o++; 3186 t->sem_op = *o++; 3187 t->sem_flg = *o++; 3188 t++; 3189 } 3190 result = semop(id, temps, nsops); 3191 Safefree(temps); 3192 return result; 3193 } 3194 #else 3195 /* diag_listed_as: sem%s not implemented */ 3196 Perl_croak(aTHX_ "semop not implemented"); 3197 #endif 3198 } 3199 3200 I32 3201 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 3202 { 3203 #ifdef HAS_SHM 3204 char *shm; 3205 struct shmid_ds shmds; 3206 const I32 id = SvIVx(*++mark); 3207 SV * const mstr = *++mark; 3208 const I32 mpos = SvIVx(*++mark); 3209 const I32 msize = SvIVx(*++mark); 3210 3211 PERL_ARGS_ASSERT_DO_SHMIO; 3212 PERL_UNUSED_ARG(sp); 3213 3214 SETERRNO(0,0); 3215 if (shmctl(id, IPC_STAT, &shmds) == -1) 3216 return -1; 3217 if (mpos < 0 || msize < 0 3218 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { 3219 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ 3220 return -1; 3221 } 3222 if (id >= 0) { 3223 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); 3224 } else { 3225 SETERRNO(EINVAL,LIB_INVARG); 3226 return -1; 3227 } 3228 if (shm == (char *)-1) /* I hate System V IPC, I really do */ 3229 return -1; 3230 if (optype == OP_SHMREAD) { 3231 char *mbuf; 3232 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ 3233 SvGETMAGIC(mstr); 3234 SvUPGRADE(mstr, SVt_PV); 3235 if (! SvOK(mstr)) 3236 SvPVCLEAR(mstr); 3237 SvPOK_only(mstr); 3238 mbuf = SvGROW(mstr, (STRLEN)msize+1); 3239 3240 Copy(shm + mpos, mbuf, msize, char); 3241 SvCUR_set(mstr, msize); 3242 *SvEND(mstr) = '\0'; 3243 SvSETMAGIC(mstr); 3244 /* who knows who has been playing with this shared memory? */ 3245 SvTAINTED_on(mstr); 3246 } 3247 else { 3248 STRLEN len; 3249 3250 const char *mbuf = SvPV_const(mstr, len); 3251 const I32 n = ((I32)len > msize) ? msize : (I32)len; 3252 Copy(mbuf, shm + mpos, n, char); 3253 if (n < msize) 3254 memzero(shm + mpos + n, msize - n); 3255 } 3256 return shmdt(shm); 3257 #else 3258 /* diag_listed_as: shm%s not implemented */ 3259 Perl_croak(aTHX_ "shm I/O not implemented"); 3260 return -1; 3261 #endif 3262 } 3263 3264 #endif /* SYSV IPC */ 3265 3266 /* 3267 =head1 IO Functions 3268 3269 =for apidoc start_glob 3270 3271 Function called by C<do_readline> to spawn a glob (or do the glob inside 3272 perl on VMS). This code used to be inline, but now perl uses C<File::Glob> 3273 this glob starter is only used by miniperl during the build process, 3274 or when PERL_EXTERNAL_GLOB is defined. 3275 Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up. 3276 3277 =cut 3278 */ 3279 3280 PerlIO * 3281 Perl_start_glob (pTHX_ SV *tmpglob, IO *io) 3282 { 3283 SV * const tmpcmd = newSV(0); 3284 PerlIO *fp; 3285 STRLEN len; 3286 const char *s = SvPV(tmpglob, len); 3287 3288 PERL_ARGS_ASSERT_START_GLOB; 3289 3290 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob")) 3291 return NULL; 3292 3293 ENTER; 3294 SAVEFREESV(tmpcmd); 3295 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ 3296 /* since spawning off a process is a real performance hit */ 3297 3298 PerlIO * 3299 Perl_vms_start_glob 3300 (pTHX_ SV *tmpglob, 3301 IO *io); 3302 3303 fp = Perl_vms_start_glob(aTHX_ tmpglob, io); 3304 3305 #else /* !VMS */ 3306 # ifdef DOSISH 3307 # if defined(OS2) 3308 sv_setpv(tmpcmd, "for a in "); 3309 sv_catsv(tmpcmd, tmpglob); 3310 sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); 3311 # elif defined(DJGPP) 3312 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ 3313 sv_catsv(tmpcmd, tmpglob); 3314 # else 3315 sv_setpv(tmpcmd, "perlglob "); 3316 sv_catsv(tmpcmd, tmpglob); 3317 sv_catpvs(tmpcmd, " |"); 3318 # endif 3319 # elif defined(CSH) 3320 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); 3321 sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob "); 3322 sv_catsv(tmpcmd, tmpglob); 3323 sv_catpvs(tmpcmd, "' 2>/dev/null |"); 3324 # else 3325 sv_setpv(tmpcmd, "echo "); 3326 sv_catsv(tmpcmd, tmpglob); 3327 sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); 3328 # endif /* !DOSISH && !CSH */ 3329 { 3330 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0); 3331 if (svp && *svp) 3332 save_helem_flags(GvHV(PL_envgv), 3333 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp, 3334 SAVEf_SETMAGIC); 3335 } 3336 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd), 3337 NULL, NULL, 0); 3338 fp = IoIFP(io); 3339 #endif /* !VMS */ 3340 LEAVE; 3341 3342 if (!fp && ckWARN(WARN_GLOB)) { 3343 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", 3344 Strerror(errno)); 3345 } 3346 3347 return fp; 3348 } 3349 3350 /* 3351 * ex: set ts=8 sts=4 sw=4 et: 3352 */ 3353