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