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