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