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